X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=9ebd67797e55eda65e7029fe32f7629cb77d93e8;hb=b5f1bfd5090893a125ba7520fc2f30ad663b3af9;hp=bc406b322e9d0c75134bd9a9fe2a1dcd7d424880;hpb=3c54829dd2c9c654433ef469b320a6e9ff098177;p=sbcl.git

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index bc406b3..9ebd677 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -45,6 +45,7 @@
            "DEFINITION-NOT-FOUND" "DEFINITION-NAME"
            "FIND-FUNCTION-CALLEES"
            "FIND-FUNCTION-CALLERS"
+           "MAP-ROOT"
            "WHO-BINDS"
            "WHO-CALLS"
            "WHO-REFERENCES"
@@ -870,3 +871,113 @@ 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.
+
+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 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.
+
+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.
+
+Experimental: interface subject to change."
+  (let ((fun (coerce function 'function)))
+    (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))
+               (funcall fun part))))
+      (etypecase object
+        ((or bignum float sb-sys:system-area-pointer fixnum))
+        (weak-pointer
+         (call (weak-pointer-value object)))
+        (cons
+         (call (car object))
+         (call (cdr object))
+         (when (and ext (ignore-errors (fboundp object)))
+           (call (fdefinition object))))
+        (ratio
+         (call (numerator object))
+         (call (denominator object)))
+        (complex
+         (call (realpart object))
+         (call (realpart object)))
+        (sb-vm::instance
+         (let* ((len (sb-kernel:%instance-length object))
+                (nuntagged (if (typep object 'structure-object)
+                               (sb-kernel:layout-n-untagged-slots
+                                (sb-kernel:%instance-layout object))
+                               0)))
+           (dotimes (i (- len nuntagged))
+             (call (sb-kernel:%instance-ref object i)))))
+        (array
+         (if (simple-vector-p object)
+             (dotimes (i (length object))
+               (call (aref object i)))
+             (when (sb-kernel:array-header-p object)
+               (call (sb-kernel::%array-data-vector object))
+               (call (sb-kernel::%array-displaced-p object))
+               (unless simple
+                 (call (sb-kernel::%array-displaced-from object))))))
+        (sb-kernel:code-component
+         (call (sb-kernel:%code-entry-points object))
+         (call (sb-kernel:%code-debug-info object))
+         (loop for i from sb-vm:code-constants-offset
+               below (sb-kernel:get-header-data object)
+               do (call (sb-kernel:code-header-ref object i))))
+        (sb-kernel:fdefn
+         (call (sb-kernel:fdefn-name object))
+         (call (sb-kernel:fdefn-fun object)))
+        (sb-kernel:simple-fun
+         (unless simple
+           (call (sb-kernel:%simple-fun-next object)))
+         (call (sb-kernel:fun-code-header object))
+         (call (sb-kernel:%simple-fun-name object))
+         (call (sb-kernel:%simple-fun-arglist object))
+         (call (sb-kernel:%simple-fun-type object))
+         (call (sb-kernel:%simple-fun-info object)))
+        (sb-kernel:closure
+         (call (sb-kernel:%closure-fun object))
+         (sb-kernel:do-closure-values (x object)
+           (call x)))
+        (sb-kernel:funcallable-instance
+         (call (sb-kernel:%funcallable-instance-function object))
+         (loop for i from 1 below (- (1+ (sb-kernel:get-closure-length object))
+                                     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 (and ext (ignore-errors (fboundp object)))
+           (call (fdefinition object))
+           (let ((class (find-class object nil)))
+             (when class (call class))))
+         (call (symbol-plist object))
+         (call (symbol-name object))
+         (unless simple
+           (call (symbol-package object))))
+        (sb-kernel::random-class
+         (case (sb-kernel:widetag-of object)
+           (#.sb-vm::value-cell-header-widetag
+            (call (sb-kernel::value-cell-ref object)))
+           #+sb-lutex
+           (#.sb-vm::lutex-widetag)
+           (t
+            (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"
+                  (sb-kernel:widetag-of object) object)))))))
+  object)