X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=3399502284388899bafaf698c7123149d13db72a;hb=82f9c527cb607ccd19e5b24261dfe9af7b1ba72e;hp=ed8f2567b30a08216fe4bee6b42ff52b4b54bd4b;hpb=344a1f088581303c92da333ddddc9aeb9c212ba9;p=sbcl.git

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index ed8f256..3399502 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -886,7 +886,7 @@ indirect containers: FDEFINITIONs, EQL specializers, classes, and
 thread-local symbol values in other threads fall into this category.
 
 NOTE: calling MAP-ROOT with a THREAD does not currently map over
-conservative roots from the thread stack & interrupt contexts.
+conservative roots from the thread registers and interrupt contexts.
 
 Experimental: interface subject to change."
   (let ((fun (coerce function 'function))
@@ -927,9 +927,29 @@ Experimental: interface subject to change."
                                0)))
            (dotimes (i (- len nuntagged))
              (call (sb-kernel:%instance-ref object i))))
+         #+sb-thread
          (when (typep object 'sb-thread:thread)
-           (dolist (value (sb-thread::%thread-local-values object))
-             (call value))))
+           (cond ((eq object sb-thread:*current-thread*)
+                  (dolist (value (sb-thread::%thread-local-references))
+                    (call value))
+                  (sb-vm::map-stack-references #'call))
+                 (t
+                  ;; KLUDGE: INTERRUPT-THREAD is Not Nice (tm), but
+                  ;; the alternative would be stopping the world...
+                  #+sb-thread
+                  (let ((sem (sb-thread:make-semaphore))
+                        (refs nil))
+                    (handler-case
+                        (progn
+                          (sb-thread:interrupt-thread
+                           object
+                           (lambda ()
+                             (setf refs (sb-thread::%thread-local-references))
+                             (sb-vm::map-stack-references (lambda (x) (push x refs)))
+                             (sb-thread:signal-semaphore sem)))
+                          (sb-thread:wait-on-semaphore sem))
+                      (sb-thread:interrupt-thread-error ()))
+                    (mapc #'call refs))))))
         (array
          (if (simple-vector-p object)
              (dotimes (i (length object))