X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fintrospect.lisp;h=f4041fdb2ec00f001df675b53856d62e3fc12de1;hb=a8419eb994f3b59b70cfa12e1004711a830a43fa;hp=bf145462a6e5e9f79f4f74b5bad92aa4e6727f5e;hpb=a80a02aec71e15e1ae7bebd502399ab2b824d08b;p=sbcl.git diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index bf14546..f4041fd 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 @@ -42,7 +42,6 @@ "DEFINITION-SOURCE-CHARACTER-OFFSET" "DEFINITION-SOURCE-FILE-WRITE-DATE" "DEFINITION-SOURCE-PLIST" - "DEFINITION-NOT-FOUND" "DEFINITION-NAME" "FIND-FUNCTION-CALLEES" "FIND-FUNCTION-CALLERS" "MAP-ROOT" @@ -124,6 +123,30 @@ FBOUNDP." ;; is. (description nil :type list)) +(defun vop-sources-from-fun-templates (name) + (let ((fun-info (sb-int:info :function :info name))) + (when fun-info + (loop for vop in (sb-c::fun-info-templates fun-info) + for source = (find-definition-source + (sb-c::vop-info-generator-function vop)) + do (setf (definition-source-description source) + (list (sb-c::template-name vop) + (sb-c::template-note vop))) + collect source)))) + +(defun find-vop-source (name) + (let* ((templates (vop-sources-from-fun-templates name)) + (vop (gethash name sb-c::*backend-template-names*)) + (source (and vop + (find-definition-source + (sb-c::vop-info-generator-function vop))))) + (when source + (setf (definition-source-description source) + (list name))) + (if source + (cons source templates) + templates))) + (defun find-definition-sources-by-name (name type) "Returns a list of DEFINITION-SOURCEs for the objects of type TYPE defined with name NAME. NAME may be a symbol or a extended function @@ -192,7 +215,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))) @@ -221,9 +245,9 @@ If an unsupported TYPE is requested, the function will return NIL. (let ((expander (or (sb-int:info :setf :inverse name) (sb-int:info :setf :expander name)))) (when expander - (sb-introspect:find-definition-source (if (symbolp expander) - (symbol-function expander) - expander))))) + (find-definition-source (if (symbolp expander) + (symbol-function expander) + expander))))) ((:structure) (let ((class (get-class name))) (if class @@ -271,36 +295,30 @@ If an unsupported TYPE is requested, the function will return NIL. (list note))) collect source))))) ((:optimizer) - (when (symbolp name) - (let ((fun-info (sb-int:info :function :info name))) - (when fun-info - (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type) - (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate) - (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate) - (sb-c::fun-info-optimizer . sb-c:optimizer)))) - (loop for (reader . name) in otypes - for fn = (funcall reader fun-info) - when fn collect - (let ((source (find-definition-source fn))) - (setf (definition-source-description source) - (list name)) - source))))))) + (let ((fun-info (and (symbolp name) + (sb-int:info :function :info name)))) + (when fun-info + (let ((otypes '((sb-c:fun-info-derive-type . sb-c:derive-type) + (sb-c:fun-info-ltn-annotate . sb-c:ltn-annotate) + (sb-c:fun-info-optimizer . sb-c:optimizer) + (sb-c:fun-info-ir2-convert . sb-c:ir2-convert) + (sb-c::fun-info-stack-allocate-result + . sb-c::stack-allocate-result)))) + (loop for (reader . name) in otypes + for fn = (funcall reader fun-info) + when fn collect + (let ((source (find-definition-source fn))) + (setf (definition-source-description source) + (list name)) + source)))))) ((:vop) (when (symbolp name) - (let ((fun-info (sb-int:info :function :info name))) - (when fun-info - (loop for vop in (sb-c::fun-info-templates fun-info) - for source = (find-definition-source - (sb-c::vop-info-generator-function vop)) - do (setf (definition-source-description source) - (list (sb-c::template-name vop) - (sb-c::template-note vop))) - collect source))))) + (find-vop-source name))) ((:source-transform) (when (symbolp name) (let ((transform-fun (sb-int:info :function :source-transform name))) (when transform-fun - (sb-introspect:find-definition-source transform-fun))))) + (find-definition-source transform-fun))))) (t nil))))) @@ -356,6 +374,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) @@ -412,6 +433,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))) @@ -419,6 +442,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 @@ -490,6 +518,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 @@ -500,6 +531,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 @@ -571,8 +612,7 @@ list of the symbols :dynamic, :static, or :read-only." (lambda (obj header size) (when (= sb-vm:code-header-widetag header) (funcall fn obj size))) - space - t))) + space))) (declaim (inline map-caller-code-components)) (defun map-caller-code-components (function spaces fn) @@ -623,7 +663,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 @@ -818,12 +858,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))) @@ -901,7 +941,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)) @@ -1005,8 +1045,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)))))))