From a08efdfc11a98f4c7531cf67e0d4fdf5f274681f Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 18 Jun 2009 12:41:13 +0000 Subject: [PATCH] 1.0.29.17: SYMBOL-VALUE-IN-THREAD * Build on top of %SYMBOL-VALUE-IN-THREAD, document and export from SB-THREAD. Write a bunch of test-cases. * New condition: SB-THREAD:THREAD-ERROR. Inherit from it in JOIN-THREAD-ERROR and INTERRUPT-THREAD-ERROR, and deprecate JOIN-THREAD-ERROR-THREAD and INTERRUPT-THREAD-ERROR-THREAD in favor of THREAD-ERROR-THREAD. * General threading related documentation touchups. --- NEWS | 5 + doc/manual/threading.texinfo | 48 ++++++--- package-data-list.lisp-expr | 43 ++++++-- src/code/target-thread.lisp | 234 ++++++++++++++++++++++++++++++------------ tests/threads.pure.lisp | 112 ++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 355 insertions(+), 89 deletions(-) diff --git a/NEWS b/NEWS index 626b6d7..aec4085 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- + * minor incompatible change: SB-THREAD:JOIN-THREAD-ERROR-THREAD and + SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD have been deprecated in favor + of SB-THREAD:THREAD-ERROR-THREAD. + * new feature: SB-THREAD:SYMBOL-VALUE-IN-THREAD provides access to symbol + values in other threads. * new feature: SB-INTROSPECT:ALLOCATION-INFORMATION provides information about object allocation. * optimization: more efficient type-checks for FIXNUMs when the value diff --git a/doc/manual/threading.texinfo b/doc/manual/threading.texinfo index d1185e7..b681669 100644 --- a/doc/manual/threading.texinfo +++ b/doc/manual/threading.texinfo @@ -14,14 +14,14 @@ x86 or x86-64 architecture, or SunOS (Solaris) on the x86. Support for 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 @@ -32,19 +32,37 @@ threading on Darwin (Mac OS X) and FreeBSD on the x86 is experimental. (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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 44e6e46..2d839e2 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -905,7 +905,6 @@ possibly temporariliy, because it might be used internally." "STANDARD-READTABLE-MODIFIED-ERROR" "ARRAY-BOUNDING-INDICES-BAD-ERROR" "SEQUENCE-BOUNDING-INDICES-BAD-ERROR" - "SPECIAL-FORM-FUNCTION" "STYLE-WARN" "SIMPLE-COMPILER-NOTE" @@ -1859,20 +1858,44 @@ is a good idea, but see SB-SYS re. blurring of boundaries." :name "SB!THREAD" :use ("CL" "SB!ALIEN" "SB!INT" "SB!SYS" "SB!KERNEL") :doc "public (but low-level): native thread support" - :export ("*CURRENT-THREAD*" "THREAD" "MAKE-THREAD" - "THREAD-NAME" "THREAD-ALIVE-P" - "LIST-ALL-THREADS" - "JOIN-THREAD" "JOIN-THREAD-ERROR" "JOIN-THREAD-ERROR-THREAD" + :export ("*CURRENT-THREAD*" + "DESTROY-THREAD" + "INTERRUPT-THREAD" "INTERRUPT-THREAD-ERROR" "INTERRUPT-THREAD-ERROR-THREAD" - "INTERRUPT-THREAD" "TERMINATE-THREAD" "DESTROY-THREAD" + "JOIN-THREAD" + "JOIN-THREAD-ERROR" + "JOIN-THREAD-ERROR-THREAD" + "LIST-ALL-THREADS" + "MAKE-THREAD" + "SYMBOL-VALUE-IN-THREAD" + "SYMBOL-VALUE-IN-THREAD-ERROR" + "TERMINATE-THREAD" + "THREAD" + "THREAD-ERROR" + "THREAD-ERROR-THREAD" + "THREAD-ALIVE-P" + "THREAD-NAME" "THREAD-YIELD" - "MUTEX" "MAKE-MUTEX" "MUTEX-NAME" "MUTEX-OWNER" "MUTEX-VALUE" + ;; Mutexes + "GET-MUTEX" "HOLDING-MUTEX-P" - "GET-MUTEX" "RELEASE-MUTEX" "WITH-MUTEX" + "MAKE-MUTEX" + "MUTEX" + "MUTEX-NAME" + "MUTEX-OWNER" + "MUTEX-VALUE" + "RELEASE-MUTEX" + "WITH-MUTEX" "WITH-RECURSIVE-LOCK" - "WAITQUEUE" "MAKE-WAITQUEUE" "WAITQUEUE-NAME" - "CONDITION-WAIT" "CONDITION-NOTIFY" "CONDITION-BROADCAST" + ;; Condition variables + "CONDITION-BROADCAST" + "CONDITION-NOTIFY" + "CONDITION-WAIT" + "MAKE-WAITQUEUE" + "WAITQUEUE" + "WAITQUEUE-NAME" + ;; Sessions "MAKE-LISTENER-THREAD" "RELEASE-FOREGROUND" "WITH-NEW-SESSION" diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 2021cfb..7cf305d 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -11,6 +11,85 @@ (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) @@ -35,8 +114,10 @@ in future versions." (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 +141,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 +160,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*))) @@ -897,19 +982,6 @@ around and can be retrieved by JOIN-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.") - (defun join-thread (thread &key (default nil defaultp)) #!+sb-doc "Suspend current thread until THREAD exits. Returns the result @@ -928,18 +1000,6 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR." "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)) @@ -1025,43 +1085,91 @@ 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 + (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)) diff --git a/tests/threads.pure.lisp b/tests/threads.pure.lisp index cb1a827..b8ca206 100644 --- a/tests/threads.pure.lisp +++ b/tests/threads.pure.lisp @@ -157,3 +157,115 @@ (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))))))) diff --git a/version.lisp-expr b/version.lisp-expr index 6b57f10..28fe2ab 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.29.16" +"1.0.29.17" -- 1.7.10.4