Menu
▾
▴
[Sbcl-commits] 1.0.46.35: first cut at MAP-ROOT
|
From: Nikodemus S. <nik...@ra...> - 2011-03-15 14:59:20
|
1.0.46.35: first cut at MAP-ROOT
Walking references from an arbitrary lisp object.
Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1891
diff -u -r1.1891 NEWS
--- NEWS 11 Mar 2011 15:35:30 -0000 1.1891
+++ NEWS 15 Mar 2011 14:53:38 -0000
@@ -13,6 +13,8 @@
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)
Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5219
diff -u -r1.5219 version.lisp-expr
--- version.lisp-expr 12 Mar 2011 21:29:37 -0000 1.5219
+++ version.lisp-expr 15 Mar 2011 14:53:38 -0000
@@ -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"
Index: contrib/sb-introspect/introspect.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-introspect/introspect.lisp,v
retrieving revision 1.10
diff -u -r1.10 introspect.lisp
--- contrib/sb-introspect/introspect.lisp 16 Nov 2010 18:18:03 -0000 1.10
+++ contrib/sb-introspect/introspect.lisp 15 Mar 2011 14:53:39 -0000
@@ -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 @@
(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)
|