threading on Darwin (Mac OS X) and FreeBSD on the x86 is experimental.
@menu
-* Threading basics::
-* Special Variables::
-* Mutex Support::
-* Semaphores::
-* Waitqueue/condition variables::
-* Sessions/Debugging::
-* Foreign threads::
-* Implementation (Linux x86/x86-64)::
+* Threading basics::
+* Special Variables::
+* Mutex Support::
+* Semaphores::
+* Waitqueue/condition variables::
+* Sessions/Debugging::
+* Foreign threads::
+* Implementation (Linux x86/x86-64)::
@end menu
@node Threading basics
(make-thread (lambda () (write-line "Hello, world")))
@end lisp
+@subsection Thread Objects
+
@include struct-sb-thread-thread.texinfo
@include var-sb-thread-star-current-thread-star.texinfo
+@include fun-sb-thread-list-all-threads.texinfo
+@include fun-sb-thread-thread-alive-p.texinfo
+@include fun-sb-thread-thread-name.texinfo
+
+@subsection Making, Joining, and Yielding Threads
+
@include fun-sb-thread-make-thread.texinfo
+@include fun-sb-thread-thread-yield.texinfo
@include fun-sb-thread-join-thread.texinfo
-@include condition-sb-thread-join-thread-error.texinfo
-@include fun-sb-thread-join-thread-error-thread.texinfo
-@include fun-sb-thread-thread-alive-p.texinfo
-@include fun-sb-thread-list-all-threads.texinfo
-@include condition-sb-thread-interrupt-thread-error.texinfo
-@include fun-sb-thread-interrupt-thread-error-thread.texinfo
+
+@subsection Asynchronous Operations
+
@include fun-sb-thread-interrupt-thread.texinfo
@include fun-sb-thread-terminate-thread.texinfo
-@include fun-sb-thread-thread-yield.texinfo
+
+@subsection Miscellaneous Operations
+
+@include fun-sb-thread-symbol-value-in-thread.texinfo
+
+@subsection Error Conditions
+
+@include condition-sb-thread-thread-error.texinfo
+@include fun-sb-thread-thread-error-thread.texinfo
+
+@c @include condition-sb-thread-symbol-value-in-thread-error.texinfo
+@include condition-sb-thread-interrupt-thread-error.texinfo
+@include condition-sb-thread-join-thread-error.texinfo
@node Special Variables
@comment node-name, next, previous, up
(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 "the symbol is unbound in thread.")
+ (:dead "the thread has exited."))))))
+ #!+sb-doc
+ (:documentation
+ "Signalled when SYMBOL-VALUE-IN-THREAD or its SETF version fails due to the
+symbol being unbound in target thread, 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)
(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*)))
(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
+ (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)
+ (values nil :unbound)
+ (values (make-lisp-obj tl-val) :bound)))
+ (values nil :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)
+ (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)))
+ (sap (%thread-sap thread))
+ (tl-val (sap-ref-word sap offset)))
+ (cond ((eql tl-val sb!vm::no-tls-value-marker-widetag)
+ (values nil :unbound))
+ (t
(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))))
+ (get-lisp-obj-address value))
+ (values value :bound))))
+ (values nil :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 form inter-thread communication."
+ (declare (symbol symbol) (thread thread))
+ #!+sb-thread
+ (multiple-value-bind (res status) (%symbol-value-in-thread symbol thread)
+ (if (eq :bound 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))
+ (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 :bound 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))
+ (values nil nil))))
(defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
(sb!vm::locked-symbol-global-value-add symbol-name delta))
(sb-ext:timeout ()
:timeout)))))))
+;;;; SYMBOL-VALUE-IN-THREAD
+
+(with-test (:name symbol-value-in-thread.1)
+ (let ((* (cons t t)))
+ (assert (eq * (symbol-value-in-thread '* *current-thread*)))
+ (setf (symbol-value-in-thread '* *current-thread*) 123)
+ (assert (= 123 (symbol-value-in-thread '* *current-thread*)))
+ (assert (= 123 *))))
+
+#+sb-thread
+(with-test (:name symbol-value-in-thread.2)
+ (let* ((parent *current-thread*)
+ (semaphore (make-semaphore))
+ (child (make-thread (lambda ()
+ (wait-on-semaphore semaphore)
+ (let ((old (symbol-value-in-thread 'this-is-new parent)))
+ (setf (symbol-value-in-thread 'this-is-new parent) :from-child)
+ old)))))
+ (progv '(this-is-new) '(42)
+ (signal-semaphore semaphore)
+ (assert (= 42 (join-thread child)))
+ (assert (eq :from-child (symbol-value 'this-is-new))))))
+
+#+sb-thread
+(with-test (:name symbol-value-in-thread.3)
+ (let* ((parent *current-thread*)
+ (semaphore (make-semaphore))
+ (running t)
+ (noise (make-thread (lambda ()
+ (loop while running
+ do (setf * (make-array 1024)))))))
+
+ (loop repeat 10000
+ do (let* ((mom-mark (cons t t))
+ (kid-mark (cons t t))
+ (child (make-thread (lambda ()
+ (wait-on-semaphore semaphore)
+ (let ((old (symbol-value-in-thread 'this-is-new parent)))
+ (setf (symbol-value-in-thread 'this-is-new parent)
+ (make-array 24 :initial-element kid-mark))
+ old)))))
+ (progv '(this-is-new) (list (make-array 24 :initial-element mom-mark))
+ (signal-semaphore semaphore)
+ (assert (eq mom-mark (aref (join-thread child) 0)))
+ (assert (eq kid-mark (aref (symbol-value 'this-is-new) 0))))))
+ (setf running nil)
+ (join-thread noise)))
+
+#+sb-thread
+(with-test (:name symbol-value-in-thread.4)
+ (let* ((parent *current-thread*)
+ (semaphore (make-semaphore))
+ (child (make-thread (lambda ()
+ (wait-on-semaphore semaphore)
+ (symbol-value-in-thread 'this-is-new parent nil)))))
+ (signal-semaphore semaphore)
+ (assert (equal '(nil nil) (multiple-value-list (join-thread child))))))
+
+#+sb-thread
+(with-test (:name symbol-value-in-thread.5)
+ (let* ((parent *current-thread*)
+ (semaphore (make-semaphore))
+ (child (make-thread (lambda ()
+ (wait-on-semaphore semaphore)
+ (handler-case
+ (symbol-value-in-thread 'this-is-new parent)
+ (symbol-value-in-thread-error (e)
+ (list (thread-error-thread e)
+ (cell-error-name e)
+ (sb-thread::symbol-value-in-thread-error-info e))))))))
+ (signal-semaphore semaphore)
+ (assert (equal (list *current-thread* 'this-is-new (list :read :unbound))
+ (join-thread child)))))
+
+#+sb-thread
+(with-test (:name symbol-value-in-thread.6)
+ (let* ((parent *current-thread*)
+ (semaphore (make-semaphore))
+ (name (gensym))
+ (child (make-thread (lambda ()
+ (wait-on-semaphore semaphore)
+ (handler-case
+ (setf (symbol-value-in-thread name parent) t)
+ (symbol-value-in-thread-error (e)
+ (list (thread-error-thread e)
+ (cell-error-name e)
+ (sb-thread::symbol-value-in-thread-error-info e))))))))
+ (signal-semaphore semaphore)
+ (let ((res (join-thread child))
+ (want (list *current-thread* name (list :write :unbound))))
+ (unless (equal res want)
+ (error "wanted ~S, got ~S" want res)))))
+
+#+sb-thread
+(with-test (:name symbol-value-in-thread.7)
+ (let ((child (make-thread (lambda ()))))
+ (handler-case
+ (symbol-value-in-thread 'this-is-new child)
+ (symbol-value-in-thread-error (e)
+ (assert (eq child (thread-error-thread e)))
+ (assert (eq 'this-is-new (cell-error-name e)))
+ (assert (equal (list :read :dead) (sb-thread::symbol-value-in-thread-error-info e)))))))
+
+#+sb-thread
+(with-test (:name symbol-value-in-thread.8)
+ (let ((child (make-thread (lambda ()))))
+ (handler-case
+ (setf (symbol-value-in-thread 'this-is-new child) t)
+ (symbol-value-in-thread-error (e)
+ (assert (eq child (thread-error-thread e)))
+ (assert (eq 'this-is-new (cell-error-name e)))
+ (assert (equal (list :write :dead) (sb-thread::symbol-value-in-thread-error-info e)))))))
projects / sbcl.git / commitdiff