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

 * Thread local values: filter out invalid values correctly (oops),
   also change SB-THREAD::%THREAD-LOCAL-REFERENCES to work on current
   thread only.

 * References from stack: SB-VM::MAP-STACK-REFERENCES walks the
   current thread stack looking for things that look like references
   to heap objects.

 * MAP-ROOT interrupts the thread it wants to check out, unless it is
   the current one -- a bit tacky, but seems preferable to stopping
   the world.

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index ed8f256..95504de 100644 (file)
--- 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))
@@ -928,8 +928,27 @@ Experimental: interface subject to change."
            (dotimes (i (- len nuntagged))
              (call (sb-kernel:%instance-ref object i))))
          (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))

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 328ca45..4e12042 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -784,6 +784,26 @@
        space)
       res)))
 
+;;; Calls FUNCTION with all object that have (possibly conservative)
+;;; references to them on current stack.
+(defun map-stack-references (function)
+  (let ((end
+         (sb!di::descriptor-sap
+          #!+stack-grows-downward-not-upward *control-stack-end*
+          #!-stack-grows-downward-not-upward *control-stack-start*))
+        (sp (current-sp))
+        (seen nil))
+    (loop until #!+stack-grows-downward-not-upward (sap> sp end)
+                #!-stack-grows-downward-not-upward (sap< sp end)
+          do (multiple-value-bind (obj ok) (make-lisp-obj (sap-ref-word sp 0) nil)
+               (when (and ok (typep obj '(not (or fixnum character))))
+                 (unless (member obj seen :test #'eq)
+                   (funcall function obj)
+                   (push obj seen))))
+             (setf sp
+                   #!+stack-grows-downward-not-upward (sap+ sp n-word-bytes)
+                   #!-stack-grows-downward-not-upward (sap- sp n-word-bytes)))))
+
 (defun map-referencing-objects (fun space object)
   (declare (type spaces space) (inline map-allocated-objects))
   (unless *ignore-after*

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 8723a7f..bc478fa 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -1200,20 +1200,22 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
 
   (define-alien-variable tls-index-start unsigned-int)
 
-  ;; Get values from the TLS.
-  (defun %thread-local-values (thread)
+  ;; Get values from the TLS area of the current thread.
+  (defun %thread-local-references ()
     (without-gcing
-      (when (thread-alive-p thread)
-        (let ((sap (%thread-sap 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 = (sb!kernel:make-lisp-obj value nil)
-                unless (or (typep obj '(or boolean fixnum character))
-                           (member value
-                                   '(#.sb!vm:no-tls-value-marker-widetag
-                                     #.sb!vm:unbound-marker-widetag)))
-                collect obj))))))
+      (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

diff --git a/version.lisp-expr b/version.lisp-expr
index d894814..9ff5d33 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.46.41"
+"1.0.46.42"