Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -2630,10 +2630,32 @@ delta-env-alist)))) (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) +(define *common:thread-punchlist* (make-hash-table)) (define (common:send-thunk-to-background-thread thunk #!key (name #f)) ;;(BB> "launched thread " name) - (if name - (thread-start! (make-thread thunk name)) - (thread-start! (make-thread thunk)))) + + ;; we need a unique name for the thread. + (let* ((realname (if name + (if (not (hash-table-ref/default *common:thread-punchlist* name #f)) + name + (conc name"-" (symbol->string (gensym)))) + (conc "anonymous-"(symbol->string (gensym))))) + (realthunk (lambda () + (let ((res (thunk))) + (hash-table-delete! *common:thread-punchlist* realname) + res))) + (thread (make-thread realthunk realname))) + (hash-table-set! *common:thread-punchlist* realname thread) + (thread-start! thread) + )) + +(define (common:join-backgrounded-threads) + ;; may need to trap and ignore exceptions -- dunno how atomic threads are... + (for-each + (lambda (thread-name) + (let* ((thread (hash-table-ref/default *common:thread-punchlist* thread-name #f))) + (if thread + (thread-join! thread)))) + (hash-table-keys *common:thread-punchlist*))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -2172,13 +2172,25 @@ (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) (if (not (null? tal)) (loop (car tal)(cdr tal))))))) (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) ((set-state-status) - ;; BB TODO - manage has-subrun case - (debug:print-info 2 *default-log-port* "new state " (car state-status) ", new status " (cadr state-status)) - (mt:test-set-state-status-by-id run-id (db:test-get-id test) (car state-status)(cadr state-status) #f) + (let* ((new-state (car state-status)) + (new-status (cadr state-status)) + (test-id (db:test-get-id test)) + (test-run-dir (db:test-get-rundir new-test-dat)) + (has-subrun (and (subrun:subrun-test-initialized? test-run-dir) + (not (subrun:subrun-removed? test-run-dir))))) + (when has-subrun + (common:send-thunk-to-background-thread + (lambda () + (subrun:set-state-status test-run-dir state status new-state-status) + ) + ) + ) + (debug:print-info 2 *default-log-port* "new state " new-state ", new status " new-status ) + (mt:test-set-state-status-by-id run-id test-id new-state new-status #f)) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ((run-wait) ;; BB TODO - manage has-subrun case (debug:print-info 2 *default-log-port* "still waiting, " (length tests) " tests still running") @@ -2197,11 +2209,12 @@ (debug:print-info 0 *default-log-port* "Estimating disk space usage for " test-fulln ": " (common:get-disk-space-used ddir))))))) (if (not (null? tal)) (loop (car tal)(cdr tal)))) ))) ) - (if worker-thread (thread-join! worker-thread)))))) + (if worker-thread (thread-join! worker-thread))) + (common:join-backgrounded-threads)))) ;; remove the run if zero tests remain (if (eq? action 'remove-runs) (let* ((run-id (db:get-value-by-header run header "id")) ;; NB// masks run-id from above? (remtests (mt:get-tests-for-run run-id #f '("DELETED") '("n/a") not-in: #t))) (if (null? remtests) ;; no more tests remaining Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -54,10 +54,16 @@ (define (subrun:set-subrun-removed test-run-dir) (let ((flagfile (conc test-run-dir "/subrun.removed"))) (if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile))) (with-output-to-file flagfile (lambda () (print (current-seconds))))))) + +(define (subrun:unset-subrun-removed test-run-dir) + (let ((flagfile (conc test-run-dir "/subrun.removed"))) + (if (and (subrun:subrun-test-initialized? test-run-dir) (common:file-exists? flagfile)) + (delete-file flagfile)))) + (define (subrun:testconfig-defines-subrun? testconfig) (configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested (define (subrun:initialize-toprun-test testconfig test-run-dir) @@ -77,17 +83,24 @@ (create-symbolic-link ra symlink-target) (configf:write-alist testconfig "testconfig.subrun"))) +(define (subrun:set-state-status test-run-dir state status new-state-status) + (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) + (let* ((action-switches-str + (conc "-set-state-status "new-state-status + (if state (conc " -state "state) "") + (if status (conc " -status "status) ""))) + (log-prefix (conc "set-state-status="new-state-status + (if state (conc ":state="state) "") + (if status (conc "+status="status) ""))) + (submt-result + (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix))) + submt-result))) (define (subrun:remove-subrun test-run-dir keep-records ) -;; set state/status of test item -;; fork off megatest -;; set state/status of test item -;; - ;;(BB> "Entered subrun:remove-subrun with "test-fulln) (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) (let* ((action-switches-str (conc "-remove-runs" (if keep-records "-keep-records " "") )) @@ -99,10 +112,13 @@ #t) #f)) #t)) (define (subrun:launch-cmd test-run-dir) + (if (subrun:subrun-removed? test-run-dir) + (subrun:unset-subrun-removed test-run-dir)) + (let* ((log-prefix "run") (switches (subrun:selector+log-switches test-run-dir log-prefix)) (run-wait #t) (cmd (conc "megatest -run "switches" " (if run-wait "-run-wait " ""))))