From 668662e152edb8f3a1d4cb80287ada419561b26b Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Thu, 7 Jul 2005 10:13:03 +0000 Subject: [PATCH] 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 --- NEWS | 1 + src/code/run-program.lisp | 38 +++++++++++++++++++++++++------------- tests/threads.impure.lisp | 1 + version.lisp-expr | 2 +- 4 files changed, 28 insertions(+), 14 deletions(-) diff --git a/NEWS b/NEWS index f4267cc..4f76b01 100644 --- 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 --- 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 @@ -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 --- 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 --- 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" -- 1.7.10.4