From a29a4e79aa00d697a564cb3bd7f1f78d7e5d7245 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Fri, 10 Nov 2017 21:00:22 +0100
Subject: Don't unmask signal if the signal was already masked before forking

---
 scsh-process.scm | 59 +++++++++++++++++++++++++++++---------------------------
 1 file changed, 31 insertions(+), 28 deletions(-)

(limited to 'scsh-process.scm')

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)
 
-- 
cgit v1.2.3