From b8846766dd1ecb2b6c3dce848f2aae0b3b11a6ea Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Sun, 23 Jun 2013 19:13:14 +0200 Subject: [PATCH] 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 ) 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. --- src/code/target-thread.lisp | 53 +++++++++++++++++++++---------------------- tests/threads.pure.lisp | 23 +++++++++++++++++++ tests/timer.impure.lisp | 26 +++++++++++++++++++++ 3 files changed, 75 insertions(+), 27 deletions(-) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 80e3fee..a797741 100644 --- 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 --- 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 --- 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 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*))) -- 1.7.10.4