Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -329,10 +329,89 @@ (if regful (cdr reg) (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal '() reg))) + +(define (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 + ) + + (debug:print-info 4 "INNER COND: (or (procedure? items)(eq? items 'have-procedure))") + (let* ((loop-list (list hed tal reg reruns)) + (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (fails (runs:calc-fails prereqs-not-met)) + (non-completed (runs:calc-not-completed prereqs-not-met))) + (debug:print-info 4 "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 fails: " (runs:pretty-string fails) + "\n testmode: " testmode + "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) + "\n (null? non-completed): " (null? non-completed) + "\n reruns: " reruns + "\n items: " items + "\n can-run-more: " can-run-more) + ;; (thread-sleep! (+ 0.01 *global-delta*)) + (cond ;; INNER COND #2 + ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test + ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch + (and (eq? testmode 'toplevel) + (null? non-completed))) + (debug:print-info 4 "INNER COND #2: (or (null? prereqs-not-met) (and (eq? testmode 'toplevel)(null? non-completed)))") + (let ((test-name (tests:testqueue-get-testname test-record))) + (setenv "MT_TEST_NAME" test-name) ;; + (setenv "MT_RUNNAME" runname) + (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process + (let ((items-list (items:get-items-from-config tconfig))) + (if (list? items-list) + (begin + (tests:testqueue-set-items! test-record items-list) + ;; (thread-sleep! *global-delta*) + (set! loop-list (list hed tal reg reruns))) + (begin + (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") + (exit 1)))))) + ((null? fails) + (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now") + ;; num-retries code was here + (set! loop-list (list (car newtal)(cdr newtal) reg reruns))) ;; an issue with prereqs not yet met? + ((and (not (null? fails))(eq? testmode 'normal)) + (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " + (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") + ", removing it from to-do list") + (if (or (not (null? reg))(not (null? tal))) + (begin + ;; (thread-sleep! *global-delta*) + (set! loop-list (list (runs:queue-next-hed tal reg reglen regfull) + (runs:queue-next-tal tal reg reglen regfull) + (runs:queue-next-reg tal reg reglen regfull) + (cons hed reruns)))))) + (else + (debug:print 4 "ERROR: No handler for this condition.") + ;; TRY (thread-sleep! (+ 1 *global-delta*)) + (set! loop-list (list (car newtal)(cdr newtal) reg reruns)))) ;; END OF IF CAN RUN MORE + loop-list)) + ;; 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) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. @@ -560,11 +639,10 @@ (runs:queue-next-reg tal reg reglen regfull) (cons hed reruns))) (begin (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?) - ;; (thread-sleep! (+ 0.01 *global-delta*)) (loop hed tal reg reruns))))))))) ;; END OF INNER COND ;; End of INNER COND for launchable test. ;; case where an items came in as a list been processed @@ -596,91 +674,20 @@ ;; (loop (car newtal)(cdr newtal) reg reruns)) ;; ) (loop (car tal)(cdr tal) reg reruns)) ;; 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 "INNER COND: (or (procedure? items)(eq? items 'have-procedure))") (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) - (let* ((prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) - (fails (runs:calc-fails prereqs-not-met)) - (non-completed (runs:calc-not-completed prereqs-not-met))) - (debug:print-info 4 "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 fails: " (runs:pretty-string fails) - "\n testmode: " testmode - "\n num-retries: " num-retries - "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel) - "\n (null? non-completed): " (null? non-completed) - "\n reruns: " reruns - "\n items: " items - "\n can-run-more: " can-run-more) - ;; (thread-sleep! (+ 0.01 *global-delta*)) - (cond ;; INNER COND #2 - ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test - ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch - (and (eq? testmode 'toplevel) - (null? non-completed))) - (debug:print-info 4 "INNER COND #2: (or (null? prereqs-not-met) (and (eq? testmode 'toplevel)(null? non-completed)))") - (let ((test-name (tests:testqueue-get-testname test-record))) - (setenv "MT_TEST_NAME" test-name) ;; - (setenv "MT_RUNNAME" runname) - (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process - (let ((items-list (items:get-items-from-config tconfig))) - (if (list? items-list) - (begin - (tests:testqueue-set-items! test-record items-list) - ;; (thread-sleep! *global-delta*) - (loop hed tal reg reruns)) - (begin - (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") - (exit 1)))))) - ((null? fails) - (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now") - ;; only increment num-retries when there are no tests runing - (if (eq? 0 (list-ref can-run-more 1)) - (begin - ;; TRY (if (> num-retries 100) ;; first 100 retries are low time cost - ;; TRY (thread-sleep! (+ 2 *global-delta*)) - ;; TRY (thread-sleep! (+ 0.01 *global-delta*))) - (set! num-retries (+ num-retries 1)))) - (if (> num-retries max-retries) - (begin - (debug:print 0 "WARNING: retries exceed " max-retries ", this may not be handled correctly. Please consider reporting this scenario.") - (if (not (null? tal)) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns))) - (loop (car newtal)(cdr newtal) reg reruns))) ;; an issue with prereqs not yet met? - ((and (not (null? fails))(eq? testmode 'normal)) - (debug:print-info 1 "test " hed " (mode=" testmode ") has failed prerequisite(s); " - (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ") - ", removing it from to-do list") - (if (or (not (null? reg))(not (null? tal))) - (begin - ;; (thread-sleep! *global-delta*) - (loop (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - (cons hed reruns))))) - (else - (debug:print 4 "ERROR: No handler for this condition.") - ;; TRY (thread-sleep! (+ 1 *global-delta*)) - (loop (car newtal)(cdr newtal) reg reruns)))) ;; END OF IF 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))) + (apply loop loop-list)) ;; if can't run more just loop with next possible test - (begin - (debug:print-info 4 "processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed) - ;; (thread-sleep! (+ 2 *global-delta*)) - (loop (car newtal)(cdr newtal) reg reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure)) - + (loop (car newtal)(cdr newtal) reg reruns)))) + ;; this case should not happen, added to help catch any bugs ((and (list? items) itemdat) (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") (exit 1)) ((not (null? reruns))