(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."))
+
+(defun join-thread-error-thread (condition)
+ (thread-error-thread condition))
+(define-compiler-macro join-thread-error-thread (condition)
+ (deprecation-warning 'join-thread-error-thread 'thread-error-thread)
+ `(thread-error-thread ,condition))
+
+#!+sb-doc
+(setf
+ (fdocumentation 'join-thread-error-thread 'function)
+ "The thread that we failed to join. Deprecated, use THREAD-ERROR-THREAD
+instead.")
+
+(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."))
+
+(defun interrupt-thread-error-thread (condition)
+ (thread-error-thread condition))
+(define-compiler-macro interrupt-thread-error-thread (condition)
+ (deprecation-warning 'join-thread-error-thread 'thread-error-thread)
+ `(thread-error-thread ,condition))
+
+#!+sb-doc
+(setf
+ (fdocumentation 'interrupt-thread-error-thread 'function)
+ "The thread that was not interrupted. Deprecated, use THREAD-ERROR-THREAD
+instead.")
+
;;; 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)
(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)
(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
(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*)))
;; 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)
+ #!+sb-lutex (ignore timeout))
(unless new-owner
(setq new-owner *current-thread*))
(let ((old (mutex-%owner mutex)))
+lock-contested+))))
;; Wait on the contested lock.
(loop
- (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
+ (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) (signal-deadline))
+ ((1) (if deadlinep
+ (signal-deadline)
+ (return-from get-mutex nil)))
((2))
(otherwise (return))))))
(setf old (sb!ext:compare-and-swap (mutex-state mutex)
(waitp
(bug "Failed to acquire lock with WAITP."))))))
+(defun grab-mutex (mutex &key (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.
+
+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.
+
+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:
+
+ - Using the NEW-OWNER parameter to assign a MUTEX to another thread
+ than the current one is not recommended, and liable to be
+ deprecated.
+
+ - 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.
+
+ - The TIMEOUT parameter is currently only supported on non-SB-LUTEX
+ platforms like Linux or BSD.
+
+ - (GRAB-MUTEX <mutex> :timeout 0.0) differs from
+ (GRAB-MUTEX <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 new-owner 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
(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
#!+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."
+time we reacquire MUTEX and return to the caller.
+
+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.")
;; continuing after a deadline or EINTR.
(setf (waitqueue-data queue) me)
(loop
- (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
+ (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
(allow-with-interrupts
(futex-wait (waitqueue-data-address queue)
(get-lisp-obj-address me)
- ;; our way if saying "no
+ ;; our way of saying "no
;; timeout":
(or to-sec -1)
(or to-usec 0))))
;; them before entering the debugger, but this is
;; better than nothing.
(allow-with-interrupts (get-mutex mutex)))
- ;; ETIMEDOUT
- ((1) (signal-deadline))
+ ;; 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
((2))
;; EWOULDBLOCK, -1 here, is the possible spurious wakeup
"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)))
(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
(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)
(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.
;;
(*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
(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.")
-
(defun join-thread (thread &key (default nil defaultp))
#!+sb-doc
"Suspend current thread until THREAD exits. Returns the result
"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))
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))))))
+
+(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))
projects / sbcl.git / blobdiff