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

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index 0808fdd..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)))
@@ -348,13 +361,12 @@
 	(declare (simple-string s))
 	(let ((n (length s)))
 	  ;; Blast the string into place.
-	  (sb-kernel:copy-to-system-area (the simple-base-string
-                                           ;; FIXME
-                                           (coerce s 'simple-base-string))
-					 (* sb-vm:vector-data-offset
-					    sb-vm:n-word-bits)
-					 string-sap 0
-					 (* (1+ n) sb-vm:n-byte-bits))
+	  (sb-kernel:copy-ub8-to-system-area (the simple-base-string
+                                               ;; FIXME
+                                               (coerce s 'simple-base-string))
+                                             0
+                                             string-sap 0
+                                             (1+ n))
 	  ;; Blast the pointer to the string into place.
 	  (setf (sap-ref-sap vec-sap i) string-sap)
 	  (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
@@ -585,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
@@ -666,11 +678,10 @@
                                      ~2I~_~A~:>"
 				 (strerror errno)))
 			       (t
-				(sb-kernel:copy-from-system-area
+				(sb-kernel:copy-ub8-from-system-area
 				 (alien-sap buf) 0
-				 string (* sb-vm:vector-data-offset
-					   sb-vm:n-word-bits)
-				 (* count sb-vm:n-byte-bits))
+				 string 0
+                                 count)
 				(write-string string stream
 					      :end count)))))))))))