Don't unmask signal if the signal was already masked before forking

2 files changed, 41 insertions, 28 deletions

diff --git a/scsh-process.scm b/scsh-process.scm
index 4e6708d..5bfd7e9 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -221,35 +221,38 @@
     (exit 0)))
 
 (define (fork #!optional thunk continue-threads?)
-  (dynamic-wind
-      ;; If we're really unlucky, sigchld might be delivered
-      ;; immediately after forking, but before we added the child's
-      ;; pid to the pending processes table.  This means we'll lose
-      ;; the event and won't mark the process as finished, resulting
-      ;; in an endless loop in process-wait.  So, mask it.
-      (lambda () (signal-mask! signal/chld))
-      (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
+  (let ((sigchld-was-masked? (signal-masked? signal/chld)))
+    (dynamic-wind
+        ;; If we're really unlucky, sigchld might be delivered
+        ;; immediately after forking, but before we added the child's
+        ;; pid to the pending processes table.  This means we'll lose
+        ;; the event and won't mark the process as finished, resulting
+        ;; in an endless loop in process-wait.  So, mask it.
+        (lambda ()
+          (unless sigchld-was-masked? (signal-mask! signal/chld)))
+        (lambda ()
+          (let* ((maybe-reinstall-deadlock-workaround!
+                  (lambda ()
+                    (cond-expand
                       (has-thread-killer
-                       (process-fork thunk (not continue-threads?)))
-                      (else ;; Ignore both args if thunk is #f, so #f won't be applied
-                       (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)))))
-      (lambda () (signal-unmask! signal/chld))))
+                       (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
+                         (process-fork thunk (not continue-threads?)))
+                        (else ;; Ignore both args if thunk is #f, so #f won't be applied
+                         (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)))))
+        (lambda ()
+          (unless sigchld-was-masked? (signal-unmask! signal/chld))))))
 
 (define %fork fork)
 
diff --git a/tests/run.scm b/tests/run.scm
index 8e202ac..f4409fd 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -17,6 +17,12 @@
   (test "run/string* returns a string output in a subprocess"
         "This is a test"
         (run/string* (lambda () (display "This is a test"))))
+
+  ;; We must mask sigchld, because otherwise our (wait #f) will fail
+  ;; due to scsh-process' signal handler possibly reaping the child
+  ;; before our wait is able to do so.
+  (signal-mask! signal/chld)
+
   (test "wait for next process to exit"
         '(#t #t #t)
         (let ((p (& (sleep 1))))
@@ -24,6 +30,10 @@
            (receive (status2 ok?2 pid2) (wait p)
              (list (eq? status status2) (eq? ok? ok?2) (or (eq? pid pid2) (list pid pid2)))))))
 
+  (test-assert "signal wasn't unmasked" (signal-masked? signal/chld))
+
+  (signal-unmask! signal/chld)
+
   ;; Reported by Haochi Kiang
   (test "run/string* does not redirect stderr"
         '("This should go to stdout" "")