1.0.25.40: fix JOIN-THREAD

If the thread has not returned normally signal the error when not
holding the mutex anymore. Disable interrupt for the duration of
holding the mutex. Fix test.

diff --git a/NEWS b/NEWS
index 5f1f129..a1cd3c5 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,9 @@ changes in sbcl-1.0.26 relative to 1.0.25:
     printed to stderr.
   * optimization: slightly faster gc on multithreaded builds
   * optimization: faster WITHOUT-GCING
+  * bug fix: when JOIN-THREAD signals an error, do it when not holding
+    important locks so that the debugger/handler doesn't produce
+    recursive errors or deadlock.
   * bug fix: real-time signals are not used anymore, so no more
     hanging when the system wide real-time signal queue gets full.
   * bug fix: finalizers, gc hooks never run in a WITHOUT-INTERRUPTS

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 58d6ffa..015ebd1 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -878,13 +878,13 @@ around and can be retrieved by JOIN-THREAD."
   "Suspend current thread until THREAD exits. Returns the result
 values of the thread function. If the thread does not exit normally,
 return DEFAULT if given or else signal JOIN-THREAD-ERROR."
-  (with-mutex ((thread-result-lock thread))
+  (with-system-mutex ((thread-result-lock thread) :allow-with-interrupts t)
     (cond ((car (thread-result thread))
-           (values-list (cdr (thread-result thread))))
+           (return-from join-thread
+             (values-list (cdr (thread-result thread)))))
           (defaultp
-           default)
-          (t
-           (error 'join-thread-error :thread thread)))))
+           (return-from join-thread default))))
+  (error 'join-thread-error :thread thread))
 
 (defun destroy-thread (thread)
   #!+sb-doc

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 3672c92..ccc78ac 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -113,7 +113,8 @@
                                  :default sym)))))
 
 (with-test (:name '(:join-thread :nlx :error))
-  (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))))
+  (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
+                 join-thread-error))
 
 (with-test (:name '(:join-thread :multiple-values))
   (assert (equal '(1 2 3)

diff --git a/version.lisp-expr b/version.lisp-expr
index 1ef8e95..c6df9ac 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".)
-"1.0.25.39"
+"1.0.25.40"