X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fsb-introspect.lisp;h=c9fed2fe6da172e9bca2bea11404e0f7fd4bcea7;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=a9af9c46c004854b9140f1fa9846cf8dd0063ebc;hpb=31f072311935e32751508ecf824905c6b58a1d95;p=sbcl.git diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index a9af9c4..c9fed2f 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) @@ -140,125 +145,146 @@ If an unsupported TYPE is requested, the function will return NIL. (flet ((listify (x) (if (listp x) x - (list x)))) - (listify - (case type - ((:variable) - (when (eq (sb-int:info :variable :kind name) :special) - (translate-source-location (sb-int:info :source-location type name)))) - ((:constant) - (when (eq (sb-int:info :variable :kind name) :constant) - (translate-source-location (sb-int:info :source-location type name)))) - ((:symbol-macro) - (when (eq (sb-int:info :variable :kind name) :macro) - (translate-source-location (sb-int:info :source-location type name)))) - ((:macro) - (when (and (symbolp name) - (macro-function name)) - (find-definition-source (macro-function name)))) - ((:compiler-macro) - (when (compiler-macro-function name) - (find-definition-source (compiler-macro-function name)))) - ((:function :generic-function) - (when (and (fboundp name) - (or (not (symbolp name)) - (not (macro-function name)))) - (let ((fun (fdefinition name))) - (when (eq (not (typep fun 'generic-function)) - (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)))) - ((:method) - (when (and (fboundp name) - (typep (fdefinition name) 'generic-function)) - (loop for method in (sb-mop::generic-function-methods - (fdefinition name)) - for source = (find-definition-source method) - when source collect source))) - ((:setf-expander) - (when (and (consp name) - (eq (car name) 'setf)) - (setf name (cadr name))) - (let ((expander-fun (or (sb-int:info :setf :inverse name) - (sb-int:info :setf :expander name)))) - (when expander-fun - (sb-introspect:find-definition-source expander-fun)))) - ((:structure) - (let ((class (ignore-errors (find-class name)))) - (if class - (when (typep class 'sb-pcl::structure-class) - (find-definition-source class)) - (when (sb-int:info :typed-structure :info name) - (translate-source-location - (sb-int:info :source-location :typed-structure name)))))) - ((:condition :class) - (let ((class (ignore-errors (find-class name)))) - (when class - (when (eq (not (typep class 'sb-pcl::condition-class)) - (not (eq type :condition))) - (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))))) - (when combination-fun - (find-definition-source combination-fun)))) - ((:package) - (when (symbolp name) - (let ((package (find-package name))) - (when package - (find-definition-source package))))) - ;;; TRANSFORM and OPTIMIZER handling from swank-sbcl - ((:transform) - (let ((fun-info (sb-int:info :function :info name))) - (when fun-info - (loop for xform in (sb-c::fun-info-transforms fun-info) - for source = (find-definition-source - (sb-c::transform-function xform)) - for typespec = (sb-kernel:type-specifier - (sb-c::transform-type xform)) - for note = (sb-c::transform-note xform) - do (setf (definition-source-description source) - (if (consp typespec) - (list (second typespec) note) - (list note))) - collect source)))) - ((:optimizer) - (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)))))) - ((:vop) - (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)))) - ((:source-transform) - (let ((transform-fun (sb-int:info :function :source-transform name))) - (when transform-fun - (sb-introspect:find-definition-source transform-fun)))) - (t - nil))))) + (list x))) + (get-class (name) + (and (symbolp name) + (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) + (when (and (symbolp name) + (eq (sb-int:info :variable :kind name) :special)) + (translate-source-location (sb-int:info :source-location type name)))) + ((:constant) + (when (and (symbolp name) + (eq (sb-int:info :variable :kind name) :constant)) + (translate-source-location (sb-int:info :source-location type name)))) + ((:symbol-macro) + (when (and (symbolp name) + (eq (sb-int:info :variable :kind name) :macro)) + (translate-source-location (sb-int:info :source-location type name)))) + ((:macro) + (when (and (symbolp name) + (macro-function name)) + (find-definition-source (macro-function name)))) + ((:compiler-macro) + (when (compiler-macro-function name) + (find-definition-source (compiler-macro-function name)))) + ((:function :generic-function) + (when (and (fboundp name) + (or (not (symbolp name)) + (not (macro-function name)))) + (let ((fun (real-fdefinition name))) + (when (eq (not (typep fun 'generic-function)) + (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)))) + ((:method) + (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))))) + ((:setf-expander) + (when (and (consp name) + (eq (car name) 'setf)) + (setf name (cadr name))) + (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))))) + ((:structure) + (let ((class (get-class name))) + (if class + (when (typep class 'sb-pcl::structure-class) + (find-definition-source class)) + (when (sb-int:info :typed-structure :info name) + (translate-source-location + (sb-int:info :source-location :typed-structure name)))))) + ((:condition :class) + (let ((class (get-class name))) + (when (and class + (not (typep class 'sb-pcl::structure-class))) + (when (eq (not (typep class 'sb-pcl::condition-class)) + (not (eq type :condition))) + (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))))) + (when combination-fun + (find-definition-source combination-fun)))) + ((:package) + (when (symbolp name) + (let ((package (find-package name))) + (when package + (find-definition-source package))))) + ;; TRANSFORM and OPTIMIZER handling from swank-sbcl + ((:transform) + (when (symbolp name) + (let ((fun-info (sb-int:info :function :info name))) + (when fun-info + (loop for xform in (sb-c::fun-info-transforms fun-info) + for source = (find-definition-source + (sb-c::transform-function xform)) + for typespec = (sb-kernel:type-specifier + (sb-c::transform-type xform)) + for note = (sb-c::transform-note xform) + do (setf (definition-source-description source) + (if (consp typespec) + (list (second typespec) note) + (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))))))) + ((: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))))) + ((: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))))) + (t + nil))))) (defun find-definition-source (object) (typecase object @@ -271,8 +297,8 @@ If an unsupported TYPE is requested, the function will return NIL. (sb-kernel::layout-source-location layout))))))) (method-combination (car - (find-definition-sources-by-name (sb-pcl::method-combination-type object) - :method-combination))) + (find-definition-sources-by-name + (sb-pcl::method-combination-type-name object) :method-combination))) (package (translate-source-location (sb-impl::package-source-location object))) (class @@ -294,8 +320,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) @@ -367,16 +401,20 @@ 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)) - (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 struct-accessor-structure-class (function) (let ((self (sb-vm::%simple-fun-self function))) @@ -459,7 +497,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) @@ -478,4 +517,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)