X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-thread.lisp;h=a73ec31051e28554eab99bacc5fab0002c0772e8;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=213021305fb317b519808cd76a0d6060bdda8d89;hpb=4b13aa3a7f0f4c6249e2787f4171e3c362d634c1;p=sbcl.git diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 2130213..a73ec31 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -11,6 +11,87 @@ (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) @@ -35,8 +116,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 +143,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 +162,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*))) @@ -120,8 +207,14 @@ in future versions." (define-alien-routine ("create_thread" %create-thread) unsigned-long (lisp-fun-address unsigned-long)) - (define-alien-routine "block_deferrable_signals" - void) + (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)) + + (defun block-deferrable-signals () + (%block-deferrable-signals 0 0)) #!+sb-lutex (progn @@ -891,19 +984,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 @@ -922,18 +1002,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)) @@ -1019,43 +1087,112 @@ 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)))))) + +(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))