From 86310f955b1eb393a605a18ff9d734823c2b29df Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Sat, 3 Jun 2017 15:11:22 +0200
Subject: Reinstall deadlock workaround thread when forking with thread killing
---
scsh-process.scm | 19 +++++++++++++++----
1 file changed, 15 insertions(+), 4 deletions(-)
diff --git a/scsh-process.scm b/scsh-process.scm
index 0676681..a5d3df6 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -73,9 +73,12 @@
;; Aaaand another hack to avoid getting "deadlock detected" when all
;; threads are waiting for a child condition. We can still get woken
;; up by the signal/chld handler (see below).
-(thread-start!
- (make-thread (lambda () (let lp () (thread-sleep! 100) (lp)))
- 'work-around-broken-deadlock-detection))
+(define (install-deadlock-workaround!)
+ (thread-start!
+ (make-thread (lambda () (let lp () (thread-sleep! 100) (lp)))
+ 'work-around-broken-deadlock-detection)))
+
+(install-deadlock-workaround!) ;; And again on fork
(define proc:pid scsh-process-pid)
(define proc? scsh-process?)
@@ -208,8 +211,15 @@
(exit 0)))
(define (fork #!optional thunk continue-threads?)
- (let* ((thunk (and thunk (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
@@ -218,6 +228,7 @@
(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)))))
--
cgit v1.2.3