From b5f1bfd5090893a125ba7520fc2f30ad663b3af9 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 15 Mar 2011 14:54:47 +0000 Subject: [PATCH] 1.0.46.35: first cut at MAP-ROOT Walking references from an arbitrary lisp object. --- NEWS | 2 + contrib/sb-introspect/introspect.lisp | 111 +++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 3 files changed, 114 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index c92f2a9..14d3cb3 100644 --- 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 --- 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 --- 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" -- 1.7.10.4