Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -184,10 +184,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 @@ -243,11 +244,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 @@ -333,12 +334,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 #f "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 @@ -346,49 +350,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 "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 #f "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 + (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 #f "Adding non-itemized test " waiton " to required-tests") - (set! required-tests (cons waiton required-tests)) - (set! test-patts new-test-patts)))) - (begin + (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 #f "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)) - + (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 #f "Preprocessing continues for " (string-intersperse remtests ", ")) (loop (car remtests)(cdr remtests)))))))) - + (if (not (null? required-tests)) (debug:print-info 1 #f "Adding \"" (string-intersperse required-tests " ") "\" to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (debug:print-info 4 #f "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 #f "ERROR: failure in runs:run-tests-queue thread, error: " ((condition-property-accessor 'exn 'message) exn)) @@ -498,11 +539,11 @@ "\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? +;; ;; 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)) @@ -930,11 +971,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 #f "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue @@ -943,10 +984,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)) @@ -954,11 +996,12 @@ 1))) ;; length of the register queue ahead (reglen (if (number? reglen-in) reglen-in 1)) (last-time-incomplete (- (current-seconds) 900)) ;; force at least one clean up cycle (last-time-some-running (current-seconds)) (tdbdat (tasks:open-db))) - + ;; BB: suspicion: sorted-tests violate dependency topology + (debug:print 0 "BB> sorted-test-names: "sorted-test-names) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) (let ((id (db:test-get-id trec)) (tn (db:test-get-testname trec)) @@ -972,11 +1015,15 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) - (if (not (null? reruns))(debug:print-info 4 #f "reruns=" 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. ;; (if (> (current-seconds)(+ last-time-incomplete 900)) @@ -1059,10 +1106,11 @@ ;; (debugger-trace-var "tal" tal) ;; (debugger-trace-var "items" items) ;; (debugger-trace-var "item-path" item-path) ;; (debugger-trace-var "waitons" waitons) ;; (debugger-pauser) +;; (debugger-trace-var "no-can-run" (hash-table->alist no-can-run)) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (member test-name waitons) @@ -1069,11 +1117,12 @@ (begin (debug:print 0 #f "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) @@ -1084,11 +1133,16 @@ (not (member waiton reruns))) 1 #f)) waitons))))) ;; could do this more elegantly with a marker.... (debug:print 0 #f "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 #f "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)