diff options
| -rw-r--r-- | scsh-process.scm | 49 |
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) |