X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=402fe683d03cd139b93ae6f3a2b4139da07e0759;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=0d0ccb96d94dcf77bc647b02e9aa7ca05f986d35;hpb=b56c1a4dc22aa0ac827343667584aa6090b15f02;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 0d0ccb9..402fe68 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -35,32 +35,34 @@ WITH-CAS-LOCK can be entered recursively." (%with-cas-lock (,place) ,@body))) (defmacro %with-cas-lock ((place) &body body &environment env) - (with-unique-names (self owner) - ;; Take care not to multiply-evaluate anything. - ;; - ;; FIXME: Once we get DEFCAS this can use GET-CAS-EXPANSION. - (let* ((placex (sb!xc:macroexpand place env)) - (place-op (if (consp placex) - (car placex) - (error "~S: ~S is not a valid place for ~S" - 'with-cas-lock - place 'sb!ext:compare-and-swap))) - (place-args (cdr placex)) - (temps (make-gensym-list (length place-args) t)) - (place `(,place-op ,@temps))) - `(let* (,@(mapcar #'list temps place-args) + (with-unique-names (owner self) + (multiple-value-bind (vars vals old new cas-form read-form) + (sb!ext:get-cas-expansion place env) + `(let* (,@(mapcar #'list vars vals) + (,owner (progn + (barrier (:read)) + ,read-form)) (,self *current-thread*) - (,owner ,place)) + (,old nil) + (,new ,self)) (unwind-protect (progn (unless (eq ,owner ,self) - (loop while (setf ,owner - (or ,place - (sb!ext:compare-and-swap ,place nil ,self))) + (loop until (loop repeat 100 + when (and (progn + (barrier (:read)) + (not ,read-form)) + (not (setf ,owner ,cas-form))) + return t + else + do (sb!ext:spin-loop-hint)) do (thread-yield))) ,@body) (unless (eq ,owner ,self) - (sb!ext:compare-and-swap ,place ,self nil))))))) + (let ((,old ,self) + (,new nil)) + (unless (eq ,old ,cas-form) + (bug "Failed to release CAS lock!"))))))))) ;;; Conditions @@ -72,14 +74,23 @@ WITH-CAS-LOCK can be entered recursively." The offending thread is initialized by the :THREAD initialization argument and read by the function THREAD-ERROR-THREAD.")) +(define-condition simple-thread-error (thread-error simple-condition) + ()) + (define-condition thread-deadlock (thread-error) ((cycle :initarg :cycle :reader thread-deadlock-cycle)) (:report (lambda (condition stream) - (let ((*print-circle* t)) - (format stream "Deadlock cycle detected:~%~@< ~@;~ - ~{~:@_~S~:@_~}~:@>" - (mapcar #'car (thread-deadlock-cycle condition))))))) + (let* ((*print-circle* t) + (cycle (thread-deadlock-cycle condition)) + (start (caar cycle))) + (format stream "Deadlock cycle detected:~%") + (loop for part = (pop cycle) + while part + do (format stream " ~S~% waited for:~% ~S~% owned by:~%" + (car part) + (cdr part))) + (format stream " ~S~%" start))))) #!+sb-doc (setf @@ -168,7 +179,9 @@ arbitrary printable objects, and need not be unique.") (multiple-value-list (join-thread thread :default cookie)))) (state (if (eq :running info) - (let* ((thing (thread-waiting-for thread))) + (let* ((thing (progn + (barrier (:read)) + (thread-waiting-for thread)))) (typecase thing (cons (list "waiting on:" (cdr thing) @@ -207,6 +220,14 @@ potentially stale even before the function returns, as the thread may exit at any time." (thread-%alive-p thread)) +(defun thread-ephemeral-p (thread) + #!+sb-doc + "Return T if THREAD is `ephemeral', which indicates that this thread is +used by SBCL for internal purposes, and specifically that it knows how to +to terminate this thread cleanly prior to core file saving without signalling +an error in that case." + (thread-%ephemeral-p thread)) + ;; A thread is eligible for gc iff it has finished and there are no ;; more references to it. This list is supposed to keep a reference to ;; all running threads. @@ -238,25 +259,101 @@ created and old ones may exit at any time." #!-sb-thread 0) +(defvar *initial-thread* nil) +(defvar *make-thread-lock*) + (defun init-initial-thread () (/show0 "Entering INIT-INITIAL-THREAD") - (let ((initial-thread (%make-thread :name "initial thread" + (setf sb!impl::*exit-lock* (make-mutex :name "Exit Lock") + *make-thread-lock* (make-mutex :name "Make-Thread Lock")) + (let ((initial-thread (%make-thread :name "main thread" :%alive-p t :os-thread (current-thread-os-thread)))) - (setq *current-thread* initial-thread) + (setq *initial-thread* initial-thread + *current-thread* initial-thread) + (grab-mutex (thread-result-lock *initial-thread*)) ;; Either *all-threads* is empty or it contains exactly one thread ;; in case we are in reinit since saving core with multiple ;; threads doesn't work. (setq *all-threads* (list initial-thread)))) + +(defun main-thread () + "Returns the main thread of the process." + *initial-thread*) + +(defun main-thread-p (&optional (thread *current-thread*)) + "True if THREAD, defaulting to current thread, is the main thread of the process." + (eq thread *initial-thread*)) + +(defmacro return-from-thread (values-form &key allow-exit) + "Unwinds from and terminates the current thread, with values from +VALUES-FORM as the results visible to JOIN-THREAD. + +If current thread is the main thread of the process (see +MAIN-THREAD-P), signals an error unless ALLOW-EXIT is true, as +terminating the main thread would terminate the entire process. If +ALLOW-EXIT is true, returning from the main thread is equivalent to +calling SB-EXT:EXIT with :CODE 0 and :ABORT NIL. + +See also: ABORT-THREAD and SB-EXT:EXIT." + `(%return-from-thread (multiple-value-list ,values-form) ,allow-exit)) + +(defun %return-from-thread (values allow-exit) + (let ((self *current-thread*)) + (cond ((main-thread-p self) + (unless allow-exit + (error 'simple-thread-error + :format-control "~@" + :format-arguments (list values) + :thread self)) + (sb!ext:exit :code 0)) + (t + (throw '%return-from-thread (values-list values)))))) + +(defun abort-thread (&key allow-exit) + "Unwinds from and terminates the current thread abnormally, causing +JOIN-THREAD on current thread to signal an error unless a +default-value is provided. + +If current thread is the main thread of the process (see +MAIN-THREAD-P), signals an error unless ALLOW-EXIT is true, as +terminating the main thread would terminate the entire process. If +ALLOW-EXIT is true, aborting the main thread is equivalent to calling +SB-EXT:EXIT code 1 and :ABORT NIL. + +Invoking the initial ABORT restart estabilished by MAKE-THREAD is +equivalent to calling ABORT-THREAD in other than main threads. +However, whereas ABORT restart may be rebound, ABORT-THREAD always +unwinds the entire thread. (Behaviour of the initial ABORT restart for +main thread depends on the :TOPLEVEL argument to +SB-EXT:SAVE-LISP-AND-DIE.) + +See also: RETURN-FROM-THREAD and SB-EXT:EXIT." + (let ((self *current-thread*)) + (cond ((main-thread-p self) + (unless allow-exit + (error 'simple-thread-error + :format-control "~@")) + (sb!ext:exit :code 1)) + (t + ;; We /could/ use TOPLEVEL-CATCHER or %END-OF-THE-WORLD as well, but + ;; this seems tidier. Those to are a bit too overloaded already. + (throw '%abort-thread t))))) ;;;; Aliens, low level stuff (define-alien-routine "kill_safely" integer - (os-thread #!-alpha unsigned-long #!+alpha unsigned-int) + (os-thread #!-alpha unsigned #!+alpha unsigned-int) (signal int)) +(define-alien-routine "wake_thread" + integer + (os-thread unsigned)) + #!+sb-thread (progn ;; FIXME it would be good to define what a thread id is or isn't @@ -264,13 +361,13 @@ created and old ones may exit at any time." ;; that on Linux it's a pid, but it might not be on posix thread ;; implementations. (define-alien-routine ("create_thread" %create-thread) - unsigned-long (lisp-fun-address unsigned-long)) + unsigned (lisp-fun-address unsigned)) (declaim (inline %block-deferrable-signals)) (define-alien-routine ("block_deferrable_signals" %block-deferrable-signals) void - (where sb!alien:unsigned-long) - (old sb!alien:unsigned-long)) + (where unsigned) + (old unsigned)) (defun block-deferrable-signals () (%block-deferrable-signals 0 0)) @@ -279,16 +376,16 @@ created and old ones may exit at any time." (progn (declaim (inline futex-wait %futex-wait futex-wake)) - (define-alien-routine ("futex_wait" %futex-wait) - int (word unsigned-long) (old-value unsigned-long) - (to-sec long) (to-usec unsigned-long)) + (define-alien-routine ("futex_wait" %futex-wait) int + (word unsigned) (old-value unsigned) + (to-sec long) (to-usec unsigned-long)) (defun futex-wait (word old to-sec to-usec) (with-interrupts (%futex-wait word old to-sec to-usec))) (define-alien-routine "futex_wake" - int (word unsigned-long) (n unsigned-long)))) + int (word unsigned) (n unsigned-long)))) ;;; used by debug-int.lisp to access interrupt contexts #!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap)) @@ -323,10 +420,12 @@ created and old ones may exit at any time." (unwind-protect (progn (setf (thread-waiting-for ,n-thread) ,new) + (barrier (:write)) ,@forms) ;; Interrupt handlers and GC save and restore any ;; previous wait marks using WITHOUT-DEADLOCKS below. - (setf (thread-waiting-for ,n-thread) nil))))) + (setf (thread-waiting-for ,n-thread) nil) + (barrier (:write)))))) ;;;; Mutexes @@ -356,32 +455,41 @@ HOLDING-MUTEX-P." ;; Make sure to get the current value. (sb!ext:compare-and-swap (mutex-%owner mutex) nil nil)) +(sb!ext:defglobal **deadlock-lock** nil) + ;;; Signals an error if owner of LOCK is waiting on a lock whose release ;;; depends on the current thread. Does not detect deadlocks from sempahores. (defun check-deadlock () (let* ((self *current-thread*) - (origin (thread-waiting-for self))) + (origin (progn + (barrier (:read)) + (thread-waiting-for self)))) (labels ((detect-deadlock (lock) (let ((other-thread (mutex-%owner lock))) (cond ((not other-thread)) ((eq self other-thread) - (let* ((chain (deadlock-chain self origin)) - (barf - (format nil - "~%WARNING: DEADLOCK CYCLE DETECTED:~%~@< ~@;~ - ~{~:@_~S~:@_~}~:@>~ - ~%END OF CYCLE~%" - (mapcar #'car chain)))) - ;; Barf to stderr in case the system is too tied up - ;; to report the error properly -- to avoid cross-talk - ;; build the whole string up first. - (write-string barf sb!sys:*stderr*) - (finish-output sb!sys:*stderr*) + (let ((chain + (with-cas-lock ((symbol-value '**deadlock-lock**)) + (prog1 (deadlock-chain self origin) + ;; We're now committed to signaling the + ;; error and breaking the deadlock, so + ;; mark us as no longer waiting on the + ;; lock. This ensures that a single + ;; deadlock is reported in only one + ;; thread, and that we don't look like + ;; we're waiting on the lock when print + ;; stuff -- because that may lead to + ;; further deadlock checking, in turn + ;; possibly leading to a bogus vicious + ;; metacycle on PRINT-OBJECT. + (setf (thread-waiting-for self) nil))))) (error 'thread-deadlock :thread *current-thread* :cycle chain))) (t - (let ((other-lock (thread-waiting-for other-thread))) + (let ((other-lock (progn + (barrier (:read)) + (thread-waiting-for other-thread)))) ;; If the thread is waiting with a timeout OTHER-LOCK ;; is a cons, and we don't consider it a deadlock -- since ;; it will time out on its own sooner or later. @@ -390,6 +498,7 @@ HOLDING-MUTEX-P." (deadlock-chain (thread lock) (let* ((other-thread (mutex-owner lock)) (other-lock (when other-thread + (barrier (:read)) (thread-waiting-for other-thread)))) (cond ((not other-thread) ;; The deadlock is gone -- maybe someone unwound @@ -406,7 +515,7 @@ HOLDING-MUTEX-P." (list (list thread lock))) (t (if other-lock - (cons (list thread lock) + (cons (cons thread lock) (deadlock-chain other-thread other-lock)) ;; Again, the deadlock is gone? (return-from check-deadlock nil))))))) @@ -424,10 +533,11 @@ HOLDING-MUTEX-P." #!-sb-thread (when old (error "Strange deadlock on ~S in an unithreaded build?" mutex)) - #!-sb-futex - (and (not (mutex-%owner mutex)) + #!-(and sb-thread sb-futex) + (and (not old) + ;; Don't even bother to try to CAS if it looks bad. (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner))) - #!+sb-futex + #!+(and sb-thread sb-futex) ;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper. (when (eql +lock-free+ (sb!ext:compare-and-swap (mutex-state mutex) +lock-free+ @@ -444,11 +554,16 @@ HOLDING-MUTEX-P." (declare (ignore to-sec to-usec)) #!-sb-futex (flet ((cas () - (loop repeat 24 - when (and (not (mutex-%owner mutex)) + (loop repeat 100 + when (and (progn + (barrier (:read)) + (not (mutex-%owner mutex))) (not (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner))) - do (return-from cas t)) + do (return-from cas t) + else + do + (sb!ext:spin-loop-hint)) ;; Check for pending interrupts. (with-interrupts nil))) (declare (dynamic-extent #'cas)) @@ -493,6 +608,7 @@ HOLDING-MUTEX-P." ;; Spin. (go :retry)))) +#!+sb-thread (defun %wait-for-mutex (mutex self timeout to-sec to-usec stop-sec stop-usec deadlinep) (with-deadlocks (self mutex timeout) (with-interrupts (check-deadlock)) @@ -507,9 +623,8 @@ HOLDING-MUTEX-P." (decode-timeout timeout)) (go :again))))))) -(defun get-mutex (mutex &optional new-owner (waitp t) (timeout nil)) - #!+sb-doc - "Deprecated in favor of GRAB-MUTEX." +(define-deprecated-function :early "1.0.37.33" get-mutex (grab-mutex) + (mutex &optional new-owner (waitp t) (timeout nil)) (declare (ignorable waitp timeout)) (let ((new-owner (or new-owner *current-thread*))) (or (%try-mutex mutex new-owner) @@ -588,7 +703,7 @@ IF-NOT-OWNER is :FORCE)." ;; FIXME: Is a :memory barrier too strong here? Can we use a :write ;; barrier instead? (barrier (:memory))) - #!+sb-futex + #!+(and sb-thread sb-futex) (when old-owner ;; FIXME: once ATOMIC-INCF supports struct slots with word sized ;; unsigned-byte type this can be used: @@ -615,7 +730,7 @@ IF-NOT-OWNER is :FORCE)." #!+sb-doc "Waitqueue type." (name nil :type (or null thread-name)) - #!+sb-futex + #!+(and sb-thread sb-futex) (token nil)) #!+(and sb-thread (not sb-futex)) @@ -648,17 +763,18 @@ IF-NOT-OWNER is :FORCE)." (setf (thread-waiting-for thread) nil) (let ((head (waitqueue-%head queue))) (do ((list head (cdr list)) - (prev nil)) - ((eq (car list) thread) - (let ((rest (cdr list))) - (cond (prev - (setf (cdr prev) rest)) - (t - (setf (waitqueue-%head queue) rest - prev rest))) - (unless rest - (setf (waitqueue-%tail queue) prev)))) - (setf prev list))) + (prev nil list)) + ((or (null list) + (eq (car list) thread)) + (when list + (let ((rest (cdr list))) + (cond (prev + (setf (cdr prev) rest)) + (t + (setf (waitqueue-%head queue) rest + prev rest))) + (unless rest + (setf (waitqueue-%tail queue) prev))))))) nil) (defun %waitqueue-wakeup (queue n) (declare (fixnum n)) @@ -672,7 +788,8 @@ IF-NOT-OWNER is :FORCE)." (setf (waitqueue-%head queue) (cdr head))) (car head))) while next - do (when (eq queue (sb!ext:compare-and-swap (thread-waiting-for next) queue nil)) + do (when (eq queue (sb!ext:compare-and-swap + (thread-waiting-for next) queue nil)) (decf n))) nil)) @@ -732,10 +849,11 @@ around the call, checking the the associated data: (push data *data*) (condition-notify *queue*))) " - #!-sb-thread (declare (ignore queue timeout)) + #!-sb-thread + (declare (ignore queue)) (assert mutex) #!-sb-thread - (wait-for nil :timeout timeout) ; Yeah... + (sb!ext:wait-for nil :timeout timeout) ; Yeah... #!+sb-thread (let ((me *current-thread*)) (barrier (:read)) @@ -750,11 +868,13 @@ around the call, checking the the associated data: (progn #!-sb-futex (progn - (%waitqueue-enqueue me queue) + (%with-cas-lock ((waitqueue-%owner queue)) + (%waitqueue-enqueue me queue)) (release-mutex mutex) (setf status (or (flet ((wakeup () - (when (neq queue (thread-waiting-for me)) + (barrier (:read)) + (unless (eq queue (thread-waiting-for me)) :ok))) (declare (dynamic-extent #'wakeup)) (allow-with-interrupts @@ -886,8 +1006,38 @@ future." (setf (fdocumentation 'semaphore-name 'function) "The name of the semaphore INSTANCE. Setfable.") +(defstruct (semaphore-notification (:constructor make-semaphore-notification ()) + (:copier nil)) + #!+sb-doc + "Semaphore notification object. Can be passed to WAIT-ON-SEMAPHORE and +TRY-SEMAPHORE as the :NOTIFICATION argument. Consequences are undefined if +multiple threads are using the same notification object in parallel." + (%status nil :type boolean)) + +(setf (fdocumentation 'make-semaphore-notification 'function) + "Constructor for SEMAPHORE-NOTIFICATION objects. SEMAPHORE-NOTIFICATION-STATUS +is initially NIL.") + +(declaim (inline semaphore-notification-status)) +(defun semaphore-notification-status (semaphore-notification) + #!+sb-doc + "Returns T if a WAIT-ON-SEMAPHORE or TRY-SEMAPHORE using +SEMAPHORE-NOTIFICATION has succeeded since the notification object was created +or cleared." + (barrier (:read)) + (semaphore-notification-%status semaphore-notification)) + +(declaim (inline clear-semaphore-notification)) +(defun clear-semaphore-notification (semaphore-notification) + #!+sb-doc + "Resets the SEMAPHORE-NOTIFICATION object for use with another call to +WAIT-ON-SEMAPHORE or TRY-SEMAPHORE." + (barrier (:write) + (setf (semaphore-notification-%status semaphore-notification) nil))) + (declaim (inline semaphore-count)) (defun semaphore-count (instance) + #!+sb-doc "Returns the current count of the semaphore INSTANCE." (barrier (:read)) (semaphore-%count instance)) @@ -897,14 +1047,23 @@ future." "Create a semaphore with the supplied COUNT and NAME." (%make-semaphore name count)) -(defun wait-on-semaphore (semaphore &key timeout) +(defun wait-on-semaphore (semaphore &key timeout notification) #!+sb-doc "Decrement the count of SEMAPHORE if the count would not be negative. Else blocks until the semaphore can be decremented. Returns T on success. If TIMEOUT is given, it is the maximum number of seconds to wait. If the count cannot be decremented in that time, returns NIL without decrementing the -count." +count. + +If NOTIFICATION is given, it must be a SEMAPHORE-NOTIFICATION object whose +SEMAPHORE-NOTIFICATION-STATUS is NIL. If WAIT-ON-SEMAPHORE succeeds and +decrements the count, the status is set to T." + (when (and notification (semaphore-notification-status notification)) + (with-simple-restart (continue "Clear notification status and continue.") + (error "~@" + 'wait-on-semaphore semaphore)) + (clear-semaphore-notification notification)) ;; A more direct implementation based directly on futexes should be ;; possible. ;; @@ -916,36 +1075,55 @@ count." (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) ;; Quick check: is it positive? If not, enter the wait loop. (let ((count (semaphore-%count semaphore))) - (if (plusp count) - (setf (semaphore-%count semaphore) (1- count)) - (unwind-protect - (progn - ;; Need to use ATOMIC-INCF despite the lock, because on our - ;; way out from here we might not be locked anymore -- so - ;; another thread might be tweaking this in parallel using - ;; ATOMIC-DECF. No danger over overflow, since there it - ;; at most one increment per thread waiting on the semaphore. - (sb!ext:atomic-incf (semaphore-waitcount semaphore)) - (loop until (plusp (setf count (semaphore-%count semaphore))) - do (or (condition-wait (semaphore-queue semaphore) - (semaphore-mutex semaphore) - :timeout timeout) - (return-from wait-on-semaphore nil))) - (setf (semaphore-%count semaphore) (1- count))) - ;; Need to use ATOMIC-DECF instead of DECF, as CONDITION-WAIT - ;; may unwind without the lock being held due to timeouts. - (sb!ext:atomic-decf (semaphore-waitcount semaphore)))))) + (cond ((plusp count) + (setf (semaphore-%count semaphore) (1- count)) + (when notification + (setf (semaphore-notification-%status notification) t))) + (t + (unwind-protect + (progn + ;; Need to use ATOMIC-INCF despite the lock, because on our + ;; way out from here we might not be locked anymore -- so + ;; another thread might be tweaking this in parallel using + ;; ATOMIC-DECF. No danger over overflow, since there it + ;; at most one increment per thread waiting on the semaphore. + (sb!ext:atomic-incf (semaphore-waitcount semaphore)) + (loop until (plusp (setf count (semaphore-%count semaphore))) + do (or (condition-wait (semaphore-queue semaphore) + (semaphore-mutex semaphore) + :timeout timeout) + (return-from wait-on-semaphore nil))) + (setf (semaphore-%count semaphore) (1- count)) + (when notification + (setf (semaphore-notification-%status notification) t))) + ;; Need to use ATOMIC-DECF as we may unwind without the lock + ;; being held! + (sb!ext:atomic-decf (semaphore-waitcount semaphore))))))) t) -(defun try-semaphore (semaphore &optional (n 1)) +(defun try-semaphore (semaphore &optional (n 1) notification) #!+sb-doc "Try to decrement the count of SEMAPHORE by N. If the count were to -become negative, punt and return NIL, otherwise return true." +become negative, punt and return NIL, otherwise return true. + +If NOTIFICATION is given it must be a semaphore notification object +with SEMAPHORE-NOTIFICATION-STATUS of NIL. If the count is decremented, +the status is set to T." (declare (type (integer 1) n)) + (when (and notification (semaphore-notification-status notification)) + (with-simple-restart (continue "Clear notification status and continue.") + (error "~@" + 'try-semaphore semaphore)) + (clear-semaphore-notification notification)) (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) (let ((new-count (- (semaphore-%count semaphore) n))) (when (not (minusp new-count)) - (setf (semaphore-%count semaphore) new-count))))) + (setf (semaphore-%count semaphore) new-count) + (when notification + (setf (semaphore-notification-%status notification) t)) + ;; FIXME: We don't actually document this -- should we just + ;; return T, or document new count as the return? + new-count)))) (defun signal-semaphore (semaphore &optional (n 1)) #!+sb-doc @@ -1018,6 +1196,8 @@ on this semaphore, then N of them is woken up." #!+sb-thread (defun handle-thread-exit (thread) (/show0 "HANDLING THREAD EXIT") + (when *exit-in-process* + (%exit)) ;; Lisp-side cleanup (with-all-threads-lock (setf (thread-%alive-p thread) nil) @@ -1026,6 +1206,47 @@ on this semaphore, then N of them is woken up." (when *session* (%delete-thread-from-session thread *session*)))) +(defun %exit-other-threads () + ;; Grabbing this lock prevents new threads from + ;; being spawned, and guarantees that *ALL-THREADS* + ;; is up to date. + (with-deadline (:seconds nil :override t) + (grab-mutex *make-thread-lock*) + (let ((timeout sb!ext:*exit-timeout*) + (code *exit-in-process*) + (current *current-thread*) + (joinees nil) + (main nil)) + (dolist (thread (list-all-threads)) + (cond ((eq thread current)) + ((main-thread-p thread) + (setf main thread)) + (t + (handler-case + (progn + (terminate-thread thread) + (push thread joinees)) + (interrupt-thread-error ()))))) + (with-progressive-timeout (time-left :seconds timeout) + (dolist (thread joinees) + (join-thread thread :default t :timeout (time-left))) + ;; Need to defer till others have joined, because when main + ;; thread exits, we're gone. Can't use TERMINATE-THREAD -- would + ;; get the exit code wrong. + (when main + (handler-case + (interrupt-thread + main + (lambda () + (setf *exit-in-process* (list code)) + (throw 'sb!impl::%end-of-the-world t))) + (interrupt-thread-error ())) + ;; Normally this never finishes, as once the main-thread unwinds we + ;; exit with the right code, but if times out before that happens, + ;; we will exit after returning -- or rathe racing the main thread + ;; to calling OS-EXIT. + (join-thread main :default t :timeout (time-left))))))) + (defun terminate-session () #!+sb-doc "Kill all threads in session except for this one. Does nothing if current @@ -1128,13 +1349,97 @@ have the foreground next." ;;;; The beef -(defun make-thread (function &key name arguments) +#!+sb-thread +(defun initial-thread-function-trampoline + (thread setup-sem real-function arguments arg1 arg2 arg3) + ;; In time we'll move some of the binding presently done in C here + ;; too. + ;; + ;; KLUDGE: Here we have a magic list of variables that are not + ;; thread-safe for one reason or another. As people report problems + ;; with the thread safety of certain variables, (e.g. "*print-case* in + ;; multiple threads broken", sbcl-devel 2006-07-14), we add a few more + ;; bindings here. The Right Thing is probably some variant of + ;; Allegro's *cl-default-special-bindings*, as that is at least + ;; accessible to users to secure their own libraries. + ;; --njf, 2006-07-15 + ;; + ;; As it is, this lambda must not cons until we are ready to run + ;; GC. Be very careful. + (let* ((*current-thread* thread) + (*restart-clusters* nil) + (*handler-clusters* (sb!kernel::initial-handler-clusters)) + (*exit-in-process* nil) + (sb!impl::*deadline* nil) + (sb!impl::*deadline-seconds* nil) + (sb!impl::*step-out* nil) + ;; internal printer variables + (sb!impl::*previous-case* nil) + (sb!impl::*previous-readtable-case* nil) + (sb!impl::*internal-symbol-output-fun* nil) + (sb!impl::*descriptor-handlers* nil)) ; serve-event + ;; Binding from C + (setf sb!vm:*alloc-signal* *default-alloc-signal*) + (setf (thread-os-thread thread) (current-thread-os-thread)) + (with-mutex ((thread-result-lock thread)) + (with-all-threads-lock + (push thread *all-threads*)) + (with-session-lock (*session*) + (push thread (session-threads *session*))) + (setf (thread-%alive-p thread) t) + (when setup-sem (signal-semaphore setup-sem)) + ;; Using handling-end-of-the-world would be a bit tricky + ;; due to other catches and interrupts, so we essentially + ;; re-implement it here. Once and only once more. + (catch 'sb!impl::toplevel-catcher + (catch 'sb!impl::%end-of-the-world + (catch '%abort-thread + (with-simple-restart + (abort "~@" *current-thread*) + (without-interrupts + (unwind-protect + (with-local-interrupts + (setf *gc-inhibit* nil) ;for foreign callbacks + (sb!unix::unblock-deferrable-signals) + (setf (thread-result thread) + (prog1 + (cons t + (multiple-value-list + (unwind-protect + (catch '%return-from-thread + (if (listp arguments) + (apply real-function arguments) + (funcall real-function arg1 arg2 arg3))) + (when *exit-in-process* + (sb!impl::call-exit-hooks))))) + #!+sb-safepoint + (sb!kernel::gc-safepoint)))) + ;; We're going down, can't handle interrupts + ;; sanely anymore. GC remains enabled. + (block-deferrable-signals) + ;; We don't want to run interrupts in a dead + ;; thread when we leave WITHOUT-INTERRUPTS. + ;; This potentially causes important + ;; interupts to be lost: SIGINT comes to + ;; mind. + (setq *interrupt-pending* nil) + #!+sb-thruption + (setq *thruption-pending* nil) + (handle-thread-exit thread))))))))) + (values)) + +(defun make-thread (function &key name arguments ephemeral) #!+sb-doc "Create a new thread of NAME that runs FUNCTION with the argument -list designator provided (defaults to no argument). When the function -returns the thread exits. The return values of FUNCTION are kept -around and can be retrieved by JOIN-THREAD." - #!-sb-thread (declare (ignore function name arguments)) +list designator provided (defaults to no argument). Thread exits when +the function returns. The return values of FUNCTION are kept around +and can be retrieved by JOIN-THREAD. + +Invoking the initial ABORT restart established by MAKE-THREAD +terminates the thread. + +See also: RETURN-FROM-THREAD, ABORT-THREAD." + #!-sb-thread (declare (ignore function name arguments ephemeral)) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (assert (or (atom arguments) (null (cdr (last arguments)))) @@ -1142,116 +1447,54 @@ around and can be retrieved by JOIN-THREAD." "Argument passed to ~S, ~S, is an improper list." 'make-thread arguments) #!+sb-thread - (let* ((thread (%make-thread :name name)) - (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 () - ;; In time we'll move some of the binding presently done in C - ;; here too. - ;; - ;; KLUDGE: Here we have a magic list of variables that are - ;; not thread-safe for one reason or another. As people - ;; report problems with the thread safety of certain - ;; variables, (e.g. "*print-case* in multiple threads - ;; broken", sbcl-devel 2006-07-14), we add a few more - ;; bindings here. The Right Thing is probably some variant - ;; of Allegro's *cl-default-special-bindings*, as that is at - ;; least accessible to users to secure their own libraries. - ;; --njf, 2006-07-15 - ;; - ;; As it is, this lambda must not cons until we are ready - ;; to run GC. Be very careful. - (let* ((*current-thread* thread) - (*restart-clusters* nil) - (*handler-clusters* (sb!kernel::initial-handler-clusters)) - (*condition-restarts* nil) - (sb!impl::*deadline* nil) - (sb!impl::*deadline-seconds* nil) - (sb!impl::*step-out* nil) - ;; internal printer variables - (sb!impl::*previous-case* nil) - (sb!impl::*previous-readtable-case* nil) - (sb!impl::*internal-symbol-output-fun* nil) - (sb!impl::*descriptor-handlers* nil)) ; serve-event - ;; Binding from C - (setf sb!vm:*alloc-signal* *default-alloc-signal*) - (setf (thread-os-thread thread) (current-thread-os-thread)) - (with-mutex ((thread-result-lock thread)) - (with-all-threads-lock - (push thread *all-threads*)) - (with-session-lock (*session*) - (push thread (session-threads *session*))) - (setf (thread-%alive-p thread) t) - (signal-semaphore setup-sem) - ;; can't use handling-end-of-the-world, because that flushes - ;; output streams, and we don't necessarily have any (or we - ;; could be sharing them) - (catch 'sb!impl::toplevel-catcher - (catch 'sb!impl::%end-of-the-world - (with-simple-restart - (terminate-thread - (format nil - "~~@" - *current-thread*)) - (without-interrupts - (unwind-protect - (with-local-interrupts - ;; Now that most things have a chance - ;; to work properly without messing up - ;; other threads, it's time to enable - ;; signals. - (sb!unix::unblock-deferrable-signals) - (setf (thread-result thread) - (cons t - (multiple-value-list - (apply real-function arguments)))) - ;; Try to block deferrables. An - ;; interrupt may unwind it, but for a - ;; normal exit it prevents interrupt - ;; loss. - (block-deferrable-signals)) - ;; We're going down, can't handle interrupts - ;; sanely anymore. GC remains enabled. - (block-deferrable-signals) - ;; We don't want to run interrupts in a dead - ;; thread when we leave WITHOUT-INTERRUPTS. - ;; This potentially causes important - ;; interupts to be lost: SIGINT comes to - ;; mind. - (setq *interrupt-pending* nil) - (handle-thread-exit thread)))))))) - (values)))) - ;; 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) - (let ((os-thread - (%create-thread - (get-lisp-obj-address initial-function)))) - (when (zerop os-thread) - (error "Can't create a new thread")) - (wait-on-semaphore setup-sem) - thread))))) + (let ((thread (%make-thread :name name :%ephemeral-p ephemeral))) + (let* ((setup-sem (make-semaphore :name "Thread setup semaphore")) + (real-function (coerce function 'function)) + (arguments (if (listp arguments) + arguments + (list arguments))) + #!+win32 + (fp-modes (dpb 0 sb!vm::float-sticky-bits ;; clear accrued bits + (sb!vm:floating-point-modes))) + (initial-function + (named-lambda initial-thread-function () + ;; Win32 doesn't inherit parent thread's FP modes, + ;; while it seems to happen everywhere else + #!+win32 + (setf (sb!vm:floating-point-modes) fp-modes) + ;; 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 - "Suspend current thread until THREAD exits. Return the result values of the -thread function. + "Suspend current thread until THREAD exits. Return the result values +of the thread function. + +If the thread does not exit normally within TIMEOUT seconds return +DEFAULT if given, or else signal JOIN-THREAD-ERROR. -If the thread does not exit normally within TIMEOUT seconds return DEFAULT if -given, or else signal JOIN-THREAD-ERROR. +Trying to join the main thread will cause JOIN-THREAD to block until +TIMEOUT occurs or the process exits: when main thread exits, the +entire process exits. -NOTE: Return convention in case of a timeout is exprimental and subject to -change." +NOTE: Return convention in case of a timeout is experimental and +subject to change." (let ((lock (thread-result-lock thread)) (got-it nil) (problem :timeout)) @@ -1279,12 +1522,18 @@ change." "Deprecated. Same as TERMINATE-THREAD." (terminate-thread thread)) +#!+sb-safepoint +(defun enter-foreign-callback (arg1 arg2 arg3) + (initial-thread-function-trampoline + (make-foreign-thread :name "foreign callback") + nil #'sb!alien::enter-alien-callback t arg1 arg2 arg3)) + (defmacro with-interruptions-lock ((thread) &body body) `(with-system-mutex ((thread-interruptions-lock ,thread)) ,@body)) ;;; Called from the signal handler. -#!-win32 +#!-(or sb-thruption win32) (defun run-interruption () (let ((interruption (with-interruptions-lock (*current-thread*) (pop (thread-interruptions *current-thread*))))) @@ -1297,24 +1546,92 @@ change." (when interruption (funcall interruption)))) +#!+sb-thruption +(defun run-interruption () + (in-interruption () ;the non-thruption code does this in the signal handler + (let ((interruption (with-interruptions-lock (*current-thread*) + (pop (thread-interruptions *current-thread*))))) + (when interruption + (funcall interruption) + ;; I tried implementing this function as an explicit LOOP, because + ;; if we are currently processing the thruption queue, why not do + ;; all of them in one go instead of one-by-one? + ;; + ;; I still think LOOPing would be basically the right thing + ;; here. But suppose some interruption unblocked deferrables. + ;; Will the next one be happy with that? The answer is "no", at + ;; least in the sense that there are tests which check that + ;; deferrables are blocked at the beginning of a thruption, and + ;; races that make those tests fail. Whether the tests are + ;; misguided or not, it seems easier/cleaner to loop implicitly + ;; -- and it's also what AK had implemented in the first place. + ;; + ;; The implicit loop is achieved by returning to C, but having C + ;; call back to us immediately. The runtime will reset the sigmask + ;; in the mean time. + ;; -- DFL + (setf *thruption-pending* t))))) + (defun interrupt-thread (thread function) #!+sb-doc - "Interrupt the live THREAD and make it run FUNCTION. A moderate -degree of care is expected for use of INTERRUPT-THREAD, due to its -nature: if you interrupt a thread that was holding important locks -then do something that turns out to need those locks, you probably -won't like the effect. FUNCTION runs with interrupts disabled, but -WITH-INTERRUPTS is allowed in it. Keep in mind that many things may -enable interrupts (GET-MUTEX when contended, for instance) so the -first thing to do is usually a WITH-INTERRUPTS or a -WITHOUT-INTERRUPTS. Within a thread interrupts are queued, they are -run in same the order they were sent." - #!+win32 + "Interrupt THREAD and make it run FUNCTION. + +The interrupt is asynchronous, and can occur anywhere with the exception of +sections protected using SB-SYS:WITHOUT-INTERRUPTS. + +FUNCTION is called with interrupts disabled, under +SB-SYS:ALLOW-WITH-INTERRUPTS. Since functions such as GRAB-MUTEX may try to +enable interrupts internally, in most cases FUNCTION should either enter +SB-SYS:WITH-INTERRUPTS to allow nested interrupts, or +SB-SYS:WITHOUT-INTERRUPTS to prevent them completely. + +When a thread receives multiple interrupts, they are executed in the order +they were sent -- first in, first out. + +This means that a great degree of care is required to use INTERRUPT-THREAD +safely and sanely in a production environment. The general recommendation is +to limit uses of INTERRUPT-THREAD for interactive debugging, banning it +entirely from production environments -- it is simply exceedingly hard to use +correctly. + +With those caveats in mind, what you need to know when using it: + + * If calling FUNCTION causes a non-local transfer of control (ie. an + unwind), all normal cleanup forms will be executed. + + However, if the interrupt occurs during cleanup forms of an UNWIND-PROTECT, + it is just as if that had happened due to a regular GO, THROW, or + RETURN-FROM: the interrupted cleanup form and those following it in the + same UNWIND-PROTECT do not get executed. + + SBCL tries to keep its own internals asynch-unwind-safe, but this is + frankly an unreasonable expectation for third party libraries, especially + given that asynch-unwind-safety does not compose: a function calling + only asynch-unwind-safe function isn't automatically asynch-unwind-safe. + + This means that in order for an asynch unwind to be safe, the entire + callstack at the point of interruption needs to be asynch-unwind-safe. + + * In addition to asynch-unwind-safety you must consider the issue of + reentrancy. INTERRUPT-THREAD can cause function that are never normally + called recursively to be re-entered during their dynamic contour, + which may cause them to misbehave. (Consider binding of special variables, + values of global variables, etc.) + +Take together, these two restrict the \"safe\" things to do using +INTERRUPT-THREAD to a fairly minimal set. One useful one -- exclusively for +interactive development use is using it to force entry to debugger to inspect +the state of a thread: + + (interrupt-thread thread #'break) + +Short version: be careful out there." + #!+(and (not sb-thread) win32) + #!+(and (not sb-thread) win32) (declare (ignore thread)) - #!+win32 (with-interrupt-bindings (with-interrupts (funcall function))) - #!-win32 + #!-(and (not sb-thread) win32) (let ((os-thread (thread-os-thread thread))) (cond ((not os-thread) (error 'interrupt-thread-error :thread thread)) @@ -1329,14 +1646,49 @@ run in same the order they were sent." (without-interrupts (allow-with-interrupts (funcall function)))))))) - (when (minusp (kill-safely os-thread sb!unix:sigpipe)) + (when (minusp (wake-thread os-thread)) (error 'interrupt-thread-error :thread thread)))))) (defun terminate-thread (thread) #!+sb-doc - "Terminate the thread identified by THREAD, by causing it to run -SB-EXT:QUIT - the usual cleanup forms will be evaluated" - (interrupt-thread thread 'sb!ext:quit)) + "Terminate the thread identified by THREAD, by interrupting it and +causing it to call SB-EXT:ABORT-THREAD with :ALLOW-EXIT T. + +The unwind caused by TERMINATE-THREAD is asynchronous, meaning that +eg. thread executing + + (let (foo) + (unwind-protect + (progn + (setf foo (get-foo)) + (work-on-foo foo)) + (when foo + ;; An interrupt occurring inside the cleanup clause + ;; will cause cleanups from the current UNWIND-PROTECT + ;; to be dropped. + (release-foo foo)))) + +might miss calling RELEASE-FOO despite GET-FOO having returned true if +the interrupt occurs inside the cleanup clause, eg. during execution +of RELEASE-FOO. + +Thus, in order to write an asynch unwind safe UNWIND-PROTECT you need +to use WITHOUT-INTERRUPTS: + + (let (foo) + (sb-sys:without-interrupts + (unwind-protect + (progn + (setf foo (sb-sys:allow-with-interrupts + (get-foo))) + (sb-sys:with-local-interrupts + (work-on-foo foo))) + (when foo + (release-foo foo))))) + +Since most libraries using UNWIND-PROTECT do not do this, you should never +assume that unknown code can safely be terminated using TERMINATE-THREAD." + (interrupt-thread thread (lambda () (abort-thread :allow-exit t)))) (define-alien-routine "thread_yield" int) @@ -1367,37 +1719,19 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" ;; Prevent the thread from dying completely while we look for the TLS ;; area... (with-all-threads-lock - (loop - (if (thread-alive-p thread) - (let* ((epoch sb!kernel::*gc-epoch*) - (offset (sb!kernel:get-lisp-obj-address - (sb!vm::symbol-tls-index symbol))) - (tl-val (sap-ref-word (%thread-sap thread) offset))) - (cond ((zerop offset) - (return (values nil :no-tls-value))) - ((or (eql tl-val sb!vm:no-tls-value-marker-widetag) - (eql tl-val sb!vm:unbound-marker-widetag)) - (return (values nil :unbound-in-thread))) - (t - (multiple-value-bind (obj ok) (make-lisp-obj tl-val nil) - ;; The value we constructed may be invalid if a GC has - ;; occurred. That is harmless, though, since OBJ is - ;; either in a register or on stack, and we are - ;; conservative on both on GENCGC -- so a bogus object - ;; is safe here as long as we don't return it. If we - ;; ever port threads to a non-conservative GC we must - ;; pin the TL-VAL address before constructing OBJ, or - ;; make WITH-ALL-THREADS-LOCK imply WITHOUT-GCING. - ;; - ;; The reason we don't just rely on TL-VAL pinning the - ;; object is that the call to MAKE-LISP-OBJ may cause - ;; bignum allocation, at which point TL-VAL might not - ;; be alive anymore -- hence the epoch check. - (when (eq epoch sb!kernel::*gc-epoch*) - (if ok - (return (values obj :ok)) - (return (values obj :invalid-tls-value)))))))) - (return (values nil :thread-dead)))))) + (if (thread-alive-p thread) + (let* ((offset (sb!kernel:get-lisp-obj-address + (sb!vm::symbol-tls-index symbol))) + (obj (sap-ref-lispobj (%thread-sap thread) offset)) + (tl-val (sb!kernel:get-lisp-obj-address obj))) + (cond ((zerop offset) + (values nil :no-tls-value)) + ((or (eql tl-val sb!vm:no-tls-value-marker-widetag) + (eql tl-val sb!vm:unbound-marker-widetag)) + (values nil :unbound-in-thread)) + (t + (values obj :ok)))) + (values nil :thread-dead)))) (defun %set-symbol-value-in-thread (symbol thread value) (with-pinned-objects (value) @@ -1410,8 +1744,8 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (cond ((zerop offset) (values nil :no-tls-value)) (t - (setf (sap-ref-word (%thread-sap thread) offset) - (get-lisp-obj-address value)) + (setf (sap-ref-lispobj (%thread-sap thread) offset) + value) (values value :ok)))) (values nil :thread-dead)))))