+(progn
+ (defun %thread-sap (thread)
+ (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))
+ (target (thread-os-thread thread)))
+ (loop
+ (when (sap= thread-sap (int-sap 0)) (return nil))
+ (let ((os-thread (sap-ref-word thread-sap
+ (* sb!vm:n-word-bytes
+ sb!vm::thread-os-thread-slot))))
+ (when (= os-thread target) (return thread-sap))
+ (setf thread-sap
+ (sap-ref-sap thread-sap (* sb!vm:n-word-bytes
+ sb!vm::thread-next-slot)))))))
+
+ (defun %symbol-value-in-thread (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)
+ (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)))))
+
+ (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
+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))))