X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Frun-program.lisp;h=45c0ccce2248b1b54cbd588fe7efa7bb1dcfebb1;hb=bb756e3d4b19c30d4a9cd4250b606c5969613ad9;hp=25c31c20aeb4602ad49810080ae429af1bcdb0e8;hpb=338732358d49ab202fe55c3581294597d63aec6b;p=sbcl.git

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index 25c31c2..45c0ccc 100644
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -138,6 +138,17 @@
 (defvar *active-processes* nil
   "List of process structures for all active processes.")
 
+(defvar *active-processes-lock* 
+  (sb-thread:make-mutex :name "Lock for active processes."))
+
+;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a
+;;; mutex is needed. More importantly the sigchld signal handler also
+;;; accesses it, that's why we need without-interrupts.
+(defmacro with-active-processes-lock (() &body body)
+  `(without-interrupts
+    (sb-thread:with-mutex (*active-processes-lock*)
+      ,@body)))
+
 (defstruct (process (:copier nil))
   pid		      ; PID of child process
   %status             ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
@@ -245,7 +256,7 @@
     (frob (process-input  proc)   t) ; .. 'cause it will generate SIGPIPE.
     (frob (process-output proc) nil)
     (frob (process-error  proc) nil))
-  (sb-sys:without-interrupts
+  (with-active-processes-lock ()
    (setf *active-processes* (delete proc *active-processes*)))
   proc)
 
@@ -260,17 +271,18 @@
 	  (wait3 t t)
 	(unless pid
 	  (return))
-	(let ((proc (find pid *active-processes* :key #'process-pid)))
-	  (when proc
-	    (setf (process-%status proc) what)
-	    (setf (process-exit-code proc) code)
-	    (setf (process-core-dumped proc) core)
-	    (when (process-status-hook proc)
-	      (funcall (process-status-hook proc) proc))
-	    (when (position what #(:exited :signaled))
-	      (sb-sys:without-interrupts
-	       (setf *active-processes*
-		     (delete proc *active-processes*)))))))))
+        (let ((proc (with-active-processes-lock ()
+                      (find pid *active-processes* :key #'process-pid))))
+          (when proc
+            (setf (process-%status proc) what)
+            (setf (process-exit-code proc) code)
+            (setf (process-core-dumped proc) core)
+            (when (process-status-hook proc)
+              (funcall (process-status-hook proc) proc))
+            (when (position what #(:exited :signaled))
+              (with-active-processes-lock ()
+                (setf *active-processes*
+                      (delete proc *active-processes*)))))))))
 
 ;;;; RUN-PROGRAM and close friends
 
@@ -320,7 +332,8 @@
 	  (push new-fd *close-on-error*)
 	  (copy-descriptor-to-stream new-fd pty cookie)))
       (values name
-	      (sb-sys:make-fd-stream master :input t :output t)))))
+	      (sb-sys:make-fd-stream master :input t :output t 
+				     :dual-channel-p t)))))
 
 (defmacro round-bytes-to-words (n)
   `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
@@ -584,7 +597,7 @@
 		   ;; Make sure we are not notified about the child
 		   ;; death before we have installed the PROCESS
 		   ;; structure in *ACTIVE-PROCESSES*.
-		   (sb-sys:without-interrupts
+		   (with-active-processes-lock ()
 		    (with-c-strvec (args-vec simple-args)
 		      (with-c-strvec (environment-vec environment)
 			(let ((child-pid