X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fsb-introspect.lisp;h=8ef31134f107fcacd0f71eed33fbf28b4dac8737;hb=0e03a9ac950b78d776c4869c809e202d9e929f39;hp=d614307a0858fed8b934235440261f32f9b33a7c;hpb=5b223181b0fdec8eaad5e787aa0d0340960fee3b;p=sbcl.git diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index d614307..8ef3113 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -36,7 +36,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) @@ -143,7 +148,14 @@ If an unsupported TYPE is requested, the function will return NIL. (list x))) (get-class (name) (and (symbolp name) - (find-class name nil)))) + (find-class name nil))) + (real-fdefinition (name) + ;; for getting the real function object, even if the + ;; function is being profiled + (let ((profile-info (gethash name sb-profile::*profiled-fun-name->info*))) + (if profile-info + (sb-profile::profile-info-encapsulated-fun profile-info) + (fdefinition name))))) (listify (case type ((:variable) @@ -169,7 +181,7 @@ If an unsupported TYPE is requested, the function will return NIL. (when (and (fboundp name) (or (not (symbolp name)) (not (macro-function name)))) - (let ((fun (fdefinition name))) + (let ((fun (real-fdefinition name))) (when (eq (not (typep fun 'generic-function)) (not (eq type :generic-function))) (find-definition-source fun))))) @@ -178,12 +190,13 @@ If an unsupported TYPE is requested, the function will return NIL. (when expander-fun (find-definition-source expander-fun)))) ((:method) - (when (and (fboundp name) - (typep (fdefinition name) 'generic-function)) - (loop for method in (sb-mop::generic-function-methods - (fdefinition name)) + (when (fboundp name) + (let ((fun (real-fdefinition name))) + (when (typep fun 'generic-function) + (loop for method in (sb-mop::generic-function-methods + fun) for source = (find-definition-source method) - when source collect source))) + when source collect source))))) ((:setf-expander) (when (and (consp name) (eq (car name) 'setf)) @@ -310,6 +323,11 @@ If an unsupported TYPE is requested, the function will return NIL. (sb-pcl::unparse-specializers (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) (find-definition-source @@ -380,14 +398,19 @@ If an unsupported TYPE is requested, the function will return NIL. ;;; FIXME: maybe this should be renamed as FUNCTION-LAMBDA-LIST? (defun function-arglist (function) - "Describe the lambda list for the function designator FUNCTION. -Works for special-operators, macros, simple functions and generic -functions. Signals error if not found" + "Describe the lambda list for the extended function designator FUNCTION. +Works for special-operators, macros, simple functions, +interpreted functions, and generic functions. Signals error if +not found" (cond ((valid-function-name-p function) - (function-arglist - (or (macro-function function) (fdefinition function)))) + (function-arglist (or (and (symbolp function) + (macro-function function)) + (fdefinition function)))) ((typep function 'generic-function) (sb-pcl::generic-function-pretty-arglist function)) + #+sb-eval + ((typep function 'sb-eval:interpreted-function) + (sb-eval:interpreted-function-lambda-list function)) (t (sb-impl::%simple-fun-arglist (sb-impl::%closure-fun function))))) @@ -491,4 +514,76 @@ 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::%closure-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-vm::%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)) + (provide 'sb-introspect)