Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -161,18 +161,18 @@ (if (runs:lownoise (conc "maxjobgroup " jobgroup) 60) (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup " in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit)) #t) (else #f)))) - ;; lets use the debugger eh? - (debugger-start start: 15) - (debugger-trace-var "runs:can-run-more-tests" "") - (debugger-trace-var "can-not-run-more" can-not-run-more) - (debugger-trace-var "num-running" num-running) - (debugger-trace-var "num-running-in-jobgroup" num-running-in-jobgroup) - (debugger-trace-var "job-group-limit" job-group-limit) - (debugger-pauser) +;; ;; lets use the debugger eh? +;; (debugger-start start: 15) +;; (debugger-trace-var "runs:can-run-more-tests" "") +;; (debugger-trace-var "can-not-run-more" can-not-run-more) +;; (debugger-trace-var "num-running" num-running) +;; (debugger-trace-var "num-running-in-jobgroup" num-running-in-jobgroup) +;; (debugger-trace-var "job-group-limit" job-group-limit) +;; (debugger-pauser) (list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit))))) ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. @@ -183,10 +183,11 @@ (keyvals (keys:target->keyval keys target)) (run-id (rmt:register-run keyvals runname "new" "n/a" user)) ;; test-name))) ;; (deferred '()) ;; delay running these since they have a waiton clause (runconfigf (conc *toppath* "/runconfigs.config")) (test-records (make-hash-table)) + (test-deps (make-hash-table)) ;; need to process runconfigs before generating these lists (all-tests-registry #f) ;; (tests:get-all)) ;; (tests:get-valid-tests (make-hash-table) test-search-path)) ;; all valid tests to check waiton names (all-test-names #f) ;; (hash-table-keys all-tests-registry)) (test-names #f) ;; Generated by a call to (tests:filter-test-names all-test-names test-patts)) (required-tests #f) ;; Put fully qualified test/testpath names in this list to be done @@ -242,11 +243,11 @@ ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test (set! all-test-names (hash-table-keys all-tests-registry)) (set! test-names (tests:filter-test-names all-test-names test-patts)) - + ;; I think seeding required-tests with all test-names makes sense but lack analysis to back that up. ;; NEW STRATEGY HERE: ;; 1. fill required tests with test-patts ;; 2. scan testconfigs and if waitons, itemwait, itempatt calc prior test test-patt @@ -332,12 +333,15 @@ (waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f)) (waiton-itemized (and waiton-tconfig (or (hash-table-ref/default waiton-tconfig "items" #f) (hash-table-ref/default waiton-tconfig "itemstable" #f)))) (itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap")) + (mode (tests:get-mode config)) (new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) (debug:print-info 0 "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items") + ;;(debug:print-info 0 "BB> Test is "hed" test-patts is "test-patts) + ;;(debug:print-info 0 "BB> waiton is " waiton " mode is " mode" and new-test-patts is "new-test-patts) ;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%" ;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt ;; is this satisfied by merely appending "/" to the waiton name added to the list? ;; ;; This approach causes all of the items in an upstream test to be run @@ -345,49 +349,86 @@ ;; if we have this waiton already processed once we can analzye it for extending ;; tests to be run, since we can't properly process waitons unless they have been ;; initially added we add them again to be processed on second round AND add the hed ;; back in to also be processed on second round ;; - (if waiton-tconfig - (begin - (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read - (if waiton-itemized - (begin - (debug:print-info 0 "New test patts: " new-test-patts ", prev test patts: " test-patts) - (set! required-tests (cons (conc waiton "/") required-tests)) - (set! test-patts new-test-patts)) - (begin - (debug:print-info 0 "Adding non-itemized test " waiton " to required-tests") - (set! required-tests (cons waiton required-tests)) - (set! test-patts new-test-patts)))) - (begin - (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it") - (set! tal (append (cons waiton tal)(list hed))))) ;; (cons (conc waiton "/") required-tests)) - + + ;;(debug:print-info 0 "BB> remaining tests: "tal) + (let ((hed-depended-on-by-remaining-test + ;; BB>> don't set testpatt if hed is waited on by another test in testnames + + (foldr + (lambda (remaining-test previous-result) + (let ((dependencies-on-remaining-test + (hash-table-ref/default test-deps remaining-test '())) + (mode (tests:get-mode config))) + ;;(debug:print-info 0 "BB> remaining-test="remaining-test" dependencies-on-remaining-test: "dependencies-on-remaining-test) + (or previous-result + (if (or + (not (equal? "itemwait" mode)) + (member hed dependencies-on-remaining-test)) + #t + #f)))) + #f + tal))) + + ;;(debug:print-info 0 "BB> hed="hed" hed-depended-on-by-remaining-test="hed-depended-on-by-remaining-test) + (if (and waiton-tconfig (not hed-depended-on-by-remaining-test)) + (begin + (set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read + (if waiton-itemized + (begin + (debug:print-info 0 "New test patts: " new-test-patts ", prev test patts: " test-patts) + (set! required-tests (cons (conc waiton "/") required-tests)) + ;;(debug:print-info 0 "BB> set1 test-patts <- " test-patts) + (set! test-patts new-test-patts)) + (begin + (debug:print-info 0 "Adding non-itemized test " waiton " to required-tests") + (set! required-tests (cons waiton required-tests)) + ;;(debug:print-info 0 "BB> set2 test-patts <- " test-patts) + (set! test-patts new-test-patts)))) + (begin + (debug:print-info 0 "No testconfig info yet for " waiton ", setting up to re-process it") + (set! tal (append (cons waiton tal)(list hed)))))) ;; (cons (conc waiton "/") required-tests)) + ;; NOPE: didn't work. required needs to be plain test names. Try tacking on to test-patts ;; - doesn't work ;; (set! test-patts (conc test-patts "," waiton "/")) ;; (set! test-names (cons waiton test-names))))) ;; was an append, now a cons ))) (delete-duplicates (append waitons waitors))) + + ;; remember deps + (hash-table-set! + test-deps + hed + (delete-duplicates (append waitons waitors (hash-table-ref/default test-deps hed '())))) + + ;; (print "INFO::: test-deps") + ;; (pp (hash-table->alist test-deps)) +;; (debugger-start start: 21) +;; (debugger-trace-var "waiton processing" "") +;; (debugger-trace-var "test-deps" (hash-table->alist test-deps)) +;; (debugger-pauser) + (let ((remtests (delete-duplicates (append waitons tal)))) (if (not (null? remtests)) (begin ;; (debug:print-info 0 "Preprocessing continues for " (string-intersperse remtests ", ")) (loop (car remtests)(cdr remtests)))))))) - + (if (not (null? required-tests)) (debug:print-info 1 "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 "test-records=" (hash-table->alist test-records)) (let ((reglen (configf:lookup *configdat* "setup" "runqueue"))) (if (> (length (hash-table-keys test-records)) 0) (let* ((keep-going #t) (run-queue-retries 5) (th1 (make-thread (lambda () - (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry)) + (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen) all-tests-registry test-deps)) ;; (handle-exceptions ;; exn ;; (begin ;; (print-call-chain (current-error-port)) ;; (debug:print 0 "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) @@ -497,17 +538,17 @@ "\n (null? non-completed): " (null? non-completed) "\n reruns: " reruns "\n items: " items "\n can-run-more: " can-run-more) - ;; lets use the debugger eh? - (debugger-start start: 2) - (debugger-trace-var "runs:expand-items" "") - (debugger-trace-var "can-run-more" can-run-more) - (debugger-trace-var "hed" hed) - (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) - (debugger-pauser) +;; ;; lets use the debugger eh? +;; (debugger-start start: 2) +;; (debugger-trace-var "runs:expand-items" "") +;; (debugger-trace-var "can-run-more" can-run-more) +;; (debugger-trace-var "hed" hed) +;; (debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met)) +;; (debugger-pauser) (cond ;; all prereqs met, fire off the test ;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch @@ -929,11 +970,11 @@ ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table)) ;; 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) +(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry test-deps) ;; 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 "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue @@ -942,10 +983,11 @@ (let ((run-info (rmt:get-run-info run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) + (no-can-run (make-hash-table)) ;; test/test/patt => #t hash of tests that can not run (registry-mutex (make-mutex)) (num-retries 0) (max-retries (config-lookup *configdat* "setup" "maxretries")) (max-concurrent-jobs (let ((mcj (config-lookup *configdat* "setup" "max_concurrent_jobs"))) (if (and mcj (string->number mcj)) @@ -971,10 +1013,12 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) + (set! reruns '()) ;; force it to test impact!! + (if (not (null? reruns))(debug:print-info 4 "reruns=" reruns)) ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes ;; moving this to a parallel thread and just run it once. ;; @@ -1054,13 +1098,15 @@ ;; lets use the debugger eh? (debugger-start start: 7) (debugger-trace-var "runs:run-tests-queue" "") (debugger-trace-var "hed" hed) (debugger-trace-var "tal" tal) + (debugger-trace-var "reruns" reruns) (debugger-trace-var "items" items) (debugger-trace-var "item-path" item-path) - (debugger-trace-var "waitons" waitons) + (debugger-trace-var "waitons" waitons) + (debugger-trace-var "no-can-run" (hash-table->alist no-can-run)) (debugger-pauser) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error @@ -1068,11 +1114,12 @@ (begin (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!") (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons)))) (cond - + + ;; hed, test-deps :: hed -> ( waitons ) ;; We want to catch tests that have waitons that are NOT in the queue and discard them IFF ;; they have been through the wringer 10 or more times ((and (list? waitons) (not (null? waitons)) (> (hash-table-ref/default *max-tries-hash* tfullname 0) 10) @@ -1083,11 +1130,16 @@ (not (member waiton reruns))) 1 #f)) waitons))))) ;; could do this more elegantly with a marker.... (debug:print 0 "WARNING: Marking test " tfullname " as not runnable. It is waiting on tests that cannot be run. Giving up now.") - (hash-table-set! test-registry tfullname 'removed)) + (hash-table-set! test-registry tfullname 'removed) + (hash-table-set! no-can-run tfullname #t) + (for-each + (lambda (waiton) + (hash-table-set! no-can-run waiton #t)) ;; NB// this does not account for itemmap and itemwait + waitons)) ;; items is #f then the test is ok to be handed off to launch (but not before) ;; ((not items) (debug:print-info 4 "OUTER COND: (not items)") Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -91,10 +91,14 @@ (list (list "%" base-itemmap)) '()) (if itemmap-table itemmap-table '())))) + +(define (tests:get-mode tconfig) + (let ((itemwait (configf:lookup tconfig "requirements" "mode"))) + itemwait)) ;; given a list of itemmaps (testname . map), return the first match ;; (define (tests:lookup-itemmap itemmaps testname) (let ((best-matches (filter (lambda (itemmap)