Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -3047,11 +3047,11 @@ ;; ;; 1. cache tests-match-qry ;; 2. compile qry and store in hash ;; 3. convert for-each-row to fold ;; -(define (db:get-tests-for-run-state-status dbstruct run-id testpatt) +#;(define (db:get-tests-for-run-state-status dbstruct run-id testpatt) (db:with-db dbstruct run-id #f (lambda (db) (let* ((res '()) (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -60,11 +60,15 @@ ) (defstruct runs:testdat hed tal reg reruns test-record test-name item-path jobgroup - waitons testmode newtal itemmaps prereqs-not-met) + waitons testmode newtal + itemmaps + (prereqs-not-met '()) + (last-update 0) ;; + ) ;; look in the $MT_RUN_AREA_HOME/.softlocks directory for key-host-pid.softlock files ;; - remove any that are over 3600 seconds old ;; - if there are any that are younger than 10 seconds ;; * sleep 10 seconds @@ -829,30 +833,54 @@ ;; tal - list of never visited tests ;; prefer next hed to be from reg than tal. (define runs:nothing-left-in-queue-count 0) +(define (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path #!key (mode '(normal))(itemmaps #f)) ;; mode: testmode itemmaps: itemmaps) + (if (< (- (current-seconds) (runs:testdat-last-update testdat)) 10) ;; only refresh for this test if it has been at least 10 seconds + (begin + ;; (debug:print 0 *default-log-port* "last-update=" (runs:testdat-last-update testdat) "(current-seconds)=" (current-seconds)) + (runs:testdat-prereqs-not-met testdat)) + ;; (rmt:get-prereqs-not-met 46 '("r1") "y1" "" mode: '(itemmatch) itemmaps: #f) + (let* ((res (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: mode itemmaps: itemmaps))) + (debug:print 4 *default-log-port* "Get prereqs for " hed ", have " (length res) + " prereqs. last-update=" (runs:testdat-last-update testdat) " current-seconds=" (current-seconds) + " delta=" (- (current-seconds) (runs:testdat-last-update testdat))) + (if (list? res) + res + (begin + (debug:print 0 *default-log-port* + "ERROR: rmt:get-prereqs-not-met returned non-list!\n" + " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed + " item-path=" item-path " testmode=" 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)) ;; (reg '()) ;; registered, put these at the head of tal ;; (reruns '())) -(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 reglen test-registry test-records itemmaps) +(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 reglen test-registry test-records itemmaps testdat) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) + (prereqs-not-met (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + #;(let ((res (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps))) (if (list? res) res (begin (debug:print 0 *default-log-port* "ERROR: rmt:get-prereqs-not-met returned non-list!\n" " res=" res " run-id=" run-id " waitons=" waitons " hed=" hed " item-path=" item-path " testmode=" testmode " itemmaps=" itemmaps) - '())))) - (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait))))) + '()))) + (have-itemized (not (null? (lset-intersection eq? testmode '(itemmatch itemwait))))) ;; (prereqs-not-met (mt:lazy-get-prereqs-not-met run-id waitons item-path mode: testmode itemmap: itemmap)) (fails (runs:calc-fails prereqs-not-met)) (prereq-fails (runs:calc-prereq-fail prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met)) (runnables (runs:calc-runnable prereqs-not-met)) @@ -1442,11 +1470,13 @@ ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table)) (define (runs:pretty-long-list lst) - (if (> (length lst) 8)(append (take lst 3)(list "...")) lst)) + (if (> (length lst) 8)(append (take lst 3)(list "...")) lst)) + +(define *runs-testdat-cache* (make-hash-table)) ;; full/testname => testdat ;;====================================================================== ;; runs:run-tests-queue is called by runs:run-tests ;;====================================================================== ;; @@ -1566,25 +1596,43 @@ '()))) (waitons (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) (num-running (rmt:get-count-tests-running-for-run-id run-id #t)) ;; fastmode=yes - (testdat (make-runs:testdat - hed: hed - tal: tal - reg: reg - reruns: reruns - test-record: test-record - test-name: test-name - item-path: item-path - jobgroup: jobgroup - waitons: waitons - testmode: testmode - newtal: newtal - itemmaps: itemmaps - ;; prereqs-not-met: prereqs-not-met - ))) + (testdat (let ((oldtestdat (hash-table-ref/default *runs-testdat-cache* tfullname #f))) + (if oldtestdat + (begin + (runs:testdat-hed-set! oldtestdat hed) + (runs:testdat-tal-set! oldtestdat tal) + (runs:testdat-reg-set! oldtestdat reg) + (runs:testdat-reruns-set! oldtestdat reruns) + (runs:testdat-test-record-set! oldtestdat test-record) + (runs:testdat-newtal-set! oldtestdat newtal) + + (if (not (equal? (runs:testdat-waitons oldtestdat) waitons)) + (debug:print 0 *default-log-port* " waitons changed for runs:testdat")) + (if (not (equal? (runs:testdat-itemmaps oldtestdat) itemmaps)) + (debug:print 0 *default-log-port* " itemmaps changed for runs:testdat")) + + oldtestdat) + (let ((newtestdat (make-runs:testdat + hed: hed + tal: tal + reg: reg + reruns: reruns + test-record: test-record + test-name: test-name + item-path: item-path + jobgroup: jobgroup + waitons: waitons + testmode: testmode + newtal: newtal + itemmaps: itemmaps + ;; prereqs-not-met: prereqs-not-met + ))) + (hash-table-set! *runs-testdat-cache* tfullname newtestdat) + newtestdat))))) (runs:dat-regfull-set! runsdat regfull) (if (> num-running 0) (set! last-time-some-running (current-seconds))) @@ -1715,11 +1763,13 @@ (loop-can-run-more (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs) (- remtries 1))))))) ))))) ;; I'm not clear on why prereqs are gathered here TODO: verfiy this is needed - (runs:testdat-prereqs-not-met-set! testdat (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps)) + (runs:lazy-get-prereqs-not-met testdat run-id waitons hed item-path + mode: testmode + itemmaps: itemmaps) ;; I'm not clear on why we'd capture running job counts here TODO: verify this is needed (runs:dat-can-run-more-tests-set! runsdat (runs:can-run-more-tests runsdat run-id jobgroup max-concurrent-jobs)) (let ((loop-list (runs:process-expanded-tests runsdat testdat))) ;; in process-expanded-tests ultimately run:test -> launch-test -> test actually running @@ -1784,13 +1834,13 @@ ;; - 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) + (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))) ;; itemized test expanded here + (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))) ;; itemized test expanded here (if loop-list (apply loop loop-list) (debug:print-info 4 *default-log-port* " -- Can't expand hed="hed) ) )