The offending thread is initialized by the :THREAD initialization argument and
read by the function THREAD-ERROR-THREAD."))
+(define-condition thread-deadlock (thread-error)
+ ((cycle :initarg :cycle :reader thread-deadlock-cycle))
+ (:report
+ (lambda (condition stream)
+ (let ((*print-circle* t))
+ (format stream "Deadlock cycle detected:~%~@< ~@;~
+ ~{~:@_~S~:@_~}~:@>"
+ (mapcar #'car (thread-deadlock-cycle condition)))))))
+
#!+sb-doc
(setf
(fdocumentation 'thread-error-thread 'function)
to be joined. The offending thread can be accessed using
THREAD-ERROR-THREAD."))
-(defun join-thread-error-thread (condition)
+(define-deprecated-function :late "1.0.29.17" join-thread-error-thread 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)
"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)
+(define-deprecated-function :late "1.0.29.17" interrupt-thread-error-thread 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
(multiple-value-list
(join-thread thread :default cookie))))
(state (if (eq :running info)
- info
+ (let* ((lock (thread-waiting-for thread)))
+ (typecase lock
+ (cons
+ (list "waiting for:" (cdr lock)
+ "timeout: " (car lock)))
+ (null
+ (list info))
+ (t
+ (list "waiting for:" lock))))
(if (eq cookie (car info))
- :aborted
+ (list :aborted)
:finished)))
- (values (when (eq :finished state) info)))
+ (values (when (eq :finished state)
+ info))
+ (*print-level* 4))
(format stream
- "~@[~S ~]~:[~A~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
+ "~@[~S ~]~:[~{~I~A~^~2I~_ ~}~_~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
(thread-name thread)
(eq :finished state)
state
values))))
+(defun print-lock (lock name owner stream)
+ (let ((*print-circle* t))
+ (print-unreadable-object (lock stream :type t :identity (not name))
+ (if owner
+ (format stream "~@[~S ~]~2I~_owner: ~S" name owner)
+ (format stream "~@[~S ~](free)" name)))))
+
+(def!method print-object ((mutex mutex) stream)
+ (print-lock mutex (mutex-name mutex) (mutex-owner mutex) stream))
+
+(def!method print-object ((spinlock spinlock) stream)
+ (print-lock spinlock (spinlock-name spinlock) (spinlock-value spinlock) stream))
+
(defun thread-alive-p (thread)
#!+sb-doc
"Return T if THREAD is still alive. Note that the return value is
;;;; Spinlocks
+(defmacro with-deadlocks ((thread lock timeout) &body forms)
+ (with-unique-names (prev n-thread n-lock n-timeout new)
+ `(let* ((,n-thread ,thread)
+ (,n-lock ,lock)
+ (,n-timeout (or ,timeout
+ (when sb!impl::*deadline*
+ sb!impl::*deadline-seconds*)))
+ ;; If we get interrupted while waiting for a lock, etc.
+ (,prev (thread-waiting-for ,n-thread))
+ (,new (if ,n-timeout
+ (cons ,n-timeout ,n-lock)
+ ,n-lock)))
+ (declare (dynamic-extent ,new))
+ ;; No WITHOUT-INTERRUPTS, since WITH-DEADLOCKS is used
+ ;; in places where interrupts should already be disabled.
+ (unwind-protect
+ (progn
+ (setf (thread-waiting-for ,n-thread) ,new)
+ ,@forms)
+ (setf (thread-waiting-for ,n-thread) ,prev)))))
+
(declaim (inline get-spinlock release-spinlock))
;;; Should always be called with interrupts disabled.
(when (eq old new)
(error "Recursive lock attempt on ~S." spinlock))
#!+sb-thread
- (flet ((cas ()
- (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
- (thread-yield)
- (return-from get-spinlock t))))
- (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. %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))
+ (with-deadlocks (new spinlock nil)
+ (flet ((cas ()
+ (if (sb!ext:compare-and-swap (spinlock-value spinlock) nil new)
+ (thread-yield)
+ (return-from get-spinlock t))))
+ ;; Try once.
+ (cas)
+ ;; Check deadlocks
+ (with-interrupts (check-deadlock))
+ (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. %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)
(defun release-spinlock (spinlock)
(declare (optimize (speed 3) (safety 0)))
;; 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)))
\f
;;;; Mutexes
;; 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))
+;;; Signals an error if owner of LOCK is waiting on a lock whose release
+;;; depends on the current thread. Does not detect deadlocks from sempahores.
+(defun check-deadlock ()
+ (let* ((self *current-thread*)
+ (origin (thread-waiting-for self)))
+ (labels ((lock-owner (lock)
+ (etypecase lock
+ (mutex (mutex-%owner lock))
+ (spinlock (spinlock-value lock))))
+ (detect-deadlock (lock)
+ (let ((other-thread (lock-owner lock)))
+ (cond ((not other-thread))
+ ((eq self other-thread)
+ (let* ((chain (deadlock-chain self origin))
+ (barf
+ (format nil
+ "~%WARNING: DEADLOCK CYCLE DETECTED:~%~@< ~@;~
+ ~{~:@_~S~:@_~}~:@>~
+ ~%END OF CYCLE~%"
+ (mapcar #'car chain))))
+ ;; Barf to stderr in case the system is too tied up
+ ;; to report the error properly -- to avoid cross-talk
+ ;; build the whole string up first.
+ (write-string barf sb!sys:*stderr*)
+ (finish-output sb!sys:*stderr*)
+ (error 'thread-deadlock
+ :thread *current-thread*
+ :cycle chain)))
+ (t
+ (let ((other-lock (thread-waiting-for other-thread)))
+ ;; If the thread is waiting with a timeout OTHER-LOCK
+ ;; is a cons, and we don't consider it a deadlock -- since
+ ;; it will time out on its own sooner or later.
+ (when (and other-lock (not (consp other-lock)))
+ (detect-deadlock other-lock)))))))
+ (deadlock-chain (thread lock)
+ (let* ((other-thread (lock-owner lock))
+ (other-lock (thread-waiting-for other-thread)))
+ (cond ((not other-thread)
+ ;; The deadlock is gone -- maybe someone timed out?
+ (return-from check-deadlock nil))
+ ((consp other-lock)
+ ;; There's a timeout -- no deadlock.
+ (return-from check-deadlock nil))
+ ((eq self other-thread)
+ ;; Done
+ (list (list thread lock)))
+ (t
+ (if other-lock
+ (cons (list thread lock)
+ (deadlock-chain other-thread other-lock))
+ ;; Again, the deadlock is gone?
+ (return-from check-deadlock nil)))))))
+ ;; Timeout means there is no deadlock
+ (unless (consp origin)
+ (detect-deadlock origin)
+ t))))
+
+(defun get-mutex (mutex &optional new-owner
+ (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))
#!-sb-thread
(setf (mutex-%owner mutex) new-owner)
#!+sb-thread
- (progn
+ (with-deadlocks (new-owner mutex timeout)
;; FIXME: Lutexes do not currently support deadlines, as at least
;; on Darwin pthread_foo_timedbar functions are not supported:
;; this means that we probably need to use the Carbon multiprocessing
;; 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
+ (let ((once (%lutex-trylock lutex)))
+ (cond ((zerop once)
+ ;; No need to wait.
+ once)
+ (t
+ (with-interrupts
+ ;; Check for deadlocks before waiting
+ (check-deadlock)
+ (%lutex-lock lutex)))))
+ (%lutex-trylock lutex))))
+ ;; FIXME: If %LUTEX-LOCK unwinds due to a signal, we may actually
+ ;; be holding the lock already -- and but neglect to mark ourselves
+ ;; as the owner here. This is bad.
+ (setf (mutex-%owner mutex) new-owner)
+ (barrier (:write))
+ t))
#!-sb-lutex
;; This is a direct translation of the Mutex 2 algorithm from
;; "Futexes are Tricky" by Ulrich Drepper.
+lock-taken+
+lock-contested+))))
;; Wait on the contested lock.
- (loop
- (multiple-value-bind (to-sec to-usec) (decode-timeout nil)
- (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))
- ((2))
- (otherwise (return))))))
+ (with-interrupts
+ (check-deadlock)
+ (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+))
(waitp
(bug "Failed to acquire lock with WAITP."))))))
+(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 <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 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
(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
"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.
-
-Note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of
+ "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
(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
- (let ((me nil))
- ;; 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-data 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 WAITQUEUE-DATA 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 queue->data, 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-data-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
- ((2))
- ;; EWOULDBLOCK, -1 here, is the possible spurious wakeup
- ;; case. 0 is the normal wakeup.
- (otherwise (return)))))))))
+ ;; 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
#!+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
"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))
+ (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 (sap-ref-word (%thread-sap thread) offset)
(get-lisp-obj-address value))
(values value :ok))))
- (values nil :thread-dead))))))
+ (values nil :thread-dead)))))
+
+ (define-alien-variable tls-index-start unsigned-int)
+
+ ;; Get values from the TLS area of the current thread.
+ (defun %thread-local-references ()
+ (without-gcing
+ (let ((sap (%thread-sap *current-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 ok) = (multiple-value-list (sb!kernel:make-lisp-obj value nil))
+ unless (or (not ok)
+ (typep obj '(or fixnum character))
+ (member value
+ '(#.sb!vm:no-tls-value-marker-widetag
+ #.sb!vm:unbound-marker-widetag))
+ (member obj seen :test #'eq))
+ collect obj into seen
+ finally (return seen))))))
(defun symbol-value-in-thread (symbol thread &optional (errorp t))
"Return the local value of SYMBOL in THREAD, and a secondary value of T
projects / sbcl.git / blobdiff