Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -74,10 +74,14 @@ (define *current-run-name* #f) ;; Testconfig and runconfig caches. (define *testconfigs* (make-hash-table)) ;; test-name => testconfig (define *runconfigs* (make-hash-table)) ;; target => runconfig + +;; This is a cache of pre-reqs met, don't re-calc in cases where called with same params less than +;; five seconds ago +(define *pre-reqs-met-cache* (make-hash-table)) (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -229,10 +229,12 @@ sort-by: sort-by sort-order: sort-order)) ;; NOTE: bubble-up also sets the global *all-item-test-names* ;; (tests (bubble-up tmptests priority: bubble-type)) (key-vals (cdb:remote-run db:get-key-vals #f run-id))) + ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. + ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? (set! referenced-run-ids (cons run-id referenced-run-ids)) (if (> (length tests) maxtests) (set! maxtests (length tests))) (if (or (not *hide-empty-runs*) ;; this reduces the data burden when set Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1026,15 +1026,29 @@ db qry run-id ) res)) + +(define (db:get-tests-for-run-state-status db run-id testpatt) + (let ((res '()) + (tests-match-qry (tests:match->sqlqry testpatt))) + (sqlite3:for-each-row + (lambda (id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res))) + db + (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")) + run-id) + res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} (define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) + ;; NB // This is get tests for "runs" (note the plural!!) ;; ;; states and statuses are lists, turn them into ("PASS","FAIL"...) and use NOT IN ;; i.e. these lists define what to NOT show. @@ -2294,11 +2308,11 @@ (result '())) (for-each (lambda (waitontest-name) ;; by getting the tests with matching name we are looking only at the matching test ;; and related sub items - (let ((tests (mt:get-tests-for-run run-id waitontest-name '() '())) + (let ((tests (cdb:remote-run db:get-tests-for-run-state-status #f run-id waitontest-name)) ;; (mt:get-tests-for-run run-id waitontest-name '() '())) (ever-seen #f) (parent-waiton-met #f) (item-waiton-met #f)) (for-each (lambda (test) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -135,17 +135,17 @@ (exit 1))) ;; Can setup as client for server mode now ;; (client:setup) (change-directory *toppath*) - (set-megatest-env-vars run-id) ;; these may be needed by the launching process + (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process (change-directory work-area) (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) - (set-megatest-env-vars run-id) + (set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) (set-item-env-vars itemdat) (save-environment-as-files "megatest") ;; open-run-close not needed for test-set-meta-info (tests:set-full-meta-info #f test-id run-id 0 work-area) @@ -270,15 +270,15 @@ (next-status (cond ((eq? overall-status 'pass) this-step-status) ((eq? overall-status 'warn) (if (eq? this-step-status 'fail) 'fail 'warn)) (else 'fail))) - (next-state "RUNNING") - ;; (cond - ;; ((null? tal) ;; more to run? - ;; "COMPLETED") - ;; (else "RUNNING")) + (next-state ;; "RUNNING") + (cond + ((null? tal) ;; more to run? + "COMPLETED") + (else "RUNNING"))) ) (debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used " this-step-status: " this-step-status " overall-status: " overall-status " next-status: " next-status " rollup-status: " rollup-status) (case next-status Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -82,10 +82,25 @@ limit)) full-list)))) (define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) + +(define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) + (let* ((key (list run-id waitons ref-item-path mode)) + (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) + (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) + (if last-time + (< (current-seconds)(+ last-time 5)) + #f)))) + (if useres + (let ((result (vector-ref res 1))) + (debug:print 4 "Using lazy value res: " result) + result) + (let ((newres (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode))) + (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) + newres)))) (define (mt:get-run-stats) (cdb:remote-run db:get-run-stats #f)) (define (mt:discard-blocked-tests run-id failed-test tests test-records) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -375,11 +375,11 @@ (define runs:nothing-left-in-queue-count 0) (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) (let* ((loop-list (list hed tal reg reruns)) - (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (mt:lazy-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 @@ -580,11 +580,11 @@ (have-resources (car run-limits-info)) (num-running (list-ref run-limits-info 1)) (num-running-in-jobgroup (list-ref run-limits-info 2)) (max-concurrent-jobs (list-ref run-limits-info 3)) (job-group-limit (list-ref run-limits-info 4)) - (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) + (prereqs-not-met (mt:lazy-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)) (loop-list (list hed tal reg reruns))) (debug:print-info 4 "have-resources: " have-resources " prereqs-not-met: (" (string-intersperse Index: tests/fullrun/config/mt_include_1.config ================================================================== --- tests/fullrun/config/mt_include_1.config +++ tests/fullrun/config/mt_include_1.config @@ -8,11 +8,14 @@ useshell yes # ## launcher launches jobs, the job is managed on the target host ## by megatest, comment out launcher to run local # workhosts localhost hermes # launcher exec nbfake + launcher nbfake +# launcher echo + # launcher nbfind # launcher nodanggood ## use "xterm -e csi -- " as a launcher to examine the launch environment. ## exit with (exit)