︙ | | | ︙ | |
845
846
847
848
849
850
851
852
853
854
855
856
857
858
|
;;; it has been at least 10 seconds
(runs:testdat-prereqs-not-met testdat) ;; return the cached result
(let* ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: mode itemmaps: itemmaps)))
(runs:testdat-prereqs-not-met-set! testdat res)
(runs:testdat-last-update-set! testdat (current-seconds))
res)))
;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;; (let loop ((hed (car sorted-test-names))
;; (tal (cdr sorted-test-names))
|
>
|
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
|
;;; it has been at least 10 seconds
(runs:testdat-prereqs-not-met testdat) ;; return the cached result
(let* ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: mode itemmaps: itemmaps)))
(runs:testdat-prereqs-not-met-set! testdat res)
(runs:testdat-last-update-set! testdat (current-seconds))
res)))
;;======================================================================
;; runs:expand-items is called by runs:run-tests-queue
;;======================================================================
;;
;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature:
;; (let loop ((hed (car sorted-test-names))
;; (tal (cdr sorted-test-names))
|
︙ | | | ︙ | |
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
|
(runnables (runs:calc-runnable prereqs-not-met))
(unexpanded-prereqs
(filter (lambda (testname)
(let* ((test-rec (hash-table-ref test-records testname))
(items (tests:testqueue-get-items test-rec)))
;;(BB> "HEY " testname "=>"items)
(or (procedure? items)(eq? items 'have-procedure))))
waitons))
)
(debug:print-info 4 *default-log-port* "START OF INNER COND #2 "
"\n can-run-more: " can-run-more
"\n testname: " hed
"\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
"\n non-completed: " (runs:pretty-string non-completed)
"\n prereq-fails: " (runs:pretty-string prereq-fails)
"\n fails: " (runs:pretty-string fails)
|
|
<
<
<
|
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
|
(runnables (runs:calc-runnable prereqs-not-met))
(unexpanded-prereqs
(filter (lambda (testname)
(let* ((test-rec (hash-table-ref test-records testname))
(items (tests:testqueue-get-items test-rec)))
;;(BB> "HEY " testname "=>"items)
(or (procedure? items)(eq? items 'have-procedure))))
waitons)))
(debug:print-info 4 *default-log-port* "START OF INNER COND #2 "
"\n can-run-more: " can-run-more
"\n testname: " hed
"\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
"\n non-completed: " (runs:pretty-string non-completed)
"\n prereq-fails: " (runs:pretty-string prereq-fails)
"\n fails: " (runs:pretty-string fails)
|
︙ | | | ︙ | |
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
|
(if (> (length lst) 8)(append (take lst 3)(list "...")) lst))
;;======================================================================
;; runs:run-tests-queue is called by runs:run-tests
;;======================================================================
;;
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry)
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
(debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags))
;; Do mark-and-find clean up of db before starting runing of quue
;;
;; (rmt:find-and-mark-incomplete)
|
|
>
|
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
|
(if (> (length lst) 8)(append (take lst 3)(list "...")) lst))
;;======================================================================
;; runs:run-tests-queue is called by runs:run-tests
;;======================================================================
;;
;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags
test-patts required-tests reglen-in all-tests-registry)
;; At this point the list of parent tests is expanded
;; NB// Should expand items here and then insert into the run queue.
(debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags))
;; Do mark-and-find clean up of db before starting runing of quue
;;
;; (rmt:find-and-mark-incomplete)
|
︙ | | | ︙ | |
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
|
;;
((not items)
(debug:print-info 4 *default-log-port* "cond branch - " "rtq-2")
(debug:print-info 4 *default-log-port* "OUTER COND: (not items)")
(if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
(not (null? tal)))
(loop (car tal)(cdr tal) reg reruns))
;; gonna try a strategy change here.
;;
;; check if can run more tests. if yes, continue, if no, rest until can run more
;; look at the test jobgroup and tot jobs running
;;
;; NOTE: This does NOT actually gate here, only captures the proc to be called later
;;
(if (not (runs:dat-wait-for-jobs-function runsdat))
(runs:dat-wait-for-jobs-function-set!
runsdat
(lambda (testdat-in)
(let* ((jobgroup (runs:testdat-jobgroup testdat-in))
|
|
|
<
|
>
>
|
<
|
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
|
;;
((not items)
(debug:print-info 4 *default-log-port* "cond branch - " "rtq-2")
(debug:print-info 4 *default-log-port* "OUTER COND: (not items)")
(if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
(not (null? tal)))
(loop (car tal)(cdr tal) reg reruns))
;; side effect is to save the prereqs in the struct
(runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path
mode: testmode
itemmaps: itemmaps)
;; not sure why this used to be here
;; (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
;; NOTE: This does NOT actually gate here, only captures the proc to be called later
;;
(if (not (runs:dat-wait-for-jobs-function runsdat))
(runs:dat-wait-for-jobs-function-set!
runsdat
(lambda (testdat-in)
(let* ((jobgroup (runs:testdat-jobgroup testdat-in))
|
︙ | | | ︙ | |
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
|
;; if items is a proc then need to run items:get-items-from-config, get the list and loop
;; - but only do that if resources exist to kick off the job
;; EXPAND ITEMS
((or (procedure? items)(eq? items 'have-procedure))
(debug:print-info 4 *default-log-port* "cond branch - " "rtq-4")
(let ((can-run-more #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
(if (not can-run-more) #;(and (list? can-run-more) ;; IDEA, this mechanism may have had some value, make it configurable to test pros/cons TODO
(car can-run-more))
(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs
run-id waitons item-path testmode test-record
can-run-more items runname tconfig reglen test-registry
test-records itemmaps testdat)))
(if loop-list
(apply loop loop-list)
|
|
>
|
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
|
;; if items is a proc then need to run items:get-items-from-config, get the list and loop
;; - but only do that if resources exist to kick off the job
;; EXPAND ITEMS
((or (procedure? items)(eq? items 'have-procedure))
(debug:print-info 4 *default-log-port* "cond branch - " "rtq-4")
(let ((can-run-more #f)) ;; (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)))
(if (not can-run-more) #;(and (list? can-run-more) ;; IDEA, this mechanism may have had some value,
;;; make it configurable to test pros/cons TODO
(car can-run-more))
(let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs
run-id waitons item-path testmode test-record
can-run-more items runname tconfig reglen test-registry
test-records itemmaps testdat)))
(if loop-list
(apply loop loop-list)
|
︙ | | | ︙ | |