1.0.46.35: first cut at MAP-ROOT

 Walking references from an arbitrary lisp object.

diff --git a/NEWS b/NEWS
index c92f2a9..14d3cb3 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,8 @@ changes relative to sbcl-1.0.46:
     declarations. (lp#726331)
   * enhancement: :NOT-NULL option has been added to alien C-STRING type to indicate
     that NIL/NULL is excluded from the type.
+  * enhancement: SB-INTROSPECT:MAP-ROOT allows mapping over pointers contained in
+    arbitrary objects.
   * optimization: SLOT-VALUE &co are faster in the presence of SLOT-VALUE-USING-CLASS
     and its compatriots.
   * optimization: core startup time is reduced by 30% on x86-64. (lp#557357)

diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index bc406b3..9ebd677 100644 (file)
--- 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)

diff --git a/version.lisp-expr b/version.lisp-expr
index 429f15b..d9525d0 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.34"
+"1.0.46.35"