Reinstall deadlock workaround thread when forking with thread killing

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)))))