Temporarily mask sigchld to avoid race condition in fork

We do a fork, and immediately afterwards we insert a scsh-process
object into the pending processes table with the pid of the newly
created child process.

However, sigchld may arrive in between the fork and the insertion of
the scsh-process object into the pending process table.  The sigchld
handler will reap the child process and attempt to update the pending
scsh-process object, but it can't find it yet because the insertion of
this object into the table happens after the fork, thus losing the
reaped child's exit status.

Then, if the program waits for the process after that, we enter an
infinite busy waiting loop that expects a sigchld to arrive and update
the object through the table, but that never happens because the child
has already been reaped.

1 files changed, 29 insertions, 20 deletions

diff --git a/scsh-process.scm b/scsh-process.scm
index 4153c00..4e6708d 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -221,26 +221,35 @@
     (exit 0)))
 
 (define (fork #!optional thunk continue-threads?)
-  (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
-                 (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)))))
+  (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
+                      (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))))
 
 (define %fork fork)