summaryrefslogtreecommitdiff
path: root/scsh-process.scm
diff options
context:
space:
mode:
Diffstat (limited to 'scsh-process.scm')
-rw-r--r--scsh-process.scm59
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)