diff options
| -rw-r--r-- | scsh-process.scm | 19 |
1 files changed, 15 insertions, 4 deletions
diff --git a/scsh-process.scm b/scsh-process.scm index 0676681..a5d3df6 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -73,9 +73,12 @@ ;; Aaaand another hack to avoid getting "deadlock detected" when all ;; threads are waiting for a child condition. We can still get woken ;; up by the signal/chld handler (see below). -(thread-start! - (make-thread (lambda () (let lp () (thread-sleep! 100) (lp))) - 'work-around-broken-deadlock-detection)) +(define (install-deadlock-workaround!) + (thread-start! + (make-thread (lambda () (let lp () (thread-sleep! 100) (lp))) + 'work-around-broken-deadlock-detection))) + +(install-deadlock-workaround!) ;; And again on fork (define proc:pid scsh-process-pid) (define proc? scsh-process?) @@ -208,8 +211,15 @@ (exit 0))) (define (fork #!optional thunk continue-threads?) - (let* ((thunk (and thunk (lambda () + (let* ((maybe-reinstall-deadlock-workaround! + (lambda () + (cond-expand + (has-thread-killer + (unless continue-threads? (install-deadlock-workaround!))) + (else (void))))) + (thunk (and thunk (lambda () (clear-scsh-pending-processes!) + (maybe-reinstall-deadlock-workaround!) (thunk)))) (pid (cond-expand (has-thread-killer @@ -218,6 +228,7 @@ (if thunk (process-fork thunk) (process-fork)))))) (cond ((zero? pid) (clear-scsh-pending-processes!) + (maybe-reinstall-deadlock-workaround!) #f) (else (add-scsh-pending-process! pid))))) |