diff options
Diffstat (limited to 'scsh-process.scm')
| -rw-r--r-- | scsh-process.scm | 59 |
1 files changed, 31 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) |