X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=f958e70773dc08ebb576d5ef99e6413ffa6fd283;hb=7169796933b86601eaf70d3a9064600730cb2b40;hp=ed8f2567b30a08216fe4bee6b42ff52b4b54bd4b;hpb=344a1f088581303c92da333ddddc9aeb9c212ba9;p=sbcl.git diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index ed8f256..f958e70 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))) @@ -886,7 +909,7 @@ 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. +conservative roots from the thread registers and interrupt contexts. Experimental: interface subject to change." (let ((fun (coerce function 'function)) @@ -902,7 +925,7 @@ Experimental: interface subject to change." (funcall fun part)))) (when ext (let ((table sb-pcl::*eql-specializer-table*)) - (call (sb-ext:with-locked-hash-table (table) + (call (sb-int:with-locked-system-table (table) (gethash object table))))) (etypecase object ((or bignum float sb-sys:system-area-pointer fixnum)) @@ -927,9 +950,29 @@ Experimental: interface subject to change." 0))) (dotimes (i (- len nuntagged)) (call (sb-kernel:%instance-ref object i)))) + #+sb-thread (when (typep object 'sb-thread:thread) - (dolist (value (sb-thread::%thread-local-values object)) - (call value)))) + (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)) @@ -986,8 +1029,6 @@ Experimental: interface subject to change." (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)))))))