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. @@ -401,10 +401,17 @@ ;; 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 ", ")) @@ -417,11 +424,11 @@ (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)) @@ -531,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 @@ -963,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 @@ -976,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)) @@ -1005,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. ;; @@ -1088,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 @@ -1102,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) @@ -1117,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)")