X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=3399502284388899bafaf698c7123149d13db72a;hb=6d36f2d6954cb79e3c88fef33fe0c3ad63deaea8;hp=bc406b322e9d0c75134bd9a9fe2a1dcd7d424880;hpb=4fa1c71c7dfa5c6d361304321cc67069a6410694;p=sbcl.git diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index bc406b3..3399502 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,144 @@ Experimental: interface subject to change." (values :stack sb-thread::*current-thread*)))) :foreign))))) +(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 (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 (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 registers and interrupt contexts. + +Experimental: interface subject to change." + (let ((fun (coerce function 'function)) + (seen (sb-int:alloc-xset))) + (flet ((call (part) + (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)) + (sb-ext:weak-pointer + (call (sb-ext: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)))) + #+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)) + (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 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)) + (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))) + #+(and sb-lutex sb-thread) + (#.sb-vm::lutex-widetag) + (t + (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%" + (sb-kernel:widetag-of object) object))))))) + object)