X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=3af8709faece462e29b2dda29ebdb096f7eb5442;hb=b2036b630923934234d66247f18acf7a6c1085ec;hp=9ebd67797e55eda65e7029fe32f7629cb77d93e8;hpb=b5f1bfd5090893a125ba7520fc2f30ad663b3af9;p=sbcl.git diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index 9ebd677..3af8709 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -21,7 +21,7 @@ ;;; TODO ;;; 1) structs don't have within-file location info. problem for the -;;; structure itself, accessors and the predicate +;;; structure itself, accessors, the copier and the predicate ;;; 3) error handling. Signal random errors, or handle and resignal 'our' ;;; error, or return NIL? ;;; 4) FIXMEs @@ -192,7 +192,8 @@ If an unsupported TYPE is requested, the function will return NIL. ((:function :generic-function) (when (and (fboundp name) (or (not (symbolp name)) - (not (macro-function name)))) + (not (macro-function name)) + (special-operator-p name))) (let ((fun (real-fdefinition name))) (when (eq (not (typep fun 'generic-function)) (not (eq type :generic-function))) @@ -356,6 +357,9 @@ If an unsupported TYPE is requested, the function will return NIL. ((struct-predicate-p object) (find-definition-source (struct-predicate-structure-class object))) + ((struct-copier-p object) + (find-definition-source + (struct-copier-structure-class object))) (t (find-function-definition-source object)))) ((or condition standard-object structure-object) @@ -376,9 +380,8 @@ If an unsupported TYPE is requested, the function will return NIL. ;; :COMPILE-TOPLEVEL). Until that's fixed, don't return a ;; DEFINITION-SOURCE with a pathname. (When that's fixed, take ;; out the (not (debug-source-form ...)) test. - (if (and (sb-c::debug-source-namestring debug-source) - (not (sb-c::debug-source-form debug-source))) - (parse-namestring (sb-c::debug-source-namestring debug-source))) + (when (stringp (sb-c::debug-source-namestring debug-source)) + (parse-namestring (sb-c::debug-source-namestring debug-source))) :character-offset (if tlf (elt (sb-c::debug-source-start-positions debug-source) tlf)) @@ -413,6 +416,8 @@ If an unsupported TYPE is requested, the function will return NIL. (sb-vm::%simple-fun-self #'(setf definition-source-pathname))) (defvar *struct-predicate* (sb-vm::%simple-fun-self #'definition-source-p)) +(defvar *struct-copier* + (sb-vm::%simple-fun-self #'copy-definition-source)) (defun struct-accessor-p (function) (let ((self (sb-vm::%simple-fun-self function))) @@ -420,6 +425,11 @@ If an unsupported TYPE is requested, the function will return NIL. (member self (list *struct-slotplace-reader* *struct-slotplace-writer*)))) +(defun struct-copier-p (function) + (let ((self (sb-vm::%simple-fun-self function))) + ;; FIXME there may be other structure copier functions + (member self (list *struct-copier*)))) + (defun struct-predicate-p (function) (let ((self (sb-vm::%simple-fun-self function))) ;; FIXME there may be other structure predicate functions @@ -491,6 +501,9 @@ value." type (sb-impl::%fun-type function-designator))))))) +;;; FIXME: These three are pretty terrible. Can we place have some proper metadata +;;; instead. + (defun struct-accessor-structure-class (function) (let ((self (sb-vm::%simple-fun-self function))) (cond @@ -501,6 +514,16 @@ value." (sb-kernel:%closure-index-ref function 1))))) ))) +(defun struct-copier-structure-class (function) + (let ((self (sb-vm::%simple-fun-self function))) + (cond + ((member self (list *struct-copier*)) + (find-class + (sb-kernel::classoid-name + (sb-kernel::layout-classoid + (sb-kernel:%closure-index-ref function 0))))) + ))) + (defun struct-predicate-structure-class (function) (let ((self (sb-vm::%simple-fun-self function))) (cond @@ -624,7 +647,7 @@ constant pool." (loop for i from 0 below (length array) by 2 for xref-name = (aref array i) for xref-path = (aref array (1+ i)) - do (when (eql xref-name wanted-name) + do (when (equal xref-name wanted-name) (let ((source-location (find-function-definition-source simple-fun))) ;; Use the more accurate source path from @@ -819,12 +842,12 @@ Experimental: interface subject to change." (let* ((addr (sb-kernel:get-lisp-obj-address object)) (space (cond ((< sb-vm:read-only-space-start addr - (* sb-vm:*read-only-space-free-pointer* - sb-vm:n-word-bytes)) + (ash sb-vm:*read-only-space-free-pointer* + sb-vm:n-fixnum-tag-bits)) :read-only) ((< sb-vm:static-space-start addr - (* sb-vm:*static-space-free-pointer* - sb-vm:n-word-bytes)) + (ash sb-vm:*static-space-free-pointer* + sb-vm:n-fixnum-tag-bits)) :static) ((< (sb-kernel:current-dynamic-space-start) addr (sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer))) @@ -871,37 +894,43 @@ 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. +(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, 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 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, 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. +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 stack & interrupt contexts, nor over thread-local symbol -bindings. +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))) + (let ((fun (coerce function 'function)) + (seen (sb-int:alloc-xset))) (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)) + (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-int:with-locked-system-table (table) + (gethash object table))))) (etypecase object ((or bignum float sb-sys:system-area-pointer fixnum)) - (weak-pointer - (call (weak-pointer-value object))) + (sb-ext:weak-pointer + (call (sb-ext:weak-pointer-value object))) (cons (call (car object)) (call (cdr object)) @@ -920,7 +949,30 @@ Experimental: interface subject to change." (sb-kernel:%instance-layout object)) 0))) (dotimes (i (- len nuntagged)) - (call (sb-kernel:%instance-ref object i))))) + (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)) @@ -957,14 +1009,16 @@ Experimental: interface subject to change." 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 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)) @@ -975,7 +1029,7 @@ Experimental: interface subject to change." (case (sb-kernel:widetag-of object) (#.sb-vm::value-cell-header-widetag (call (sb-kernel::value-cell-ref object))) - #+sb-lutex + #+(and sb-lutex sb-thread) (#.sb-vm::lutex-widetag) (t (warn "~&MAP-ROOT: Unknown widetag ~S: ~S~%"