0.9.2.34:

  * bug fix: run-program is now thread safe(r)
  * enable debugger in threads.impure.lisp for the duration of
    the debugger test

diff --git a/NEWS b/NEWS
index f4267cc..4f76b01 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -30,6 +30,7 @@ changes in sbcl-0.9.3 relative to sbcl-0.9.2:
     ** bug fix: fixed thread safety issues in read and print
     ** bug fix: debugger doesn't hang on session lock if interrupted at
        an inappropriate moment
+    ** bug fix: run-program is now thread safe(r)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** TYPE-ERRORs from signalled by COERCE now have DATUM and
        EXPECTED-TYPE slots filled.

diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index ab9ebf7..45c0ccc 100644 (file)
--- 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*)))))))))
 \f
 ;;;; RUN-PROGRAM and close friends
 
@@ -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

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index e073ad9..fc917b4 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -352,6 +352,7 @@
 
 (format t "~&thread startup sigmask test done~%")
 
+(sb-debug::enable-debugger)
 (let* ((main-thread *current-thread*)
        (interruptor-thread
         (make-thread (lambda ()

diff --git a/version.lisp-expr b/version.lisp-expr
index 2aecb34..a028091 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.2.33"
+"0.9.2.34"