Block only current thread instead of entire process when waiting for a child.

Signed-off-by: Peter Bex <peter@more-magic.net>

1 files changed, 40 insertions, 18 deletions

diff --git a/scsh-process.scm b/scsh-process.scm
index ffff74d..2810baf 100644
--- a/scsh-process.scm
+++ b/scsh-process.scm
@@ -37,6 +37,10 @@
 ; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
 ; OF THE POSSIBILITY OF SUCH DAMAGE.
 
+(declare
+  ;; Avoid FD leaks due to context switch between create-pipe and fork
+  (disable-interrupts))
+
 (module scsh-process
   (;; procedures
    exec-path exec-path* fork %fork fork/pipe %fork/pipe fork/pipe+ %fork/pipe+
@@ -50,7 +54,7 @@
 
 (import chicken scheme data-structures)
 
-(use extras utils files ports posix srfi-1 srfi-69)
+(use extras utils files ports posix srfi-1 srfi-18 srfi-69)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Process bookkeeping ;;
@@ -64,7 +68,14 @@
 ;; process-wait procedure from POSIX, but this allows us to
 ;; transparently mark off processes which were waited on by the user.
 
-(define-record scsh-process pid exit-status ok?)
+(define-record scsh-process pid exit-status ok? child-condition)
+
+;; 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 proc:pid scsh-process-pid)
 (define proc? scsh-process?)
@@ -78,7 +89,8 @@
   (set! *scsh-pending-processes* (make-hash-table)))
 
 (define (add-scsh-pending-process! pid)
-  (let ((process (make-scsh-process pid #f #f)))
+  (let* ((c (make-condition-variable pid))
+         (process (make-scsh-process pid #f #f c)))
     (hash-table-set! *scsh-pending-processes* pid process)
     process))
 
@@ -108,21 +120,29 @@
                 (values (scsh-process-exit-status p)
                         (scsh-process-ok? p)
                         (scsh-process-pid p))
-                (handle-exceptions exn
-                  (if (and p (scsh-process-exit-status p)) ; Signal might've occurred
-                      (values (scsh-process-exit-status p)
-                              (scsh-process-ok? p)
-                              (scsh-process-pid p))
-                      (abort exn))
-                  (receive (pid ok? status)
-                    (posix-process-wait (and p (scsh-process-pid p)) nohang)
-                    (cond
-                     ((zero? pid) (values #f #f #f))
-                     (else (when p
-                             (scsh-process-exit-status-set! p status)
-                             (scsh-process-ok?-set! p ok?))
-                           (remove-scsh-pending-process! pid)
-                           (values status ok? pid)))))))))
+		(if (and p (not nohang))
+		    (let ((m (make-mutex)))
+		      (mutex-unlock! m (scsh-process-child-condition p))
+		      (values (scsh-process-exit-status p)
+			      (scsh-process-ok? p)
+			      (scsh-process-pid p)))
+		    (handle-exceptions exn
+                      (if (and p (scsh-process-exit-status p)) ; Signal might've occurred
+			  (values (scsh-process-exit-status p)
+				  (scsh-process-ok? p)
+				  (scsh-process-pid p))
+			  (abort exn))
+		      (receive (pid ok? status)
+                        (posix-process-wait (and p (scsh-process-pid p)) nohang)
+			(cond
+			 ((zero? pid) (values #f #f #f))
+			 (else (when p
+				 (scsh-process-exit-status-set! p status)
+				 (scsh-process-ok?-set! p ok?)
+				 (condition-variable-broadcast!
+                                  (scsh-process-child-condition p)))
+			       (remove-scsh-pending-process! pid)
+			       (values status ok? pid))))))))))
 
   (set-signal-handler!
    signal/chld
@@ -145,6 +165,8 @@
                            (let ((p (hash-table-ref *scsh-pending-processes* pid)))
                              (scsh-process-exit-status-set! p status)
                              (scsh-process-ok?-set! p ok?)
+			     (condition-variable-broadcast!
+                              (scsh-process-child-condition p))
                              ;; The GC can clean it up
                              (remove-scsh-pending-process! pid))))))
                    (hash-table-keys *scsh-pending-processes*))