X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=8723a7f984006de10cefef758d458b26cefed377;hb=344a1f088581303c92da333ddddc9aeb9c212ba9;hp=a0cf2e080e6211063059be6f836bbe2b98a754f8;hpb=85e1967527101d2d8a4c0f5d37857cf731690733;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index a0cf2e0..8723a7f 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -11,6 +11,71 @@ (in-package "SB!THREAD") +;;; Conditions + +(define-condition thread-error (error) + ((thread :reader thread-error-thread :initarg :thread)) + #!+sb-doc + (:documentation + "Conditions of type THREAD-ERROR are signalled when thread operations fail. +The offending thread is initialized by the :THREAD initialization argument and +read by the function THREAD-ERROR-THREAD.")) + +#!+sb-doc +(setf + (fdocumentation 'thread-error-thread 'function) + "Return the offending thread that the THREAD-ERROR pertains to.") + +(define-condition symbol-value-in-thread-error (cell-error thread-error) + ((info :reader symbol-value-in-thread-error-info :initarg :info)) + (:report + (lambda (condition stream) + (destructuring-bind (op problem) + (symbol-value-in-thread-error-info condition) + (format stream "Cannot ~(~A~) value of ~S in ~S: ~S" + op + (cell-error-name condition) + (thread-error-thread condition) + (ecase problem + (:unbound-in-thread "the symbol is unbound in thread.") + (:no-tls-value "the symbol has no thread-local value.") + (:thread-dead "the thread has exited.") + (:invalid-tls-value "the thread-local value is not valid.")))))) + #!+sb-doc + (:documentation + "Signalled when SYMBOL-VALUE-IN-THREAD or its SETF version fails due to eg. +the symbol not having a thread-local value, or the target thread having +exited. The offending symbol can be accessed using CELL-ERROR-NAME, and the +offending thread using THREAD-ERROR-THREAD.")) + +(define-condition join-thread-error (thread-error) () + (:report (lambda (c s) + (format s "Joining thread failed: thread ~A ~ + did not return normally." + (thread-error-thread c)))) + #!+sb-doc + (:documentation + "Signalled when joining a thread fails due to abnormal exit of the thread +to be joined. The offending thread can be accessed using +THREAD-ERROR-THREAD.")) + +(define-deprecated-function :late "1.0.29.17" join-thread-error-thread thread-error-thread + (condition) + (thread-error-thread condition)) + +(define-condition interrupt-thread-error (thread-error) () + (:report (lambda (c s) + (format s "Interrupt thread failed: thread ~A has exited." + (thread-error-thread c)))) + #!+sb-doc + (:documentation + "Signalled when interrupting a thread fails because the thread has already +exited. The offending thread can be accessed using THREAD-ERROR-THREAD.")) + +(define-deprecated-function :late "1.0.29.17" interrupt-thread-error-thread thread-error-thread + (condition) + (thread-error-thread condition)) + ;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is ;;; necessary because threads are only supported with the conservative ;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS) @@ -22,21 +87,11 @@ (setf (fdocumentation '*current-thread* 'variable) "Bound in each thread to the thread itself.") -(defstruct (thread (:constructor %make-thread)) - #!+sb-doc - "Thread type. Do not rely on threads being structs as it may change -in future versions." - name - %alive-p - os-thread - interruptions - (interruptions-lock (make-mutex :name "thread interruptions lock")) - result - (result-lock (make-mutex :name "thread result lock"))) - #!+sb-doc -(setf (fdocumentation 'thread-name 'function) - "The name of the thread. Setfable.") +(setf + (fdocumentation 'thread-name 'function) + "Name of the thread. Can be assigned to using SETF. Thread names can be +arbitrary printable objects, and need not be unique.") (def!method print-object ((thread thread) stream) (print-unreadable-object (thread stream :type t :identity t) @@ -60,7 +115,9 @@ in future versions." (defun thread-alive-p (thread) #!+sb-doc - "Check if THREAD is running." + "Return T if THREAD is still alive. Note that the return value is +potentially stale even before the function returns, as the thread may exit at +any time." (thread-%alive-p thread)) ;; A thread is eligible for gc iff it has finished and there are no @@ -77,7 +134,9 @@ in future versions." (defun list-all-threads () #!+sb-doc - "Return a list of the live threads." + "Return a list of the live threads. Note that the return value is +potentially stale even before the function returns, as new threads may be +created and old ones may exit at any time." (with-all-threads-lock (copy-list *all-threads*))) @@ -87,8 +146,10 @@ in future versions." (declaim (inline current-thread-os-thread)) (defun current-thread-os-thread () - (sap-int - (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) + #!+sb-thread + (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)) + #!-sb-thread + 0) (defun init-initial-thread () (/show0 "Entering INIT-INITIAL-THREAD") @@ -104,6 +165,11 @@ in future versions." ;;;; Aliens, low level stuff +(define-alien-routine "kill_safely" + integer + (os-thread #!-alpha unsigned-long #!+alpha unsigned-int) + (signal int)) + #!+sb-thread (progn ;; FIXME it would be good to define what a thread id is or isn't @@ -113,11 +179,14 @@ in future versions." (define-alien-routine ("create_thread" %create-thread) unsigned-long (lisp-fun-address unsigned-long)) - (define-alien-routine "signal_interrupt_thread" - integer (os-thread unsigned-long)) + (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)) - (define-alien-routine "block_deferrable_signals" - void) + (defun block-deferrable-signals () + (%block-deferrable-signals 0 0)) #!+sb-lutex (progn @@ -216,10 +285,14 @@ in future versions." (if (and (not *interrupts-enabled*) *allow-with-interrupts*) ;; If interrupts are disabled, but we are allowed to ;; enabled them, check for pending interrupts every once - ;; in a while. - (loop - (loop repeat 128 do (cas)) ; 128 is arbitrary here - (sb!unix::%check-interrupts)) + ;; in a while. %CHECK-INTERRUPTS is taking shortcuts, make + ;; sure that deferrables are unblocked by doing an empty + ;; WITH-INTERRUPTS once. + (progn + (with-interrupts) + (loop + (loop repeat 128 do (cas)) ; 128 is arbitrary here + (sb!unix::%check-interrupts))) (loop (cas))))) t)) @@ -236,7 +309,12 @@ in future versions." ;; FIXME: this does not work on SMP Pentium Pro and OOSTORE systems, ;; neither on most non-x86 architectures (but we don't have threads ;; on those). - (setf (spinlock-value spinlock) nil)) + (setf (spinlock-value spinlock) nil) + + ;; FIXME: Is a :memory barrier too strong here? Can we use a :write + ;; barrier instead? + #!+(not (or x86 x86-64)) + (barrier (:memory))) ;;;; Mutexes @@ -267,32 +345,15 @@ HOLDING-MUTEX-P." ;; Make sure to get the current value. (sb!ext:compare-and-swap (mutex-%owner mutex) nil nil)) -(defun get-mutex (mutex &optional (new-owner *current-thread*) (waitp t)) +(defun get-mutex (mutex &optional (new-owner *current-thread*) + (waitp t) (timeout nil)) #!+sb-doc - "Acquire MUTEX for NEW-OWNER, which must be a thread or NIL. If -NEW-OWNER is NIL, it defaults to the current thread. If WAITP is -non-NIL and the mutex is in use, sleep until it is available. - -Note: using GET-MUTEX to assign a MUTEX to another thread then the -current one is not recommended, and liable to be deprecated. - -GET-MUTEX is not interrupt safe. The correct way to call it is: - - (WITHOUT-INTERRUPTS - ... - (ALLOW-WITH-INTERRUPTS (GET-MUTEX ...)) - ...) - -WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the -call while the mutex is in an inconsistent state while -ALLOW-WITH-INTERRUPTS allows the call to be interrupted from sleep. - -It is recommended that you use WITH-MUTEX instead of calling GET-MUTEX -directly." + "Deprecated in favor of GRAB-MUTEX." (declare (type mutex mutex) (optimize (speed 3)) - #!-sb-thread (ignore waitp)) + #!-sb-thread (ignore waitp timeout)) (unless new-owner (setq new-owner *current-thread*)) + (barrier (:read)) (let ((old (mutex-%owner mutex))) (when (eq new-owner old) (error "Recursive lock attempt ~S." mutex)) @@ -313,14 +374,18 @@ directly." ;; but has that been checked?) (2) after the lutex call, but ;; before setting the mutex owner. #!+sb-lutex - (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) - (if waitp - (with-interrupts (%lutex-lock lutex)) - (%lutex-trylock lutex)))) - (setf (mutex-%owner mutex) new-owner) - t) + (progn + (when timeout + (error "Mutex timeouts not supported on this platform.")) + (when (zerop (with-lutex-address (lutex (mutex-lutex mutex)) + (if waitp + (with-interrupts (%lutex-lock lutex)) + (%lutex-trylock lutex)))) + (setf (mutex-%owner mutex) new-owner) + (barrier (:write)) + t)) #!-sb-lutex - ;; This is a direct tranlation of the Mutex 2 algorithm from + ;; This is a direct translation of the Mutex 2 algorithm from ;; "Futexes are Tricky" by Ulrich Drepper. (let ((old (sb!ext:compare-and-swap (mutex-state mutex) +lock-free+ @@ -334,13 +399,20 @@ directly." +lock-taken+ +lock-contested+)))) ;; Wait on the contested lock. - (multiple-value-bind (to-sec to-usec) (decode-timeout nil) - (when (= 1 (with-pinned-objects (mutex) - (futex-wait (mutex-state-address mutex) - (get-lisp-obj-address +lock-contested+) - (or to-sec -1) - (or to-usec 0)))) - (signal-deadline)))) + (loop + (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep) + (decode-timeout timeout) + (declare (ignore stop-sec stop-usec)) + (case (with-pinned-objects (mutex) + (futex-wait (mutex-state-address mutex) + (get-lisp-obj-address +lock-contested+) + (or to-sec -1) + (or to-usec 0))) + ((1) (if deadlinep + (signal-deadline) + (return-from get-mutex nil))) + ((2)) + (otherwise (return)))))) (setf old (sb!ext:compare-and-swap (mutex-state mutex) +lock-free+ +lock-contested+)) @@ -356,7 +428,48 @@ directly." (waitp (bug "Failed to acquire lock with WAITP.")))))) -(defun release-mutex (mutex) +(defun grab-mutex (mutex &key (waitp t) (timeout nil)) + #!+sb-doc + "Acquire MUTEX for the current thread. If WAITP is true (the default) and +the mutex is not immediately available, sleep until it is available. + +If TIMEOUT is given, it specifies a relative timeout, in seconds, on +how long GRAB-MUTEX should try to acquire the lock in the contested +case. Unsupported on :SB-LUTEX platforms (eg. Darwin), where a non-NIL +TIMEOUT signals an error. + +If GRAB-MUTEX returns T, the lock acquisition was successful. In case +of WAITP being NIL, or an expired TIMEOUT, GRAB-MUTEX may also return +NIL which denotes that GRAB-MUTEX did -not- acquire the lock. + +Notes: + + - GRAB-MUTEX is not interrupt safe. The correct way to call it is: + + (WITHOUT-INTERRUPTS + ... + (ALLOW-WITH-INTERRUPTS (GRAB-MUTEX ...)) + ...) + + WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding + the call while the mutex is in an inconsistent state while + ALLOW-WITH-INTERRUPTS allows the call to be interrupted from + sleep. + + - (GRAB-MUTEX :timeout 0.0) differs from + (GRAB-MUTEX :waitp nil) in that the former may signal a + DEADLINE-TIMEOUT if the global deadline was due already on + entering GRAB-MUTEX. + + The exact interplay of GRAB-MUTEX and deadlines are reserved to + change in future versions. + + - It is recommended that you use WITH-MUTEX instead of calling + GRAB-MUTEX directly. +" + (get-mutex mutex nil waitp timeout)) + +(defun release-mutex (mutex &key (if-not-owner :punt)) #!+sb-doc "Release MUTEX by setting it to NIL. Wake up threads waiting for this mutex. @@ -364,37 +477,43 @@ this mutex. RELEASE-MUTEX is not interrupt safe: interrupts should be disabled around calls to it. -Signals a WARNING if current thread is not the current owner of the -mutex." +If the current thread is not the owner of the mutex then it silently +returns without doing anything (if IF-NOT-OWNER is :PUNT), signals a +WARNING (if IF-NOT-OWNER is :WARN), or releases the mutex anyway (if +IF-NOT-OWNER is :FORCE)." (declare (type mutex mutex)) ;; Order matters: set owner to NIL before releasing state. (let* ((self *current-thread*) (old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil))) - (unless (eql self old-owner) - (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner) - (setf (mutex-%owner mutex) nil))) - #!+sb-thread - (progn - #!+sb-lutex - (with-lutex-address (lutex (mutex-lutex mutex)) - (%lutex-unlock lutex)) - #!-sb-lutex - ;; FIXME: once ATOMIC-INCF supports struct slots with word sized - ;; unsigned-byte type this can be used: - ;; - ;; (let ((old (sb!ext:atomic-incf (mutex-state mutex) -1))) - ;; (unless (eql old +lock-free+) - ;; (setf (mutex-state mutex) +lock-free+) - ;; (with-pinned-objects (mutex) - ;; (futex-wake (mutex-state-address mutex) 1)))) - (let ((old (sb!ext:compare-and-swap (mutex-state mutex) - +lock-taken+ +lock-free+))) - (when (eql old +lock-contested+) - (sb!ext:compare-and-swap (mutex-state mutex) - +lock-contested+ +lock-free+) - (with-pinned-objects (mutex) - (futex-wake (mutex-state-address mutex) 1)))) - nil)) + (unless (eql self old-owner) + (ecase if-not-owner + ((:punt) (return-from release-mutex nil)) + ((:warn) + (warn "Releasing ~S, owned by another thread: ~S" mutex old-owner)) + ((:force)))) + #!+sb-thread + (when old-owner + (setf (mutex-%owner mutex) nil) + #!+sb-lutex + (with-lutex-address (lutex (mutex-lutex mutex)) + (%lutex-unlock lutex)) + #!-sb-lutex + ;; FIXME: once ATOMIC-INCF supports struct slots with word sized + ;; unsigned-byte type this can be used: + ;; + ;; (let ((old (sb!ext:atomic-incf (mutex-state mutex) -1))) + ;; (unless (eql old +lock-free+) + ;; (setf (mutex-state mutex) +lock-free+) + ;; (with-pinned-objects (mutex) + ;; (futex-wake (mutex-state-address mutex) 1)))) + (let ((old (sb!ext:compare-and-swap (mutex-state mutex) + +lock-taken+ +lock-free+))) + (when (eql old +lock-contested+) + (sb!ext:compare-and-swap (mutex-state mutex) + +lock-contested+ +lock-free+) + (with-pinned-objects (mutex) + (futex-wake (mutex-state-address mutex) 1)))) + nil))) ;;;; Waitqueues/condition variables @@ -402,11 +521,15 @@ mutex." (defstruct (waitqueue (:constructor %make-waitqueue)) #!+sb-doc "Waitqueue type." - (name nil :type (or null simple-string)) + (name nil :type (or null thread-name)) #!+(and sb-lutex sb-thread) (lutex (make-lutex)) #!-sb-lutex - (data nil)) + (token nil)) + +(def!method print-object ((waitqueue waitqueue) stream) + (print-unreadable-object (waitqueue stream :type t :identity t) + (format stream "~@[~A~]" (waitqueue-name waitqueue)))) (defun make-waitqueue (&key name) #!+sb-doc @@ -418,20 +541,45 @@ mutex." "The name of the waitqueue. Setfable.") #!+(and sb-thread (not sb-lutex)) -(define-structure-slot-addressor waitqueue-data-address +(define-structure-slot-addressor waitqueue-token-address :structure waitqueue - :slot data) + :slot token) (defun condition-wait (queue mutex) #!+sb-doc - "Atomically release MUTEX and enqueue ourselves on QUEUE. Another -thread may subsequently notify us using CONDITION-NOTIFY, at which -time we reacquire MUTEX and return to the caller." + "Atomically release MUTEX and enqueue ourselves on QUEUE. Another thread may +subsequently notify us using CONDITION-NOTIFY, at which time we reacquire +MUTEX and return to the caller. + +Important: CONDITION-WAIT may return without CONDITION-NOTIFY having occurred. +The correct way to write code that uses CONDITION-WAIT is to loop around the +call, checking the the associated data: + + (defvar *data* nil) + (defvar *queue* (make-waitqueue)) + (defvar *lock* (make-mutex)) + + ;; Consumer + (defun pop-data () + (with-mutex (*lock*) + (loop until *data* + do (condition-wait *queue* *lock*)) + (pop *data*))) + + ;; Producer + (defun push-data (data) + (with-mutex (*lock*) + (push data *data*) + (condition-notify *queue*))) + +Also note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of +returning normally, it may do so without holding the mutex." #!-sb-thread (declare (ignore queue)) (assert mutex) #!-sb-thread (error "Not supported in unithread builds.") #!+sb-thread (let ((me *current-thread*)) + (barrier (:read)) (assert (eq me (mutex-%owner mutex))) (/show0 "CONDITION-WAITing") #!+sb-lutex @@ -446,44 +594,63 @@ time we reacquire MUTEX and return to the caller." (with-lutex-address (mutex-lutex-address (mutex-lutex mutex)) (with-local-interrupts (%lutex-wait queue-lutex-address mutex-lutex-address))))) - (setf (mutex-%owner mutex) me))) + (barrier (:write) + (setf (mutex-%owner mutex) me)))) #!-sb-lutex ;; Need to disable interrupts so that we don't miss grabbing the ;; mutex on our way out. (without-interrupts - (unwind-protect - (let ((me *current-thread*)) - ;; This setf becomes visible to other CPUS due to the - ;; usual memory barrier semantics of lock - ;; acquire/release. - (setf (waitqueue-data queue) me) - (release-mutex mutex) - ;; Now we go to sleep using futex-wait. If anyone else - ;; manages to grab MUTEX and call CONDITION-NOTIFY during - ;; this comment, it will change queue->data, and so - ;; futex-wait returns immediately instead of sleeping. - ;; Ergo, no lost wakeup. We may get spurious wakeups, but - ;; that's ok. - (multiple-value-bind (to-sec to-usec) (decode-timeout nil) - (when (= 1 (with-pinned-objects (queue me) - (allow-with-interrupts - (futex-wait (waitqueue-data-address queue) - (get-lisp-obj-address me) - ;; our way if saying "no - ;; timeout": - (or to-sec -1) - (or to-usec 0))))) - (signal-deadline)))) - ;; If we are interrupted while waiting, we should do these - ;; things before returning. Ideally, in the case of an - ;; unhandled signal, we should do them before entering the - ;; debugger, but this is better than nothing. - (get-mutex mutex))))) + ;; This setf becomes visible to other CPUS due to the usual + ;; memory barrier semantics of lock acquire/release. This must + ;; not be moved into the loop else wakeups may be lost upon + ;; continuing after a deadline or EINTR. + (setf (waitqueue-token queue) me) + (loop + (multiple-value-bind (to-sec to-usec) + (allow-with-interrupts (decode-timeout nil)) + (case (unwind-protect + (with-pinned-objects (queue me) + ;; RELEASE-MUTEX is purposefully as close to + ;; FUTEX-WAIT as possible to reduce the size of + ;; the window where the token may be set by a + ;; notifier. + (release-mutex mutex) + ;; Now we go to sleep using futex-wait. If + ;; anyone else manages to grab MUTEX and call + ;; CONDITION-NOTIFY during this comment, it + ;; will change the token, and so futex-wait + ;; returns immediately instead of sleeping. + ;; Ergo, no lost wakeup. We may get spurious + ;; wakeups, but that's ok. + (allow-with-interrupts + (futex-wait (waitqueue-token-address queue) + (get-lisp-obj-address me) + ;; our way of saying "no + ;; timeout": + (or to-sec -1) + (or to-usec 0)))) + ;; If we are interrupted while waiting, we should + ;; do these things before returning. Ideally, in + ;; the case of an unhandled signal, we should do + ;; them before entering the debugger, but this is + ;; better than nothing. + (allow-with-interrupts (get-mutex mutex))) + ;; ETIMEDOUT; we know it was a timeout, yet we cannot + ;; signal a deadline unconditionally here because the + ;; call to GET-MUTEX may already have signaled it. + ((1)) + ;; EINTR; we do not need to return to the caller because + ;; an interleaved wakeup would change the token causing an + ;; EWOULDBLOCK in the next iteration. + ((2)) + ;; EWOULDBLOCK, -1 here, is the possible spurious wakeup + ;; case. 0 is the normal wakeup. + (otherwise (return)))))))) (defun condition-notify (queue &optional (n 1)) #!+sb-doc "Notify N threads waiting on QUEUE. The same mutex that is used in -the correspoinding condition-wait must be held by this thread during +the corresponding CONDITION-WAIT must be held by this thread during this call." #!-sb-thread (declare (ignore queue n)) #!-sb-thread (error "Not supported in unithread builds.") @@ -495,17 +662,19 @@ this call." #!+sb-lutex (with-lutex-address (lutex (waitqueue-lutex queue)) (%lutex-wake lutex n)) - ;; no problem if >1 thread notifies during the comment in - ;; condition-wait: as long as the value in queue-data isn't the - ;; waiting thread's id, it matters not what it is + ;; No problem if >1 thread notifies during the comment in condition-wait: + ;; as long as the value in queue-data isn't the waiting thread's id, it + ;; matters not what it is -- using the queue object itself is handy. + ;; ;; XXX we should do something to ensure that the result of this setf - ;; is visible to all CPUs + ;; is visible to all CPUs. + ;; + ;; ^-- surely futex_wake() involves a memory barrier? #!-sb-lutex - (let ((me *current-thread*)) - (progn - (setf (waitqueue-data queue) me) - (with-pinned-objects (queue) - (futex-wake (waitqueue-data-address queue) n)))))) + (progn + (setf (waitqueue-token queue) queue) + (with-pinned-objects (queue) + (futex-wake (waitqueue-token-address queue) n))))) (defun condition-broadcast (queue) #!+sb-doc @@ -524,9 +693,9 @@ this call." "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT should be considered an implementation detail, and may change in the future." - (name nil :type (or null simple-string)) - (%count 0 :type (integer 0)) - (waitcount 0 :type (integer 0)) + (name nil :type (or null thread-name)) + (%count 0 :type (integer 0)) + (waitcount 0 :type sb!vm:word) (mutex (make-mutex)) (queue (make-waitqueue))) @@ -560,12 +729,29 @@ negative. Else blocks until the semaphore can be decremented." (setf (semaphore-%count semaphore) (1- count)) (unwind-protect (progn - (incf (semaphore-waitcount semaphore)) + ;; 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 (condition-wait (semaphore-queue semaphore) (semaphore-mutex semaphore))) (setf (semaphore-%count semaphore) (1- count))) - (decf (semaphore-waitcount semaphore))))))) + ;; 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))))))) + +(defun try-semaphore (semaphore &optional (n 1)) + #!+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." + (declare (type (integer 1) n)) + (with-mutex ((semaphore-mutex semaphore)) + (let ((new-count (- (semaphore-%count semaphore) n))) + (when (not (minusp new-count)) + (setf (semaphore-%count semaphore) new-count))))) (defun signal-semaphore (semaphore &optional (n 1)) #!+sb-doc @@ -574,7 +760,7 @@ on this semaphore, then N of them is woken up." (declare (type (integer 1) n)) ;; Need to disable interrupts so that we don't lose a wakeup after ;; we have incremented the count. - (with-system-mutex ((semaphore-mutex semaphore)) + (with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t) (let ((waitcount (semaphore-waitcount semaphore)) (count (incf (semaphore-%count semaphore) n))) (when (plusp waitcount) @@ -638,9 +824,6 @@ on this semaphore, then N of them is woken up." #!+sb-thread (defun handle-thread-exit (thread) (/show0 "HANDLING THREAD EXIT") - ;; We're going down, can't handle interrupts sanely anymore. GC - ;; remains enabled. - (block-deferrable-signals) ;; Lisp-side cleanup (with-all-threads-lock (setf (thread-%alive-p thread) nil) @@ -768,7 +951,7 @@ around and can be retrieved by JOIN-THREAD." (setup-sem (make-semaphore :name "Thread setup semaphore")) (real-function (coerce function 'function)) (initial-function - (lambda () + (named-lambda initial-thread-function () ;; In time we'll move some of the binding presently done in C ;; here too. ;; @@ -789,13 +972,11 @@ around and can be retrieved by JOIN-THREAD." (*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) - (empty (vector)) - (sb!impl::*merge-sort-temp-vector* empty) - (sb!impl::*zap-array-data-temp* empty) (sb!impl::*internal-symbol-output-fun* nil) (sb!impl::*descriptor-handlers* nil)) ; serve-event ;; Binding from C @@ -818,123 +999,121 @@ around and can be retrieved by JOIN-THREAD." (format nil "~~@" *current-thread*)) - (unwind-protect - (progn - ;; 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 - (funcall real-function))))) - (handle-thread-exit 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 + (funcall real-function)))) + ;; 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. - (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)))) - -(define-condition join-thread-error (error) - ((thread :reader join-thread-error-thread :initarg :thread)) - #!+sb-doc - (:documentation "Joining thread failed.") - (:report (lambda (c s) - (format s "Joining thread failed: thread ~A ~ - has not returned normally." - (join-thread-error-thread c))))) - -#!+sb-doc -(setf (fdocumentation 'join-thread-error-thread 'function) - "The thread that we failed to join.") + ;; 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))))) (defun join-thread (thread &key (default nil defaultp)) #!+sb-doc "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 "Deprecated. Same as TERMINATE-THREAD." (terminate-thread thread)) -(define-condition interrupt-thread-error (error) - ((thread :reader interrupt-thread-error-thread :initarg :thread)) - #!+sb-doc - (:documentation "Interrupting thread failed.") - (:report (lambda (c s) - (format s "Interrupt thread failed: thread ~A has exited." - (interrupt-thread-error-thread c))))) - -#!+sb-doc -(setf (fdocumentation 'interrupt-thread-error-thread 'function) - "The thread that was not interrupted.") - (defmacro with-interruptions-lock ((thread) &body body) `(with-system-mutex ((thread-interruptions-lock ,thread)) ,@body)) -;;; Called from the signal handler in C. +;;; Called from the signal handler. +#!-win32 (defun run-interruption () - (in-interruption () - (loop - (let ((interruption (with-interruptions-lock (*current-thread*) - (pop (thread-interruptions *current-thread*))))) - ;; Resignalling after popping one works fine, because from the - ;; OS's point of view we have returned from the signal handler - ;; (thanks to arrange_return_to_lisp_function) so at least one - ;; more signal will be delivered. - (when (thread-interruptions *current-thread*) - (signal-interrupt-thread (thread-os-thread *current-thread*))) - (if interruption - (with-interrupts - (funcall interruption)) - (return)))))) - -;;; The order of interrupt execution is peculiar. If thread A -;;; interrupts thread B with I1, I2 and B for some reason receives I1 -;;; when FUN2 is already on the list, then it is FUN2 that gets to run -;;; first. But when FUN2 is run SIG_INTERRUPT_THREAD is enabled again -;;; and I2 hits pretty soon in FUN2 and run FUN1. This is of course -;;; just one scenario, and the order of thread interrupt execution is -;;; undefined. + (let ((interruption (with-interruptions-lock (*current-thread*) + (pop (thread-interruptions *current-thread*))))) + ;; If there is more to do, then resignal and let the normal + ;; interrupt deferral mechanism take care of the rest. From the + ;; OS's point of view the signal we are in the handler for is no + ;; longer pending, so the signal will not be lost. + (when (thread-interruptions *current-thread*) + (kill-safely (thread-os-thread *current-thread*) sb!unix:sigpipe)) + (when interruption + (funcall interruption)))) + (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." - #!-sb-thread (declare (ignore thread)) - #!-sb-thread +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 + (declare (ignore thread)) + #!+win32 (with-interrupt-bindings (with-interrupts (funcall function))) - #!+sb-thread - (if (eq thread *current-thread*) - (with-interrupt-bindings - (with-interrupts (funcall function))) - (let ((os-thread (thread-os-thread thread))) - (cond ((not os-thread) - (error 'interrupt-thread-error :thread thread)) - (t - (with-interruptions-lock (thread) - (push function (thread-interruptions thread))) - (when (minusp (signal-interrupt-thread os-thread)) - (error 'interrupt-thread-error :thread thread))))))) + #!-win32 + (let ((os-thread (thread-os-thread thread))) + (cond ((not os-thread) + (error 'interrupt-thread-error :thread thread)) + (t + (with-interruptions-lock (thread) + ;; Append to the end of the interruptions queue. It's + ;; O(N), but it does not hurt to slow interruptors down a + ;; bit when the queue gets long. + (setf (thread-interruptions thread) + (append (thread-interruptions thread) + (list (lambda () + (without-interrupts + (allow-with-interrupts + (funcall function)))))))) + (when (minusp (kill-safely os-thread sb!unix:sigpipe)) + (error 'interrupt-thread-error :thread thread)))))) (defun terminate-thread (thread) #!+sb-doc @@ -968,43 +1147,129 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" sb!vm::thread-next-slot))))))) (defun %symbol-value-in-thread (symbol thread) - (tagbody - ;; Prevent the dead from dying completely while we look for the - ;; TLS area... - (with-all-threads-lock - (if (thread-alive-p thread) - (let* ((offset (* sb!vm:n-word-bytes - (sb!vm::symbol-tls-index symbol))) - (tl-val (sap-ref-word (%thread-sap thread) offset))) - (if (eql tl-val sb!vm::no-tls-value-marker-widetag) - (go :unbound) - (return-from %symbol-value-in-thread - (values (make-lisp-obj tl-val) t)))) - (return-from %symbol-value-in-thread (values nil nil)))) - :unbound - (error "Cannot read thread-local symbol value: ~S unbound in ~S" - symbol 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* ((epoch sb!kernel::*gc-epoch*) + (offset (* sb!vm:n-word-bytes + (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)))))) (defun %set-symbol-value-in-thread (symbol thread value) - (tagbody - (with-pinned-objects (value) - ;; Prevent the dead from dying completely while we look for - ;; the TLS area... - (with-all-threads-lock - (if (thread-alive-p thread) - (let* ((offset (* sb!vm:n-word-bytes - (sb!vm::symbol-tls-index symbol))) - (sap (%thread-sap thread)) - (tl-val (sap-ref-word sap offset))) - (if (eql tl-val sb!vm::no-tls-value-marker-widetag) - (go :unbound) - (setf (sap-ref-word sap offset) - (get-lisp-obj-address value))) - (return-from %set-symbol-value-in-thread (values value t))) - (return-from %set-symbol-value-in-thread (values nil nil))))) - :unbound - (error "Cannot set thread-local symbol value: ~S unbound in ~S" - symbol thread)))) + (with-pinned-objects (value) + ;; Prevent the thread from dying completely while we look for the TLS + ;; area... + (with-all-threads-lock + (if (thread-alive-p thread) + (let ((offset (* sb!vm:n-word-bytes + (sb!vm::symbol-tls-index symbol)))) + (cond ((zerop offset) + (values nil :no-tls-value)) + (t + (setf (sap-ref-word (%thread-sap thread) offset) + (get-lisp-obj-address value)) + (values value :ok)))) + (values nil :thread-dead))))) + + (define-alien-variable tls-index-start unsigned-int) + + ;; Get values from the TLS. + (defun %thread-local-values (thread) + (without-gcing + (when (thread-alive-p thread) + (let ((sap (%thread-sap thread))) + (loop for index from tls-index-start below + (symbol-value 'sb!vm::*free-tls-index*) + for value = (sap-ref-word sap (* sb!vm:n-word-bytes index)) + for obj = (sb!kernel:make-lisp-obj value nil) + unless (or (typep obj '(or boolean fixnum character)) + (member value + '(#.sb!vm:no-tls-value-marker-widetag + #.sb!vm:unbound-marker-widetag))) + collect obj)))))) + +(defun symbol-value-in-thread (symbol thread &optional (errorp t)) + "Return the local value of SYMBOL in THREAD, and a secondary value of T +on success. + +If the value cannot be retrieved (because the thread has exited or because it +has no local binding for NAME) and ERRORP is true signals an error of type +SYMBOL-VALUE-IN-THREAD-ERROR; if ERRORP is false returns a primary value of +NIL, and a secondary value of NIL. + +Can also be used with SETF to change the thread-local value of SYMBOL. + +SYMBOL-VALUE-IN-THREAD is primarily intended as a debugging tool, and not as a +mechanism for inter-thread communication." + (declare (symbol symbol) (thread thread)) + #!+sb-thread + (multiple-value-bind (res status) (%symbol-value-in-thread symbol thread) + (if (eq :ok status) + (values res t) + (if errorp + (error 'symbol-value-in-thread-error + :name symbol + :thread thread + :info (list :read status)) + (values nil nil)))) + #!-sb-thread + (if (boundp symbol) + (values (symbol-value symbol) t) + (if errorp + (error 'symbol-value-in-thread-error + :name symbol + :thread thread + :info (list :read :unbound-in-thread)) + (values nil nil)))) + +(defun (setf symbol-value-in-thread) (value symbol thread &optional (errorp t)) + (declare (symbol symbol) (thread thread)) + #!+sb-thread + (multiple-value-bind (res status) (%set-symbol-value-in-thread symbol thread value) + (if (eq :ok status) + (values res t) + (if errorp + (error 'symbol-value-in-thread-error + :name symbol + :thread thread + :info (list :write status)) + (values nil nil)))) + #!-sb-thread + (if (boundp symbol) + (values (setf (symbol-value symbol) value) t) + (if errorp + (error 'symbol-value-in-thread-error + :name symbol + :thread thread + :info (list :write :unbound-in-thread)) + (values nil nil)))) (defun sb!vm::locked-symbol-global-value-add (symbol-name delta) (sb!vm::locked-symbol-global-value-add symbol-name delta))