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