Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -312,14 +312,37 @@ (api:unregister-thread (current-thread)) payload)) (else (assert #f "FATAL: failed to deserialize indat "indat)))))) +(define *last-refresh-of-dbs* 0) +(define *db-starts-running* #f) (define (api:dispatch-request dbstruct cmd run-id params) - (if (not *no-sync-db*) - (db:open-no-sync-db)) + (if (not *no-sync-db*)(db:open-no-sync-db)) + + (thread-start! + (make-thread + (lambda () + (if (and (not *db-starts-running*) + (not run-id) ;; i.e. we are mainl.db + (> (- (current-seconds) *last-refresh-of-dbs*) 20)) + (set! *db-starts-running* #t) + (let loop ((dbnum 10)) + (let* ((dbname (conc dbnum".db")) ;; Yes, this is correct, use dbnum directly + (candidates (dbfile:get-process-options *no-sync-db* "server" dbname))) + (if (null? candidates) + ;; start a server for this dbfile + (tt:server-process-run + *toppath* + (common:get-testsuite-name) + (common:find-local-megatest) + dbname))) + (thread-sleep! 0.5) + (if (> dbnum 0)(loop (- dbnum 1))) + (set! *db-starts-running* #f) + (set! *last-refresh-of-dbs* (current-seconds))))))) (case cmd ;;=============================================== ;; READ/WRITE QUERIES ;;=============================================== Index: dbfile.scm ================================================================== --- dbfile.scm +++ dbfile.scm @@ -580,10 +580,11 @@ host port pid starttime endtime status purpose dbname mtversion)) (define (dbfile:set-process-status nsdb host pid newstatus) (sqlite3:execute nsdb "UPDATE processes SET status=? WHERE host=? AND pid=?;" newstatus host pid)) +;; get list of process records to examine for suitabliity of connecting to (define (dbfile:get-process-options nsdb purpose dbname) (sqlite3:fold-row ;; host port pid starttime status mtversion (lambda (res . row) (cons row res)) Index: tcp-transportmod.scm ================================================================== --- tcp-transportmod.scm +++ tcp-transportmod.scm @@ -138,11 +138,12 @@ (server-start-proc (lambda () (tt:server-process-run (tt-areapath ttdat) testsuite ;; (dbfile:testsuite-name) (common:find-local-megatest) - run-id)))) + dbfname ;; run-id + )))) (if conn (begin ; (debug:print-info 0 *default-log-port* "already connected to the server") conn) ;; we are already connected to the server (let* ((sdat (tt:get-current-server-info ttdat dbfname))) @@ -755,16 +756,18 @@ ;; Given an area path, start a server process ### NOTE ### > file 2>&1 ;; if the target-host is set ;; try running on that host ;; incidental: rotate logs in logs/ dir. ;; -(define (tt:server-process-run areapath testsuite mtexe run-id #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area +(define (tt:server-process-run areapath testsuite mtexe + dbfname ;; run-id + #!key (profile-mode "")) ;; areapath is *toppath* for a given testsuite area (assert areapath "FATAL: tt:server-process-run called without areapath defined.") (assert testsuite "FATAL: tt:server-process-run called without testsuite defined.") (assert mtexe "FATAL: tt:server-process-run called without mtexe defined.") ;; mtest -server - -m testsuite:ext-tests -db 6.db - (let* ((dbfname (dbmod:run-id->dbfname run-id)) + (let* (;; (dbfname (dbmod:run-id->dbfname run-id)) (load (get-normalized-cpu-load)) (trying (length (tt:find-server areapath dbfname))) (nrun (number-of-processes-running (conc "mtest.*server.*"testsuite".*"dbfname)))) (cond ((> load 2.0)