X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=402fe683d03cd139b93ae6f3a2b4139da07e0759;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=7ec33099e50865c9e849a9bf9d35da6cd3a45513;hpb=c6fecd1dcff10bce2e88f67bfade3aab3f7309ac;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 7ec3309..402fe68 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -74,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 @@ -211,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. @@ -242,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 @@ -268,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)) @@ -283,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)) @@ -362,6 +455,8 @@ 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 () @@ -373,18 +468,21 @@ HOLDING-MUTEX-P." (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))) @@ -417,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))))))) @@ -525,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) @@ -925,7 +1022,7 @@ is initially NIL.") (defun semaphore-notification-status (semaphore-notification) #!+sb-doc "Returns T if a WAIT-ON-SEMAPHORE or TRY-SEMAPHORE using -SEMAPHORE-NOTICATION has succeeded since the notification object was created +SEMAPHORE-NOTIFICATION has succeeded since the notification object was created or cleared." (barrier (:read)) (semaphore-notification-%status semaphore-notification)) @@ -1099,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) @@ -1107,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 @@ -1209,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)))) @@ -1223,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. -NOTE: Return convention in case of a timeout is exprimental and subject to -change." +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 experimental and +subject to change." (let ((lock (thread-result-lock thread)) (got-it nil) (problem :timeout)) @@ -1360,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*))))) @@ -1378,6 +1546,32 @@ 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 THREAD and make it run FUNCTION. @@ -1415,16 +1609,16 @@ With those caveats in mind, what you need to know when using it: 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 asych unwind to be safe, the entire + 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 - re-entrancy. INTERRUPT-THREAD can cause function that are never normally + 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 togather, these two restrict the \"safe\" things to do using +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: @@ -1432,12 +1626,12 @@ the state of a thread: (interrupt-thread thread #'break) Short version: be careful out there." - #!+win32 + #!+(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)) @@ -1452,16 +1646,16 @@ Short version: be careful out there." (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 interrupting it and causing -it to call 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 +The unwind caused by TERMINATE-THREAD is asynchronous, meaning that +eg. thread executing (let (foo) (unwind-protect @@ -1474,12 +1668,12 @@ executing ;; 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. +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: +Thus, in order to write an asynch unwind safe UNWIND-PROTECT you need +to use WITHOUT-INTERRUPTS: (let (foo) (sb-sys:without-interrupts @@ -1494,7 +1688,7 @@ WITHOUT-INTERRUPTS: 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 'sb!ext:quit)) + (interrupt-thread thread (lambda () (abort-thread :allow-exit t)))) (define-alien-routine "thread_yield" int) @@ -1525,20 +1719,19 @@ assume that unknown code can safely be terminated using TERMINATE-THREAD." ;; Prevent the thread from dying completely while we look for the TLS ;; area... (with-all-threads-lock - (loop - (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) - (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 - (return (values obj :ok))))) - (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)