Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -76,10 +76,11 @@ (if (not idb)(sqlite3:finalize! db)) res)) (define *global-delta* 0) (define *last-global-delta-printed* 0) + (define (open-run-close-measure proc idb . params) (let* ((start-ms (current-milliseconds)) (db (if idb idb (open-db))) (throttle (string->number (config-lookup *configdat* "setup" "throttle")))) @@ -357,20 +358,32 @@ ;;====================================================================== ;; meta get and set vars ;;====================================================================== ;; returns number if string->number is successful, string otherwise +;; also updates *global-delta* (define (db:get-var db var) - (let ((res #f)) + (let* ((start-ms (current-milliseconds)) + (throttle (string->number (config-lookup *configdat* "setup" "throttle"))) + (res #f)) (sqlite3:for-each-row (lambda (val) (set! res val)) db "SELECT val FROM metadat WHERE var=?;" var) + ;; convert to number if can (if (string? res) (let ((valnum (string->number res))) - (if valnum valnum res)) - res))) + (if valnum (set! res valnum)))) + ;; scale by 10, average with current value. + (set! *global-delta* (/ (+ *global-delta* (* (- (current-milliseconds) start-ms) + (if throttle throttle 0.01))) + 2)) + (if (> (abs (- *last-global-delta-printed* *global-delta*)) 0.08) ;; don't print all the time, only if it changes a bit + (begin + (debug:print 1 "INFO: launch throttle factor=" *global-delta*) + (set! *last-global-delta-printed* *global-delta*))) + res)) (define (db:set-var db var val) (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" var val)) ;; use a global for some primitive caching, it is just silly to re-read the db Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -95,11 +95,11 @@ ;; (sqlite3:finalize! db) ;; (sqlite3:finalize! tdb) (exit 1))) (change-directory *toppath*) - (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process + (open-run-close-measure set-megatest-env-vars #f run-id) ;; these may be needed by the launching process (change-directory work-area) (open-run-close set-run-config-vars #f run-id) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -62,29 +62,49 @@ (define (runs:test-get-full-path test) (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) +;; Awful. Please FIXME +(define *env-vars-by-run-id* (make-hash-table)) +(define *current-run-name* #f) + (define (set-megatest-env-vars db run-id) - (let ((keys (db:get-keys db))) - (for-each (lambda (key) - (sqlite3:for-each-row - (lambda (val) - (debug:print 2 "setenv " (key:get-fieldname key) " " val) - (setenv (key:get-fieldname key) val)) - db - (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") - run-id)) - keys) + (let ((keys (db:get-keys db)) + (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f))) + ;; get the info from the db and put it in the cache + (if (not vals) + (let ((ht (make-hash-table))) + (hash-table-set! *env-vars-by-run-id* run-id ht) + (set! vals ht) + (for-each + (lambda (key) + (sqlite3:for-each-row + (lambda (val) + (hash-table-set! vals key val)) + db + (conc "SELECT " (key:get-fieldname key) " FROM runs WHERE id=?;") + run-id)) + keys))) + ;; from the cached data set the vars + (hash-table-for-each + vals + (lambda (key val) + (debug:print 2 "setenv " (key:get-fieldname key) " " val) + (setenv (key:get-fieldname key) val))) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment - (sqlite3:for-each-row - (lambda (runname) - (setenv "MT_RUNNAME" runname)) - db - "SELECT runname FROM runs WHERE id=?;" - run-id) + (if (not *current-run-name*) + (sqlite3:for-each-row + (lambda (runname) + (set! *current-run-name* runname)) + + db + "SELECT runname FROM runs WHERE id=?;" + run-id)) + (setenv "MT_RUNNAME" *current-run-name*) + (setenv "MT_RUN_AREA_HOME" *toppath*) )) (define (set-item-env-vars itemdat) (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) @@ -205,11 +225,11 @@ ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (db:delete-tests-in-state db run-id "NOT_STARTED") - (rdb:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) + (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) ;; from here on out the db will be opened and closed on every call runs:run-tests-queue (sqlite3:finalize! db) ;; now add non-directly referenced dependencies (i.e. waiton) (if (not (null? test-names)) @@ -458,11 +478,11 @@ (and (eq? testmode 'toplevel) (null? non-completed))) (let ((test-name (tests:testqueue-get-testname test-record))) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (open-run-close-measure set-megatest-env-vars #f run-id) ;; these may be needed by the launching process + (open-run-close set-megatest-env-vars #f run-id) ;; these may be needed by the launching process (let ((items-list (items:get-items-from-config tconfig))) (if (list? items-list) (begin (tests:testqueue-set-items! test-record items-list) (loop hed tal reruns)) @@ -540,11 +560,11 @@ (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) (debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "/") "/" item-path)) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (open-run-close-measure set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated ;; Yes, another use of a global for caching. Need a better way? (if (not (hash-table-ref/default *test-meta-updated* test-name #f))