X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=contrib%2Fsb-introspect%2Fsb-introspect.lisp;h=e986d144317ddce50fdeb15e95ba17bdb80dd278;hb=df871446529da0e83d670f35a9566c11d814be32;hp=debda196cbf50555cb8b9529e521e9c3ee321fa6;hpb=e15ca902a6c4eb6e4695e71400edbbd57c5e57cd;p=sbcl.git diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index debda19..e986d14 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -24,7 +24,10 @@ (defpackage :sb-introspect (:use "CL") - (:export "FUNCTION-ARGLIST" + (:export "ALLOCATION-INFORMATION" + "FUNCTION-ARGLIST" + "FUNCTION-LAMBDA-LIST" + "DEFTYPE-LAMBDA-LIST" "VALID-FUNCTION-NAME-P" "FIND-DEFINITION-SOURCE" "FIND-DEFINITION-SOURCES-BY-NAME" @@ -36,7 +39,12 @@ "DEFINITION-SOURCE-PLIST" "DEFINITION-NOT-FOUND" "DEFINITION-NAME" "FIND-FUNCTION-CALLEES" - "FIND-FUNCTION-CALLERS")) + "FIND-FUNCTION-CALLERS" + "WHO-BINDS" + "WHO-CALLS" + "WHO-REFERENCES" + "WHO-SETS" + "WHO-MACROEXPANDS")) (in-package :sb-introspect) @@ -64,7 +72,7 @@ include the pathname of the file and the position of the definition." (declaim (ftype (function (function) debug-info) function-debug-info)) (defun function-debug-info (function) - (let* ((function-object (sb-kernel::%closure-fun function)) + (let* ((function-object (sb-kernel::%fun-fun function)) (function-header (sb-kernel:fun-code-header function-object))) (sb-kernel:%code-debug-info function-header))) @@ -181,9 +189,14 @@ If an unsupported TYPE is requested, the function will return NIL. (not (eq type :generic-function))) (find-definition-source fun))))) ((:type) - (let ((expander-fun (sb-int:info :type :expander name))) - (when expander-fun - (find-definition-source expander-fun)))) + ;; Source locations for types are saved separately when the expander + ;; is a closure without a good source-location. + (let ((loc (sb-int:info :type :source-location name))) + (if loc + (translate-source-location loc) + (let ((expander-fun (sb-int:info :type :expander name))) + (when expander-fun + (find-definition-source expander-fun)))))) ((:method) (when (fboundp name) (let ((fun (real-fdefinition name))) @@ -219,11 +232,12 @@ If an unsupported TYPE is requested, the function will return NIL. (find-definition-source class))))) ((:method-combination) (let ((combination-fun - (ignore-errors (find-method #'sb-mop:find-method-combination - nil - (list (find-class 'generic-function) - (list 'eql name) - t))))) + (find-method #'sb-mop:find-method-combination + nil + (list (find-class 'generic-function) + (list 'eql name) + t) + nil))) (when combination-fun (find-definition-source combination-fun)))) ((:package) @@ -315,8 +329,16 @@ If an unsupported TYPE is requested, the function will return NIL. (when source (setf (definition-source-description source) (append (method-qualifiers object) - (sb-pcl::unparse-specializers - (sb-mop:method-specializers object))))) + (if (sb-mop:method-generic-function object) + (sb-pcl::unparse-specializers + (sb-mop:method-generic-function object) + (sb-mop:method-specializers object)) + (sb-mop:method-specializers object))))) + source)) + #+sb-eval + (sb-eval:interpreted-function + (let ((source (translate-source-location + (sb-eval:interpreted-function-source-location object)))) source)) (function (cond ((struct-accessor-p object) @@ -327,8 +349,10 @@ If an unsupported TYPE is requested, the function will return NIL. (struct-predicate-structure-class object))) (t (find-function-definition-source object)))) + ((or condition standard-object structure-object) + (find-definition-source (class-of object))) (t - (error "Don't know how to retrive source location for a ~S~%" + (error "Don't know how to retrieve source location for a ~S~%" (type-of object))))) (defun find-function-definition-source (function) @@ -338,8 +362,14 @@ If an unsupported TYPE is requested, the function will return NIL. (tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun)))) (make-definition-source :pathname - (if (eql (sb-c::debug-source-from debug-source) :file) - (parse-namestring (sb-c::debug-source-name debug-source))) + ;; KLUDGE: at the moment, we don't record the correct toplevel + ;; form number for forms processed by EVAL (including EVAL-WHEN + ;; :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))) :character-offset (if tlf (elt (sb-c::debug-source-start-positions debug-source) tlf)) @@ -386,19 +416,36 @@ If an unsupported TYPE is requested, the function will return NIL. ;; FIXME there may be other structure predicate functions (member self (list *struct-predicate*)))) -;;; FIXME: maybe this should be renamed as FUNCTION-LAMBDA-LIST? (defun function-arglist (function) + "Deprecated alias for FUNCTION-LAMBDA-LIST." + (function-lambda-list function)) + +(define-compiler-macro function-arglist (function) + (sb-int:deprecation-warning 'function-arglist 'function-lambda-list) + `(function-lambda-list ,function)) + +(defun function-lambda-list (function) "Describe the lambda list for the extended function designator FUNCTION. -Works for special-operators, macros, simple functions and generic -functions. Signals error if not found" +Works for special-operators, macros, simple functions, interpreted functions, +and generic functions. Signals an error if FUNCTION is not a valid extended +function designator." (cond ((valid-function-name-p function) - (function-arglist (or (and (symbolp function) - (macro-function function)) - (fdefinition function)))) + (function-lambda-list (or (and (symbolp function) + (macro-function function)) + (fdefinition function)))) ((typep function 'generic-function) (sb-pcl::generic-function-pretty-arglist function)) - (t (sb-impl::%simple-fun-arglist - (sb-impl::%closure-fun function))))) + #+sb-eval + ((typep function 'sb-eval:interpreted-function) + (sb-eval:interpreted-function-lambda-list function)) + (t + (sb-kernel:%simple-fun-arglist (sb-kernel:%fun-fun function))))) + +(defun deftype-lambda-list (typespec-operator) + "Returns the lambda list of TYPESPEC-OPERATOR as first return +value, and a flag whether the arglist could be found as second +value." + (sb-int:info :type :lambda-list typespec-operator)) (defun struct-accessor-structure-class (function) (let ((self (sb-vm::%simple-fun-self function))) @@ -481,7 +528,8 @@ 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))) + space + t))) (declaim (inline map-caller-code-components)) (defun map-caller-code-components (function spaces fn) @@ -500,4 +548,182 @@ constant pool." function)) (funcall fn obj)))))))) +;;; XREF facility + +(defun get-simple-fun (functoid) + (etypecase functoid + (sb-kernel::fdefn + (get-simple-fun (sb-vm::fdefn-fun functoid))) + ((or null sb-impl::funcallable-instance) + nil) + (function + (sb-kernel::%fun-fun functoid)))) + +(defun collect-xref (kind-index wanted-name) + (let ((ret nil)) + (dolist (env sb-c::*info-environment* ret) + ;; Loop through the infodb ... + (sb-c::do-info (env :class class :type type :name info-name + :value value) + ;; ... looking for function or macro definitions + (when (and (eql class :function) + (or (eql type :macro-function) + (eql type :definition))) + ;; Get a simple-fun for the definition, and an xref array + ;; from the table if available. + (let* ((simple-fun (get-simple-fun value)) + (xrefs (when simple-fun + (sb-kernel:%simple-fun-xrefs simple-fun))) + (array (when xrefs + (aref xrefs kind-index)))) + ;; Loop through the name/path xref entries in the table + (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) + (let ((source-location + (find-function-definition-source simple-fun))) + ;; Use the more accurate source path from + ;; the xref entry. + (setf (definition-source-form-path source-location) + xref-path) + (push (cons info-name source-location) + ret)))))))))) + +(defun who-calls (function-name) + "Use the xref facility to search for source locations where the +global function named FUNCTION-NAME is called. Returns a list of +function name, definition-source pairs." + (collect-xref #.(position :calls sb-c::*xref-kinds*) function-name)) + +(defun who-binds (symbol) + "Use the xref facility to search for source locations where the +special variable SYMBOL is rebound. Returns a list of function name, +definition-source pairs." + (collect-xref #.(position :binds sb-c::*xref-kinds*) symbol)) + +(defun who-references (symbol) + "Use the xref facility to search for source locations where the +special variable or constant SYMBOL is read. Returns a list of function +name, definition-source pairs." + (collect-xref #.(position :references sb-c::*xref-kinds*) symbol)) + +(defun who-sets (symbol) + "Use the xref facility to search for source locations where the +special variable SYMBOL is written to. Returns a list of function name, +definition-source pairs." + (collect-xref #.(position :sets sb-c::*xref-kinds*) symbol)) + +(defun who-macroexpands (macro-name) + "Use the xref facility to search for source locations where the +macro MACRO-NAME is expanded. Returns a list of function name, +definition-source pairs." + (collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name)) + +;;;; ALLOCATION INTROSPECTION + +(defun allocation-information (object) + #+sb-doc + "Returns information about the allocation of OBJECT. Primary return value +indicates the general type of allocation: :IMMEDIATE, :HEAP, :STACK, +or :FOREIGN. + +Possible secondary return value provides additional information about the +allocation. + +For :HEAP objects the secondary value is a plist: + + :SPACE + Inficates the heap segment the object is allocated in. + + :GENERATION + Is the current generation of the object: 0 for nursery, 6 for pseudo-static + generation loaded from core. (GENCGC and :SPACE :DYNAMIC only.) + + :LARGE + Indicates a \"large\" object subject to non-copying + promotion. (GENCGC and :SPACE :DYNAMIC only.) + + :PINNED + Indicates that the page(s) on which the object resides are kept live due + to conservative references. Note that object may reside on a pinned page + even if :PINNED in NIL if the GC has not had the need to mark the the page + as pinned. (GENCGC and :SPACE :DYNAMIC only.) + +For :STACK objects secondary value is the thread on whose stack the object is +allocated. + +Expected use-cases include introspection to gain insight into allocation and +GC behaviour and restricting memoization to heap-allocated arguments. + +Experimental: interface subject to change." + ;; FIXME: Would be nice to provide the size of the object as well, though + ;; maybe that should be a separate function, and something like MAP-PARTS + ;; for mapping over parts of arbitrary objects so users can get "deep sizes" + ;; as well if they want to. + ;; + ;; FIXME: For the memoization use-case possibly we should also provide a + ;; simpler HEAP-ALLOCATED-P, since that doesn't require disabling the GC + ;; scanning threads for negative answers? Similarly, STACK-ALLOCATED-P for + ;; checking if an object has been stack-allocated by a given thread for + ;; testing purposes might not come amiss. + (if (typep object '(or fixnum character)) + (values :immediate nil) + (let ((plist + (sb-sys:without-gcing + ;; Disable GC so the object cannot move to another page while + ;; we have the address. + (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)) + :read-only) + ((< sb-vm:static-space-start addr + (* sb-vm:*static-space-free-pointer* + sb-vm:n-word-bytes)) + :static) + ((< (sb-kernel:current-dynamic-space-start) addr + (sb-sys:sap-int (sb-kernel:dynamic-space-free-pointer))) + :dynamic)))) + (when space + #+gencgc + (if (eq :dynamic space) + (let ((index (sb-vm::find-page-index addr))) + (symbol-macrolet ((page (sb-alien:deref sb-vm::page-table index))) + (let ((flags (sb-alien:slot page 'sb-vm::flags))) + (list :space space + :generation (sb-alien:slot page 'sb-vm::gen) + :write-protected (logbitp 0 flags) + :pinned (logbitp 5 flags) + :large (logbitp 6 flags))))) + (list :space space)) + #-gencgc + (list :space space)))))) + (cond (plist + (values :heap plist)) + (t + (let ((sap (sb-sys:int-sap (sb-kernel:get-lisp-obj-address object)))) + ;; FIXME: Check other stacks as well. + #+sb-thread + (dolist (thread (sb-thread:list-all-threads)) + (let ((c-start (sb-di::descriptor-sap + (sb-thread::%symbol-value-in-thread + 'sb-vm:*control-stack-start* + thread))) + (c-end (sb-di::descriptor-sap + (sb-thread::%symbol-value-in-thread + 'sb-vm:*control-stack-end* + thread)))) + (when (and c-start c-end) + (when (and (sb-sys:sap<= c-start sap) + (sb-sys:sap< sap c-end)) + (return-from allocation-information + (values :stack thread)))))) + #-sb-thread + (when (sb-vm:control-stack-pointer-valid-p sap nil) + (return-from allocation-information + (values :stack sb-thread::*current-thread*)))) + :foreign))))) + (provide 'sb-introspect)