Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -45,32 +45,41 @@ 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 (equal? (config-lookup *configdat* "setup" "synchronous") "yes") + (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))) + (let* ((db (if idb idb (open-db))) + (res #f)) + (if (equal? (config-lookup *configdat* "setup" "synchronous") "yes") + (sqlite3:execute db "PRAGMA synchronous = 0;")) + (set! res (apply proc db params)) (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))) - (res (apply proc db params))) + (db (if idb idb (open-db)))) + (if (equal? (config-lookup *configdat* "setup" "synchronous") "yes") + (sqlite3:execute db "PRAGMA synchronous = 0;")) + (set! res (apply proc db params)) (if (not idb)(sqlite3:finalize! db)) ;; scale by 10, average with current value. (set! *global-delta* (/ (+ *global-delta* (/ (- (current-milliseconds) start-ms) 200)) 2)) - (debug:print 4 "INFO: delta=" *global-delta*) + (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:initialize db) (let* ((configdat (car *configinfo*)) ;; tut tut, global warning... (keys (config-get-fields configdat)) @@ -85,11 +94,11 @@ (begin (print "ERROR: your key cannot be named " keyn " as this conflicts with the same named field in the runs table") (system (conc "rm -f " dbpath)) (exit 1))))) keys) - ;; (sqlite3:execute db "PRAGMA synchronous = OFF;") + (sqlite3:execute db "PRAGMA synchronous = OFF;") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS keys (id INTEGER PRIMARY KEY, fieldname TEXT, fieldtype TEXT, CONSTRAINT keyconstraint UNIQUE (fieldname));") (for-each (lambda (key) (sqlite3:execute db "INSERT INTO keys (fieldname,fieldtype) VALUES (?,?);" (key:get-fieldname key)(key:get-fieldtype key))) keys) (sqlite3:execute db (conc Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -89,18 +89,22 @@ (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) +(define *last-num-running-tests* 0) (define (runs:can-run-more-tests db test-record) (let* ((tconfig (tests:testqueue-get-testconfig test-record)) (jobgroup (config-lookup tconfig "requirements" "jobgroup")) (num-running (db:get-count-tests-running db)) (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup)) (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")) (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) - (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (if (not (eq? *last-num-running-tests* num-running)) + (begin + (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) + (set! *last-num-running-tests* num-running))) (if (not (eq? 0 *globalexitstatus*)) #f (let ((can-not-run-more (cond ;; if max-concurrent-jobs is set and the number running is greater ;; than it than cannot run more jobs @@ -378,11 +382,11 @@ (if (vector? hed) (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") (loop (car tal)(cdr tal))) (begin - (debug:print 1 "WARN: Test not processed correctly? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") + (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;; " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)") (loop hed 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 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) -debug 10 -runall -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_b -m "This is a comment specific to a run" -v $(SERVER) + cd fullrun;$(MEGATEST) -debug 2 -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 &