1.0.46.42: more on threads in SB-INTROSPECT:MAP-ROOT

[sbcl.git] / src / code / target-thread.lisp

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 111f92b..bc478fa 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -527,6 +527,10 @@ IF-NOT-OWNER is :FORCE)."
   #!-sb-lutex
   (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
   "Create a waitqueue."
@@ -1192,7 +1196,26 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
                      (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