X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=3399502284388899bafaf698c7123149d13db72a;hb=6d36f2d6954cb79e3c88fef33fe0c3ad63deaea8;hp=9ebd67797e55eda65e7029fe32f7629cb77d93e8;hpb=b5f1bfd5090893a125ba7520fc2f30ad663b3af9;p=sbcl.git

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index 9ebd677..3399502 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -871,37 +871,43 @@ Experimental: interface subject to change."
                      (values :stack sb-thread::*current-thread*))))
                :foreign)))))
 
-(defun map-root (function object &key simple ext)
-  "Call FUNCTION with all non-immediate objects pointed to by OBJECT. Returns
-OBJECT.
+(defun map-root (function object &key simple (ext t))
+  "Call FUNCTION with all non-immediate objects pointed to by OBJECT.
+Returns OBJECT.
 
-If SIMPLE is true, elides those pointers that are not notionally part of
-certain built-in objects, but backpointers to a conceptual parent: eg. elides
-the pointer from a SYMBOL to the corresponding PACKAGE.
+If SIMPLE is true (default is NIL), elides those pointers that are not
+notionally part of certain built-in objects, but backpointers to a
+conceptual parent: eg. elides the pointer from a SYMBOL to the
+corresponding PACKAGE.
 
-If EXT is true, includes some pointers that are not actually contained in the
-object, but in well-known indirect containers. For example, symbols in SBCL do
-not directly point to their SYMBOL-FUNCTION or class by the same name, but
-when :EXT T is used MAP-ROOT will also walk the function and class (if any)
-associated with the symbol.
+If EXT is true (default is T), includes some pointers that are not
+actually contained in the object, but found in certain well-known
+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, nor over thread-local symbol
-bindings.
+NOTE: calling MAP-ROOT with a THREAD does not currently map over
+conservative roots from the thread registers and interrupt contexts.
 
 Experimental: interface subject to change."
-  (let ((fun (coerce function 'function)))
+  (let ((fun (coerce function 'function))
+        (seen (sb-int:alloc-xset)))
     (flet ((call (part)
-             (when (member (sb-kernel:lowtag-of part)
-                           `(,sb-vm:instance-pointer-lowtag
-                             ,sb-vm:list-pointer-lowtag
-                             ,sb-vm:fun-pointer-lowtag
-                             ,sb-vm:other-pointer-lowtag))
+             (when (and (member (sb-kernel:lowtag-of part)
+                                `(,sb-vm:instance-pointer-lowtag
+                                  ,sb-vm:list-pointer-lowtag
+                                  ,sb-vm:fun-pointer-lowtag
+                                  ,sb-vm:other-pointer-lowtag))
+                        (not (sb-int:xset-member-p part seen)))
+               (sb-int:add-to-xset part seen)
                (funcall fun part))))
+      (when ext
+        (let ((table sb-pcl::*eql-specializer-table*))
+          (call (sb-ext:with-locked-hash-table (table)
+                  (gethash object table)))))
       (etypecase object
         ((or bignum float sb-sys:system-area-pointer fixnum))
-        (weak-pointer
-         (call (weak-pointer-value object)))
+        (sb-ext:weak-pointer
+         (call (sb-ext:weak-pointer-value object)))
         (cons
          (call (car object))
          (call (cdr object))
@@ -920,7 +926,30 @@ Experimental: interface subject to change."
                                 (sb-kernel:%instance-layout object))
                                0)))
            (dotimes (i (- len nuntagged))
-             (call (sb-kernel:%instance-ref object i)))))
+             (call (sb-kernel:%instance-ref object i))))
+         #+sb-thread
+         (when (typep object 'sb-thread:thread)
+           (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))
@@ -957,14 +986,16 @@ Experimental: interface subject to change."
                                      sb-vm::funcallable-instance-info-offset)
                do (call (sb-kernel:%funcallable-instance-info object i))))
         (symbol
-         (when (boundp object)
-           (let ((global (ignore-errors (symbol-global-value object)))
-                 (local (symbol-value object)))
-             (call global)
-             (unless (eq local global)
-               (call local))))
+         (when ext
+           (dolist (thread (sb-thread:list-all-threads))
+             (call (sb-thread:symbol-value-in-thread object thread nil))))
+         (handler-case
+             ;; We don't have GLOBAL-BOUNDP, and there's no ERRORP arg.
+             (call (sb-ext:symbol-global-value object))
+           (unbound-variable ()))
          (when (and ext (ignore-errors (fboundp object)))
            (call (fdefinition object))
+           (call (macro-function object))
            (let ((class (find-class object nil)))
              (when class (call class))))
          (call (symbol-plist object))
@@ -975,7 +1006,7 @@ Experimental: interface subject to change."
          (case (sb-kernel:widetag-of object)
            (#.sb-vm::value-cell-header-widetag
             (call (sb-kernel::value-cell-ref object)))
-           #+sb-lutex
+           #+(and sb-lutex sb-thread)
            (#.sb-vm::lutex-widetag)
            (t
             (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"