Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -45,15 +45,15 @@ 36000)))) ;; 136000))) (debug:print 4 "INFO: dbpath=" dbpath) (sqlite3:set-busy-handler! db handler) (if (not dbexists) (db:initialize db)) - (if (config-lookup *configdat* "setup" "synchronous") - (begin - (debug:print 5 "INFO: Turning off pragma synchronous") - (sqlite3:execute db "PRAGMA synchronous = 0;")) - (debug:print 5 "INFO: NOT turning off pragma synchronous")) + ;; (if (config-lookup *configdat* "setup" "synchronous") + ;; (begin + ;; (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) (let* ((db (if idb idb (open-db))) (res (apply proc db params))) @@ -64,12 +64,13 @@ (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*) + ;; scale by 10, average with current value. + (set! *global-delta* (/ (+ *global-delta* (/ (- (current-milliseconds) start-ms) 100)) 2)) + (debug:print 4 "INFO: delta=" *global-delta*) res)) (define (db:initialize db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (config-get-fields configdat)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -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! (/ *global-delta* 10)) ;; give other applications some time with the db + (thread-sleep! *global-delta*) ;; 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)) @@ -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! (* *global-delta* *global-delta*)) + (thread-sleep! (+ 1 *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,18 +368,20 @@ ;; 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! (* *global-delta* *global-delta*)) ;; long sleep here - no resources, may as well be patient + (thread-sleep! (+ 1 *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 - (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) - " from the launch list as it has prerequistes that are FAIL") + (if (vector? hed) + (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed) + " from the launch list as it has prerequistes that are FAIL") + (debug:print 1 "WARN: Dropping test " hed " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")) (loop (car tal)(cdr tal))))))))) ;; case where an items came in as a list been processed ((and (list? items) ;; thus we know our items are already calculated (not itemdat)) ;; and not yet expanded into the list of things to be done @@ -474,11 +476,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! (/ *global-delta* 10)) + (thread-sleep! *global-delta*) (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) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -20,11 +20,11 @@ test3 : fullprep cd fullrun;$(MEGATEST) -runtests runfirst -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b $(SERVER) -debug 10 test4 : fullprep - cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER) + cd fullrun;$(MEGATEST) -debug 10 -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER) test5 : fullprep cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_aa -v $(SERVER) 2&>1 aa.log & cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ab -v $(SERVER) 2&>1 ab.log & cd fullrun;$(MEGATEST) -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_ac -v $(SERVER) 2&>1 ac.log &