In MAKE-THREAD, use WITH-SYSTEM-MUTEX for locking *MAKE-THREAD-LOCK*

Otherwise MAKE-THREAD could be interrupted after having
locked *MAKE-THREAD-LOCK*. If the interrupting code also called
MAKE-THREAD, a recursive lock attempt for *MAKE-THREAD-LOCK* would
occur.

The problem could be easily triggered by

  (MAKE-TIMER ... :THREAD <T or a thread>)

Also move let bindings of SETUP-SEM, REAL-FUNCTION, ARGUMENTS and
INITIAL-FUNCTION and the NOT *GC-INHIBIT* assertion out of the
critical section.

Tests have been added in threads.pure.lisp and timer.impure.lisp.

fixes lp#1180102.

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 80e3fee..a797741 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -1384,7 +1384,7 @@ have the foreground next."
     (setf (thread-os-thread thread) (current-thread-os-thread))
     (with-mutex ((thread-result-lock thread))
       (with-all-threads-lock
-          (push thread *all-threads*))
+        (push thread *all-threads*))
       (with-session-lock (*session*)
         (push thread (session-threads *session*)))
       (setf (thread-%alive-p thread) t)
@@ -1449,32 +1449,31 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
                        'make-thread arguments)
   #!+sb-thread
   (let ((thread (%make-thread :name name :%ephemeral-p ephemeral)))
-     (with-mutex (*make-thread-lock*)
-       (let* ((setup-sem (make-semaphore :name "Thread setup semaphore"))
-              (real-function (coerce function 'function))
-              (arguments     (if (listp arguments)
-                                 arguments
-                                 (list arguments)))
-              (initial-function
-               (named-lambda initial-thread-function ()
-                 ;; As it is, this lambda must not cons until we are ready
-                 ;; to run GC. Be very careful.
-                 (initial-thread-function-trampoline
-                  thread setup-sem real-function arguments nil nil nil))))
-         ;; If the starting thread is stopped for gc before it signals the
-         ;; semaphore then we'd be stuck.
-         (assert (not *gc-inhibit*))
-         ;; Keep INITIAL-FUNCTION pinned until the child thread is
-         ;; initialized properly. Wrap the whole thing in
-         ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another
-         ;; thread.
-         (without-interrupts
-           (with-pinned-objects (initial-function)
-             (if (zerop
-                  (%create-thread (get-lisp-obj-address initial-function)))
-                 (setf thread nil)
-                 (wait-on-semaphore setup-sem))))))
-     (or thread (error "Could not create a new thread."))))
+    (let* ((setup-sem (make-semaphore :name "Thread setup semaphore"))
+           (real-function (coerce function 'function))
+           (arguments     (if (listp arguments)
+                              arguments
+                              (list arguments)))
+           (initial-function
+             (named-lambda initial-thread-function ()
+               ;; As it is, this lambda must not cons until we are
+               ;; ready to run GC. Be very careful.
+               (initial-thread-function-trampoline
+                thread setup-sem real-function arguments nil nil nil))))
+      ;; If the starting thread is stopped for gc before it signals
+      ;; the semaphore then we'd be stuck.
+      (assert (not *gc-inhibit*))
+      ;; Keep INITIAL-FUNCTION pinned until the child thread is
+      ;; initialized properly. Wrap the whole thing in
+      ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to
+      ;; another thread.
+      (with-system-mutex (*make-thread-lock*)
+        (with-pinned-objects (initial-function)
+          (if (zerop
+               (%create-thread (get-lisp-obj-address initial-function)))
+              (setf thread nil)
+              (wait-on-semaphore setup-sem)))))
+    (or thread (error "Could not create a new thread."))))
 
 (defun join-thread (thread &key (default nil defaultp) timeout)
   #!+sb-doc

diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp
index ea80fa3..00040dd 100644 (file)
--- a/tests/threads.pure.lisp
+++ b/tests/threads.pure.lisp
@@ -594,3 +594,26 @@
                 (thread-error ()
                   :oops)))))
 
+;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
+;; before entering WITHOUT-INTERRUPTS. When a thread which was
+;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
+;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
+;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
+;; interrupting code thus made a recursive lock attempt.
+;;
+;; See (:TIMER :DISPATCH-THREAD :MAKE-THREAD :BUG-1180102) in
+;; timer.impure.lisp.
+(with-test (:name (make-thread :interrupt-with make-thread :bug-1180102)
+            :skipped-on '(not :sb-thread))
+  (dotimes (i 100)
+    (let ((threads '())
+          (parent *current-thread*))
+      (dotimes (i 100)
+        (push (make-thread
+               (lambda ()
+                 (interrupt-thread
+                  parent
+                  (lambda () (push (make-thread (lambda ())) threads)))))
+              threads)
+        (push (make-thread (lambda ())) threads))
+      (mapc #'join-thread threads))))

diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp
index 4bbaf91..734d810 100644 (file)
--- a/tests/timer.impure.lisp
+++ b/tests/timer.impure.lisp
@@ -326,3 +326,29 @@
           (dolist (thread threads)
             (sched thread)))
         (mapcar #'sb-thread:join-thread threads)))))
+
+;; SB-THREAD:MAKE-THREAD used to lock SB-THREAD:*MAKE-THREAD-LOCK*
+;; before entering WITHOUT-INTERRUPTS. When a thread which was
+;; executing SB-THREAD:MAKE-THREAD was interrupted with code which
+;; also called SB-THREAD:MAKE-THREAD, it could happen that the first
+;; thread already owned SB-THREAD:*MAKE-THREAD-LOCK* and the
+;; interrupting code thus made a recursive lock attempt. A timer with
+;; :THREAD T or :THREAD <some thread spawning child threads> could
+;; also trigger this problem.
+;;
+;; See (MAKE-THREAD :INTERRUPT-WITH MAKE-THREAD :BUG-1180102) in
+;; threads.pure.lisp.
+(with-test (:name (:timer :dispatch-thread :make-thread :bug-1180102)
+            :skipped-on '(not :sb-thread))
+  (flet ((test (thread)
+           (let ((timer (make-timer (lambda ()) :thread thread)))
+             (schedule-timer timer .01 :repeat-interval 0.1)
+             (dotimes (i 100)
+               (let ((threads '()))
+                 (dotimes (i 100)
+                   (push (sb-thread:make-thread (lambda () (sleep .01)))
+                         threads))
+                 (mapc #'sb-thread:join-thread threads)))
+             (unschedule-timer timer))))
+    (test t)
+    (test sb-thread:*current-thread*)))