Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -445,11 +445,11 @@ (iup:attribute-set! obj "TITLE" (if *hide-empty-runs* "+Hide" "-Hide")) (mark-for-update))) (iup:button "Refresh" #:action (lambda (obj) (mark-for-update)))) (iup:hbox - (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(exit))) + (iup:button "Quit" #:action (lambda (obj)(if *db* (sqlite3:finalize! *db*))(exit))) (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (argv))" -guimonitor &"))))) )) ;; (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offset* (+ *start-run-offset* 1)))) ;; (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-offset* (if (> *start-test-offset* 0)(- *start-test-offset* 1) 0)))) ;; (iup:button "Down v" #:action (lambda (obj)(set! *start-test-offset* (if (>= *start-test-offset* (length *alltestnamelst*))(length *alltestnamelst*)(+ *start-test-offset* 1))))) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -52,15 +52,25 @@ (debug:print 5 "INFO: Turning off pragma synchronous") (sqlite3:execute db "PRAGMA synchronous = 0;")) (debug:print 5 "INFO: NOT turning off pragma synchronous")) db)) -(define (open-run-close proc idb . params) +(define (open-run-close proc idb . params) (let* ((db (if idb idb (open-db))) (res (apply proc db params))) (if (not idb)(sqlite3:finalize! db)) res)) + +(define *global-delta* 0) +(define (open-run-close-measure proc idb . params) + (let* ((start-ms (current-milliseconds)) + (db (if idb idb (open-db))) + (res (apply proc db params))) + (if (not idb)(sqlite3:finalize! db)) + (set! *global-delta* (- (current-milliseconds) start-ms)) + (print "INFO: delta=" *global-delta*) + res)) (define (db:initialize db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (config-get-fields configdat)) (havekeys (> (length keys) 0)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -63,11 +63,11 @@ (let* ((testname (db:test-get-testname test)) (itempath (db:test-get-item-path test))) (conc testname (if (equal? itempath "") "" (conc "(" itempath ")"))))) (define (set-megatest-env-vars db run-id) - (let ((keys (rdb:get-keys db))) + (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)) @@ -284,11 +284,11 @@ (let ((sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (item-patts (hash-table-ref/default flags "-itempatt" #f))) (if (not (null? sorted-test-names)) (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names))) - (thread-sleep! 0.1) ;; give other applications some time with the db + (thread-sleep! (/ *global-delta* 10)) ;; give other applications some time with the db (let* ((test-record (hash-table-ref test-records hed)) (tconfig (tests:testqueue-get-testconfig test-record)) (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) (if m (string->symbol m) 'normal))) (waitons (tests:testqueue-get-waitons test-record)) @@ -337,13 +337,13 @@ (fails (calc-fails prereqs-not-met)) (non-completed (calc-not-completed prereqs-not-met))) (debug:print 8 "INFO: have-resources: " have-resources " prereqs-not-met: " (string-intersperse (map (lambda (t) - (if (not (vector? t)) - (conc " WARNING: t is not a vector=" t ) - (conc (db:test-get-state t) "/" (db:test-get-status t)))) + (if (vector? t) + (conc (db:test-get-state t) "/" (db:test-get-status t)) + (conc " WARNING: t is not a vector=" t ))) prereqs-not-met) ", ") " fails: " fails) ;; Don't know at this time if the test have been launched at some time in the past ;; i.e. is this a re-launch? (cond ((and have-resources @@ -356,11 +356,11 @@ (debug:print 1 "INFO: Skipping " (tests:testqueue-get-testname test-record) " " item-path " as it doesn't match " item-patts)) ;; else the run is stuck, temporarily or permanently ;; but should check if it is due to lack of resources vs. prerequisites ) ((not have-resources) ;; simply try again after waiting a second - (thread-sleep! 1.0) + (thread-sleep! (* *global-delta* *global-delta*)) (debug:print 1 "INFO: no resources to run new tests, waiting ...") ;; could have done hed tal here but doing car/cdr of newtal to rotate tests (loop (car newtal)(cdr newtal))) (else ;; must be we have unmet prerequisites (debug:print 4 "FAILS: " fails) @@ -368,11 +368,11 @@ ;; a message and drop hed from the items to be processed. (if (null? fails) (begin ;; couldn't run, take a breather (debug:print 4 "INFO: Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...") - (thread-sleep! 0.1) ;; long sleep here - no resources, may as well be patient + (thread-sleep! (* *global-delta* *global-delta*)) ;; long sleep here - no resources, may as well be patient ;; we made new tal by sticking hed at the back of the list (loop (car newtal)(cdr newtal))) ;; the waiton is FAIL so no point in trying to run hed ever again (if (not (null? tal)) (begin @@ -429,11 +429,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 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 (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)) @@ -474,11 +474,11 @@ (if (not *runremote*)(exit)) ;; #f) ;; return a #f as a hint that we are done ;; Here we need to check that all the tests remaining to be run are eligible to run ;; and are not blocked by failed (let ((newlst (open-run-close tests:filter-non-runnable #f run-id tal test-records))) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED, - (thread-sleep! 0.1) + (thread-sleep! (/ *global-delta* 10)) (if (not (null? newlst)) (loop (car newlst)(cdr newlst))))))))) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step (define (run:test run-id runname keyvallst test-record flags parent-test) @@ -501,11 +501,11 @@ (if (not itemdat)(set! itemdat '())) (set! item-path (item-list->path itemdat)) (debug:print 2 "Attempting to launch test " test-name "/" item-path) (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) - (open-run-close set-megatest-env-vars db run-id) ;; these may be needed by the launching process + (open-run-close-measure 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))