From d351f80b1076dd54e5aee3dacab82d59c2e58060 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 5 Aug 2009 12:11:42 +0000 Subject: [PATCH] 1.0.30.35: turn SB-INTROSPECT into an ASDF system * I at least am starting to find myself having to insert (EVAL-WHEN (...) (REQUIRE :SB-INTROSPECT)) in too many places. This may be a sign that things aught to be in SB-EXT instead, but ASDFication seems like a logical next step. ...arguably all contribs but ASDF itself should be ASDF systems. --- NEWS | 1 + contrib/sb-introspect/Makefile | 7 +- contrib/sb-introspect/introspect.lisp | 732 +++++++++++++++++++++++++++++ contrib/sb-introspect/sb-introspect.asd | 50 ++ contrib/sb-introspect/sb-introspect.lisp | 729 ---------------------------- contrib/sb-introspect/test-driver.lisp | 414 ++++++++++------ contrib/sb-introspect/xref-test-data.lisp | 14 + contrib/sb-introspect/xref-test.lisp | 91 ++-- version.lisp-expr | 2 +- 9 files changed, 1116 insertions(+), 924 deletions(-) create mode 100644 contrib/sb-introspect/introspect.lisp create mode 100644 contrib/sb-introspect/sb-introspect.asd delete mode 100644 contrib/sb-introspect/sb-introspect.lisp diff --git a/NEWS b/NEWS index 7986978..f743ead 100644 --- a/NEWS +++ b/NEWS @@ -20,6 +20,7 @@ changes relative to sbcl-1.0.30: * optimization: ARRAY-IN-BOUNDS-P is resolved at compile-time when sufficient type information is available. (thanks to Leslie Polzer) * optimization: unused vector creation can now be optimized away. + * improvement: ASDF systems can now depends on SB-INTROSPECT. * improvement: a STYLE-WARNING is signalled when a generic function clobbers an earlier FTYPE proclamation. * improvement: the compiler is able to track the effective type of diff --git a/contrib/sb-introspect/Makefile b/contrib/sb-introspect/Makefile index 525f235..ce88f93 100644 --- a/contrib/sb-introspect/Makefile +++ b/contrib/sb-introspect/Makefile @@ -1,5 +1,2 @@ -MODULE=sb-introspect -include ../vanilla-module.mk - -test:: - $(SBCL) --disable-debugger --load test-driver.lisp +SYSTEM=sb-introspect +include ../asdf-module.mk diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp new file mode 100644 index 0000000..5f46ae6 --- /dev/null +++ b/contrib/sb-introspect/introspect.lisp @@ -0,0 +1,732 @@ +;;; introspection library + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +;;; For the avoidance of doubt, the exported interface is the supported +;;; interface. Anything else is internal, though you're welcome to argue a +;;; case for exporting it. + +;;; If you steal the code from this file to cut and paste into your +;;; own project, there will be much wailing and gnashing of teeth. +;;; Your teeth. If need be, we'll kick them for you. This is a +;;; contrib, we're allowed to look in internals. You're an +;;; application programmer, and are not. + +;;; TODO +;;; 1) structs don't have within-file location info. problem for the +;;; structure itself, accessors and the predicate +;;; 3) error handling. Signal random errors, or handle and resignal 'our' +;;; error, or return NIL? +;;; 4) FIXMEs + +(defpackage :sb-introspect + (:use "CL") + (:export "ALLOCATION-INFORMATION" + "FUNCTION-ARGLIST" + "FUNCTION-LAMBDA-LIST" + "DEFTYPE-LAMBDA-LIST" + "VALID-FUNCTION-NAME-P" + "FIND-DEFINITION-SOURCE" + "FIND-DEFINITION-SOURCES-BY-NAME" + "DEFINITION-SOURCE" + "DEFINITION-SOURCE-PATHNAME" + "DEFINITION-SOURCE-FORM-PATH" + "DEFINITION-SOURCE-CHARACTER-OFFSET" + "DEFINITION-SOURCE-FILE-WRITE-DATE" + "DEFINITION-SOURCE-PLIST" + "DEFINITION-NOT-FOUND" "DEFINITION-NAME" + "FIND-FUNCTION-CALLEES" + "FIND-FUNCTION-CALLERS" + "WHO-BINDS" + "WHO-CALLS" + "WHO-REFERENCES" + "WHO-SETS" + "WHO-MACROEXPANDS")) + +(in-package :sb-introspect) + +;;;; Internal interface for SBCL debug info + +;;; Here are some tutorial-style type definitions to help understand +;;; the internal SBCL debugging data structures we're using. The +;;; commentary is based on CMUCL's debug internals manual. +;;; +(deftype debug-info () + "Structure containing all the debug information related to a function. +Function objects reference debug-infos which in turn reference +debug-sources and so on." + 'sb-c::compiled-debug-info) + +(deftype debug-source () + "Debug sources describe where to find source code. +For example, the debug source for a function compiled from a file will +include the pathname of the file and the position of the definition." + 'sb-c::debug-source) + +(deftype debug-function () + "Debug function represent static compile-time information about a function." + 'sb-c::compiled-debug-fun) + +(declaim (ftype (function (function) debug-info) function-debug-info)) +(defun function-debug-info (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))) + +(declaim (ftype (function (function) debug-source) function-debug-source)) +(defun function-debug-source (function) + (debug-info-source (function-debug-info function))) + +(declaim (ftype (function (debug-info) debug-source) debug-info-source)) +(defun debug-info-source (debug-info) + (sb-c::debug-info-source debug-info)) + +(declaim (ftype (function (debug-info) debug-function) debug-info-debug-function)) +(defun debug-info-debug-function (debug-info) + (elt (sb-c::compiled-debug-info-fun-map debug-info) 0)) + +(defun valid-function-name-p (name) + "True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION " + (and (sb-int:valid-function-name-p name) t)) + +;;;; Finding definitions + +(defstruct definition-source + ;; Pathname of the source file that the definition was compiled from. + ;; This is null if the definition was not compiled from a file. + (pathname nil :type (or null pathname)) + ;; Source-path of the definition within the file. + ;; This may be incomplete depending on the debug level at which the + ;; source was compiled. + (form-path '() :type list) + ;; Character offset of the top-level-form containing the definition. + ;; This corresponds to the first element of form-path. + (character-offset nil :type (or null integer)) + ;; File-write-date of the source file when compiled. + ;; Null if not compiled from a file. + (file-write-date nil :type (or null integer)) + ;; plist from WITH-COMPILATION-UNIT + (plist nil) + ;; Any extra metadata that the caller might be interested in. For + ;; example the specializers of the method whose definition-source this + ;; is. + (description nil :type list)) + +(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 +name. Type can currently be one of the following: + + (Public) + :CLASS + :COMPILER-MACRO + :CONDITION + :CONSTANT + :FUNCTION + :GENERIC-FUNCTION + :MACRO + :METHOD + :METHOD-COMBINATION + :PACKAGE + :SETF-EXPANDER + :STRUCTURE + :SYMBOL-MACRO + :TYPE + :VARIABLE + + (Internal) + :OPTIMIZER + :SOURCE-TRANSFORM + :TRANSFORM + :VOP + +If an unsupported TYPE is requested, the function will return NIL. +" + (flet ((listify (x) + (if (listp x) + x + (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) + ;; 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))) + (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 + (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) + (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 + ((or sb-pcl::condition-class sb-pcl::structure-class) + (let ((classoid (sb-impl::find-classoid (class-name object)))) + (when classoid + (let ((layout (sb-impl::classoid-layout classoid))) + (when layout + (translate-source-location + (sb-kernel::layout-source-location layout))))))) + (method-combination + (car + (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 + (translate-source-location (sb-pcl::definition-source object))) + ;; Use the PCL definition location information instead of the function + ;; debug-info for methods and generic functions. Sometimes the + ;; debug-info would point into PCL internals instead of the proper + ;; location. + (generic-function + (let ((source (translate-source-location + (sb-pcl::definition-source object)))) + (when source + (setf (definition-source-description source) + (list (sb-mop:generic-function-lambda-list object)))) + source)) + (method + (let ((source (translate-source-location + (sb-pcl::definition-source object)))) + (when source + (setf (definition-source-description source) + (append (method-qualifiers 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) + (find-definition-source + (struct-accessor-structure-class object))) + ((struct-predicate-p object) + (find-definition-source + (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 retrieve source location for a ~S~%" + (type-of object))))) + +(defun find-function-definition-source (function) + (let* ((debug-info (function-debug-info function)) + (debug-source (debug-info-source debug-info)) + (debug-fun (debug-info-debug-function debug-info)) + (tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun)))) + (make-definition-source + :pathname + ;; 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)) + ;; Unfortunately there is no proper source path available in the + ;; debug-source. FIXME: We could use sb-di:code-locations to get + ;; a full source path. -luke (12/Mar/2005) + :form-path (if tlf (list tlf)) + :file-write-date (sb-c::debug-source-created debug-source) + :plist (sb-c::debug-source-plist debug-source)))) + +(defun translate-source-location (location) + (if location + (make-definition-source + :pathname (let ((n (sb-c:definition-source-location-namestring location))) + (when n + (parse-namestring n))) + :form-path + (let ((number (sb-c:definition-source-location-toplevel-form-number + location))) + (when number + (list number))) + :plist (sb-c:definition-source-location-plist location)) + (make-definition-source))) + +;;; This is kludgey. We expect these functions (the underlying functions, +;;; not the closures) to be in static space and so not move ever. +;;; FIXME It's also possibly wrong: not all structures use these vanilla +;;; accessors, e.g. when the :type option is used +(defvar *struct-slotplace-reader* + (sb-vm::%simple-fun-self #'definition-source-pathname)) +(defvar *struct-slotplace-writer* + (sb-vm::%simple-fun-self #'(setf definition-source-pathname))) +(defvar *struct-predicate* + (sb-vm::%simple-fun-self #'definition-source-p)) + +(defun struct-accessor-p (function) + (let ((self (sb-vm::%simple-fun-self function))) + ;; FIXME there are other kinds of struct accessor. Fill out this list + (member self (list *struct-slotplace-reader* + *struct-slotplace-writer*)))) + +(defun struct-predicate-p (function) + (let ((self (sb-vm::%simple-fun-self function))) + ;; FIXME there may be other structure predicate functions + (member self (list *struct-predicate*)))) + +(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, interpreted functions, +and generic functions. Signals an error if FUNCTION is not a valid extended +function designator." + (cond ((valid-function-name-p function) + (function-lambda-list (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-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))) + (cond + ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*)) + (find-class + (sb-kernel::classoid-name + (sb-kernel::layout-classoid + (sb-kernel:%closure-index-ref function 1))))) + ))) + +(defun struct-predicate-structure-class (function) + (let ((self (sb-vm::%simple-fun-self function))) + (cond + ((member self (list *struct-predicate*)) + (find-class + (sb-kernel::classoid-name + (sb-kernel::layout-classoid + (sb-kernel:%closure-index-ref function 0))))) + ))) + +;;;; find callers/callees, liberated from Helmut Eller's code in SLIME + +;;; This interface is trmendously experimental. + +;;; For the moment I'm taking the view that FDEFN is an internal +;;; object (one out of one CMUCL developer surveyed didn't know what +;;; they were for), so these routines deal in FUNCTIONs + +;;; Find callers and callees by looking at the constant pool of +;;; compiled code objects. We assume every fdefn object in the +;;; constant pool corresponds to a call to that function. A better +;;; strategy would be to use the disassembler to find actual +;;; call-sites. + +(defun find-function-callees (function) + "Return functions called by FUNCTION." + (let ((callees '())) + (map-code-constants + (sb-kernel:fun-code-header function) + (lambda (obj) + (when (sb-kernel:fdefn-p obj) + (push (sb-kernel:fdefn-fun obj) + callees)))) + callees)) + + +(defun find-function-callers (function &optional (spaces '(:read-only :static + :dynamic))) + "Return functions which call FUNCTION, by searching SPACES for code objects" + (let ((referrers '())) + (map-caller-code-components + function + spaces + (lambda (code) + (let ((entry (sb-kernel:%code-entry-points code))) + (cond ((not entry) + (push (princ-to-string code) referrers)) + (t + (loop for e = entry then (sb-kernel::%simple-fun-next e) + while e + do (pushnew e referrers))))))) + referrers)) + +(declaim (inline map-code-constants)) +(defun map-code-constants (code fn) + "Call FN for each constant in CODE's constant pool." + (check-type code sb-kernel:code-component) + (loop for i from sb-vm:code-constants-offset below + (sb-kernel:get-header-data code) + do (funcall fn (sb-kernel:code-header-ref code i)))) + +(declaim (inline map-allocated-code-components)) +(defun map-allocated-code-components (spaces fn) + "Call FN for each allocated code component in one of SPACES. FN +receives the object and its size as arguments. SPACES should be a +list of the symbols :dynamic, :static, or :read-only." + (dolist (space spaces) + (sb-vm::map-allocated-objects + (lambda (obj header size) + (when (= sb-vm:code-header-widetag header) + (funcall fn obj size))) + space + t))) + +(declaim (inline map-caller-code-components)) +(defun map-caller-code-components (function spaces fn) + "Call FN for each code component with a fdefn for FUNCTION in its +constant pool." + (let ((function (coerce function 'function))) + (map-allocated-code-components + spaces + (lambda (obj size) + (declare (ignore size)) + (map-code-constants + obj + (lambda (constant) + (when (and (sb-kernel:fdefn-p constant) + (eq (sb-kernel:fdefn-fun constant) + 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))))) + diff --git a/contrib/sb-introspect/sb-introspect.asd b/contrib/sb-introspect/sb-introspect.asd new file mode 100644 index 0000000..b484c23 --- /dev/null +++ b/contrib/sb-introspect/sb-introspect.asd @@ -0,0 +1,50 @@ +;;; -*- Lisp -*- + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(defpackage :sb-introspect-system + (:use :asdf :cl)) + +(in-package :sb-introspect-system) + +(defsystem :sb-introspect + :components ((:file "introspect"))) + +(defmethod perform :after ((o load-op) (c (eql (find-system :sb-introspect)))) + (provide 'sb-introspect)) + +(defmethod perform ((o test-op) (c (eql (find-system :sb-introspect)))) + (operate 'load-op :sb-introspect-tests) + (operate 'test-op :sb-introspect-tests)) + +(defclass plist-file (cl-source-file) + ((source-plist + :initform nil + :initarg :source-plist + :reader plist-file-source-plist))) + +(defmethod perform ((op compile-op) (com plist-file)) + (with-compilation-unit (:source-plist (plist-file-source-plist com)) + (call-next-method))) + +(defmethod perform ((op load-op) (com plist-file)) + (with-compilation-unit (:source-plist (plist-file-source-plist com)) + (call-next-method))) + +(defsystem :sb-introspect-tests + :depends-on (:sb-introspect :sb-rt) + :components ((:file "xref-test-data") + (:file "xref-test" :depends-on ("xref-test-data")) + (:plist-file "test" :source-plist (:test-outer "OUT")) + (:file "test-driver" :depends-on ("test")))) + +(defmethod perform ((op test-op) (com (eql (find-system :sb-introspect-tests)))) + (or (funcall (intern "DO-TESTS" (find-package "SB-RT"))) + (error "~S failed" 'test-op))) diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp deleted file mode 100644 index e986d14..0000000 --- a/contrib/sb-introspect/sb-introspect.lisp +++ /dev/null @@ -1,729 +0,0 @@ -;;; introspection library - -;;; This is here as a discussion point, not yet a supported interface. If -;;; you would like to use the functions here, or you would like other -;;; functions to be here, join the debate on navel@metacircles.com. -;;; List info at http://lists.metacircles.com/cgi-bin/mailman/listinfo/navel - -;;; For the avoidance of doubt, the exported interface is the proposed -;;; supported interface. Anything else is internal, though you're -;;; welcome to argue a case for exporting it. - -;;; If you steal the code from this file to cut and paste into your -;;; own project, there will be much wailing and gnashing of teeth. -;;; Your teeth. If need be, we'll kick them for you. This is a -;;; contrib, we're allowed to look in internals. You're an -;;; application programmer, and are not. - -;;; TODO -;;; 1) structs don't have within-file location info. problem for the -;;; structure itself, accessors and the predicate -;;; 3) error handling. Signal random errors, or handle and resignal 'our' -;;; error, or return NIL? -;;; 4) FIXMEs - -(defpackage :sb-introspect - (:use "CL") - (:export "ALLOCATION-INFORMATION" - "FUNCTION-ARGLIST" - "FUNCTION-LAMBDA-LIST" - "DEFTYPE-LAMBDA-LIST" - "VALID-FUNCTION-NAME-P" - "FIND-DEFINITION-SOURCE" - "FIND-DEFINITION-SOURCES-BY-NAME" - "DEFINITION-SOURCE" - "DEFINITION-SOURCE-PATHNAME" - "DEFINITION-SOURCE-FORM-PATH" - "DEFINITION-SOURCE-CHARACTER-OFFSET" - "DEFINITION-SOURCE-FILE-WRITE-DATE" - "DEFINITION-SOURCE-PLIST" - "DEFINITION-NOT-FOUND" "DEFINITION-NAME" - "FIND-FUNCTION-CALLEES" - "FIND-FUNCTION-CALLERS" - "WHO-BINDS" - "WHO-CALLS" - "WHO-REFERENCES" - "WHO-SETS" - "WHO-MACROEXPANDS")) - -(in-package :sb-introspect) - -;;;; Internal interface for SBCL debug info - -;;; Here are some tutorial-style type definitions to help understand -;;; the internal SBCL debugging data structures we're using. The -;;; commentary is based on CMUCL's debug internals manual. -;;; -(deftype debug-info () - "Structure containing all the debug information related to a function. -Function objects reference debug-infos which in turn reference -debug-sources and so on." - 'sb-c::compiled-debug-info) - -(deftype debug-source () - "Debug sources describe where to find source code. -For example, the debug source for a function compiled from a file will -include the pathname of the file and the position of the definition." - 'sb-c::debug-source) - -(deftype debug-function () - "Debug function represent static compile-time information about a function." - 'sb-c::compiled-debug-fun) - -(declaim (ftype (function (function) debug-info) function-debug-info)) -(defun function-debug-info (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))) - -(declaim (ftype (function (function) debug-source) function-debug-source)) -(defun function-debug-source (function) - (debug-info-source (function-debug-info function))) - -(declaim (ftype (function (debug-info) debug-source) debug-info-source)) -(defun debug-info-source (debug-info) - (sb-c::debug-info-source debug-info)) - -(declaim (ftype (function (debug-info) debug-function) debug-info-debug-function)) -(defun debug-info-debug-function (debug-info) - (elt (sb-c::compiled-debug-info-fun-map debug-info) 0)) - -(defun valid-function-name-p (name) - "True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION " - (and (sb-int:valid-function-name-p name) t)) - -;;;; Finding definitions - -(defstruct definition-source - ;; Pathname of the source file that the definition was compiled from. - ;; This is null if the definition was not compiled from a file. - (pathname nil :type (or null pathname)) - ;; Source-path of the definition within the file. - ;; This may be incomplete depending on the debug level at which the - ;; source was compiled. - (form-path '() :type list) - ;; Character offset of the top-level-form containing the definition. - ;; This corresponds to the first element of form-path. - (character-offset nil :type (or null integer)) - ;; File-write-date of the source file when compiled. - ;; Null if not compiled from a file. - (file-write-date nil :type (or null integer)) - ;; plist from WITH-COMPILATION-UNIT - (plist nil) - ;; Any extra metadata that the caller might be interested in. For - ;; example the specializers of the method whose definition-source this - ;; is. - (description nil :type list)) - -(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 -name. Type can currently be one of the following: - - (Public) - :CLASS - :COMPILER-MACRO - :CONDITION - :CONSTANT - :FUNCTION - :GENERIC-FUNCTION - :MACRO - :METHOD - :METHOD-COMBINATION - :PACKAGE - :SETF-EXPANDER - :STRUCTURE - :SYMBOL-MACRO - :TYPE - :VARIABLE - - (Internal) - :OPTIMIZER - :SOURCE-TRANSFORM - :TRANSFORM - :VOP - -If an unsupported TYPE is requested, the function will return NIL. -" - (flet ((listify (x) - (if (listp x) - x - (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) - ;; 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))) - (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 - (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) - (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 - ((or sb-pcl::condition-class sb-pcl::structure-class) - (let ((classoid (sb-impl::find-classoid (class-name object)))) - (when classoid - (let ((layout (sb-impl::classoid-layout classoid))) - (when layout - (translate-source-location - (sb-kernel::layout-source-location layout))))))) - (method-combination - (car - (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 - (translate-source-location (sb-pcl::definition-source object))) - ;; Use the PCL definition location information instead of the function - ;; debug-info for methods and generic functions. Sometimes the - ;; debug-info would point into PCL internals instead of the proper - ;; location. - (generic-function - (let ((source (translate-source-location - (sb-pcl::definition-source object)))) - (when source - (setf (definition-source-description source) - (list (sb-mop:generic-function-lambda-list object)))) - source)) - (method - (let ((source (translate-source-location - (sb-pcl::definition-source object)))) - (when source - (setf (definition-source-description source) - (append (method-qualifiers 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) - (find-definition-source - (struct-accessor-structure-class object))) - ((struct-predicate-p object) - (find-definition-source - (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 retrieve source location for a ~S~%" - (type-of object))))) - -(defun find-function-definition-source (function) - (let* ((debug-info (function-debug-info function)) - (debug-source (debug-info-source debug-info)) - (debug-fun (debug-info-debug-function debug-info)) - (tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun)))) - (make-definition-source - :pathname - ;; 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)) - ;; Unfortunately there is no proper source path available in the - ;; debug-source. FIXME: We could use sb-di:code-locations to get - ;; a full source path. -luke (12/Mar/2005) - :form-path (if tlf (list tlf)) - :file-write-date (sb-c::debug-source-created debug-source) - :plist (sb-c::debug-source-plist debug-source)))) - -(defun translate-source-location (location) - (if location - (make-definition-source - :pathname (let ((n (sb-c:definition-source-location-namestring location))) - (when n - (parse-namestring n))) - :form-path - (let ((number (sb-c:definition-source-location-toplevel-form-number - location))) - (when number - (list number))) - :plist (sb-c:definition-source-location-plist location)) - (make-definition-source))) - -;;; This is kludgey. We expect these functions (the underlying functions, -;;; not the closures) to be in static space and so not move ever. -;;; FIXME It's also possibly wrong: not all structures use these vanilla -;;; accessors, e.g. when the :type option is used -(defvar *struct-slotplace-reader* - (sb-vm::%simple-fun-self #'definition-source-pathname)) -(defvar *struct-slotplace-writer* - (sb-vm::%simple-fun-self #'(setf definition-source-pathname))) -(defvar *struct-predicate* - (sb-vm::%simple-fun-self #'definition-source-p)) - -(defun struct-accessor-p (function) - (let ((self (sb-vm::%simple-fun-self function))) - ;; FIXME there are other kinds of struct accessor. Fill out this list - (member self (list *struct-slotplace-reader* - *struct-slotplace-writer*)))) - -(defun struct-predicate-p (function) - (let ((self (sb-vm::%simple-fun-self function))) - ;; FIXME there may be other structure predicate functions - (member self (list *struct-predicate*)))) - -(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, interpreted functions, -and generic functions. Signals an error if FUNCTION is not a valid extended -function designator." - (cond ((valid-function-name-p function) - (function-lambda-list (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-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))) - (cond - ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*)) - (find-class - (sb-kernel::classoid-name - (sb-kernel::layout-classoid - (sb-kernel:%closure-index-ref function 1))))) - ))) - -(defun struct-predicate-structure-class (function) - (let ((self (sb-vm::%simple-fun-self function))) - (cond - ((member self (list *struct-predicate*)) - (find-class - (sb-kernel::classoid-name - (sb-kernel::layout-classoid - (sb-kernel:%closure-index-ref function 0))))) - ))) - -;;;; find callers/callees, liberated from Helmut Eller's code in SLIME - -;;; This interface is trmendously experimental. - -;;; For the moment I'm taking the view that FDEFN is an internal -;;; object (one out of one CMUCL developer surveyed didn't know what -;;; they were for), so these routines deal in FUNCTIONs - -;;; Find callers and callees by looking at the constant pool of -;;; compiled code objects. We assume every fdefn object in the -;;; constant pool corresponds to a call to that function. A better -;;; strategy would be to use the disassembler to find actual -;;; call-sites. - -(defun find-function-callees (function) - "Return functions called by FUNCTION." - (let ((callees '())) - (map-code-constants - (sb-kernel:fun-code-header function) - (lambda (obj) - (when (sb-kernel:fdefn-p obj) - (push (sb-kernel:fdefn-fun obj) - callees)))) - callees)) - - -(defun find-function-callers (function &optional (spaces '(:read-only :static - :dynamic))) - "Return functions which call FUNCTION, by searching SPACES for code objects" - (let ((referrers '())) - (map-caller-code-components - function - spaces - (lambda (code) - (let ((entry (sb-kernel:%code-entry-points code))) - (cond ((not entry) - (push (princ-to-string code) referrers)) - (t - (loop for e = entry then (sb-kernel::%simple-fun-next e) - while e - do (pushnew e referrers))))))) - referrers)) - -(declaim (inline map-code-constants)) -(defun map-code-constants (code fn) - "Call FN for each constant in CODE's constant pool." - (check-type code sb-kernel:code-component) - (loop for i from sb-vm:code-constants-offset below - (sb-kernel:get-header-data code) - do (funcall fn (sb-kernel:code-header-ref code i)))) - -(declaim (inline map-allocated-code-components)) -(defun map-allocated-code-components (spaces fn) - "Call FN for each allocated code component in one of SPACES. FN -receives the object and its size as arguments. SPACES should be a -list of the symbols :dynamic, :static, or :read-only." - (dolist (space spaces) - (sb-vm::map-allocated-objects - (lambda (obj header size) - (when (= sb-vm:code-header-widetag header) - (funcall fn obj size))) - space - t))) - -(declaim (inline map-caller-code-components)) -(defun map-caller-code-components (function spaces fn) - "Call FN for each code component with a fdefn for FUNCTION in its -constant pool." - (let ((function (coerce function 'function))) - (map-allocated-code-components - spaces - (lambda (obj size) - (declare (ignore size)) - (map-code-constants - obj - (lambda (constant) - (when (and (sb-kernel:fdefn-p constant) - (eq (sb-kernel:fdefn-fun constant) - 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) diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp index c38d9f5..322ca91 100644 --- a/contrib/sb-introspect/test-driver.lisp +++ b/contrib/sb-introspect/test-driver.lisp @@ -1,30 +1,47 @@ -(require :sb-introspect) +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. (defpackage :sb-introspect-test - (:use "SB-INTROSPECT" "CL")) -(in-package :sb-introspect-test) - -(with-compilation-unit (:source-plist (list :test-outer "OUT")) - (load (compile-file (merge-pathnames "test.lisp" *load-pathname*)))) - -(assert (equal (function-lambda-list 'cl-user::one) - '(cl-user::a cl-user::b cl-user::c))) -(assert (equal (function-lambda-list 'the) - '(sb-c::value-type sb-c::form))) + (:use "SB-INTROSPECT" "CL" "SB-RT")) -(assert (equal (function-lambda-list #'(sb-pcl::slow-method cl-user::j (t))) - '(sb-pcl::method-args sb-pcl::next-methods))) - -(let ((source (find-definition-source #'cl-user::one))) - (assert (= (definition-source-file-write-date source) - (file-write-date (merge-pathnames "test.lisp" *load-pathname*)))) - (assert (equal (getf (definition-source-plist source) :test-outer) - "OUT"))) +(in-package :sb-introspect-test) -(let ((plist (definition-source-plist - (find-definition-source #'cl-user::four)))) - (assert (equal (getf plist :test-outer) "OUT")) - (assert (equal (getf plist :test-inner) "IN"))) +(deftest function-lambda-list.1 + (function-lambda-list 'cl-user::one) + (cl-user::a cl-user::b cl-user::c)) + +(deftest function-lambda-list.2 + (function-lambda-list 'the) + (sb-c::value-type sb-c::form)) + +(deftest function-lambda-list.3 + (function-lambda-list #'(sb-pcl::slow-method cl-user::j (t))) + (sb-pcl::method-args sb-pcl::next-methods)) + +(deftest definition-source-plist.1 + (let* ((source (find-definition-source #'cl-user::one)) + (plist (definition-source-plist source))) + (values (= (definition-source-file-write-date source) + (file-write-date "test.lisp")) + (or (equal (getf plist :test-outer) + "OUT") + plist))) + t t) + +(deftest definition-source-plist.2 + (let ((plist (definition-source-plist + (find-definition-source #'cl-user::four)))) + (values (or (equal (getf plist :test-outer) "OUT") + plist) + (or (equal (getf plist :test-inner) "IN") + plist))) + t t) (defun matchp (object form-number) (let ((ds (sb-introspect:find-definition-source object))) @@ -42,50 +59,136 @@ (let ((ds (sb-introspect:find-definition-sources-by-name object type))) (= (length ds) form-numbers))) -(assert (matchp-name :function 'cl-user::one 2)) -(assert (matchp #'cl-user::one 2)) -(assert (matchp-name :generic-function 'cl-user::two 3)) -(assert (matchp (car (sb-pcl:generic-function-methods #'cl-user::two)) 4)) - -(assert (matchp-name :variable 'cl-user::*a* 8)) -(assert (matchp-name :variable 'cl-user::*b* 9)) -(assert (matchp-name :class 'cl-user::a 10)) -(assert (matchp-name :condition 'cl-user::b 11)) -(assert (matchp-name :structure 'cl-user::c 12)) -(assert (matchp-name :function 'cl-user::make-c 12)) -(assert (matchp-name :function 'cl-user::c-e 12)) -(assert (matchp-name :structure 'cl-user::d 13)) -(assert (matchp-name :function 'cl-user::make-d 13)) -(assert (matchp-name :function 'cl-user::d-e 13)) -(assert (matchp-name :package 'cl-user::e 14)) -(assert (matchp-name :symbol-macro 'cl-user::f 15)) -(assert (matchp-name :type 'cl-user::g 16)) -(assert (matchp-name :constant 'cl-user::+h+ 17)) -(assert (matchp-length :method 'cl-user::j 2)) -(assert (matchp-name :macro 'cl-user::l 20)) -(assert (matchp-name :compiler-macro 'cl-user::m 21)) -(assert (matchp-name :setf-expander 'cl-user::n 22)) -(assert (matchp-name :function '(setf cl-user::o) 23)) -(assert (matchp-name :method '(setf cl-user::p) 24)) -(assert (matchp-name :macro 'cl-user::q 25)) -(assert (matchp-name :method-combination 'cl-user::r 26)) -(assert (matchp-name :setf-expander 'cl-user::s 27)) - -(let ((fin (make-instance 'sb-mop:funcallable-standard-object))) - (sb-mop:set-funcallable-instance-function fin #'cl-user::one) - (assert (matchp fin 2))) - -(sb-profile:profile cl-user::one) -(assert (matchp-name :function 'cl-user::one 2)) -(sb-profile:unprofile cl-user::one) - - -;;;; Check correctness of FUNCTION-LAMBDA-LIST. - -(assert (equal (function-lambda-list 'cl-user::one) - '(cl-user::a cl-user::b cl-user::c))) -(assert (equal (function-lambda-list 'the) - '(sb-c::value-type sb-c::form))) +(deftest find-source-stuff.1 + (matchp-name :function 'cl-user::one 2) + t) + +(deftest find-source-stuff.2 + (matchp #'cl-user::one 2) + t) + +(deftest find-source-stuff.3 + (matchp-name :generic-function 'cl-user::two 3) + t) + +(deftest find-source-stuff.4 + (matchp (car (sb-pcl:generic-function-methods #'cl-user::two)) 4) + t) + +(deftest find-source-stuff.5 + (matchp-name :variable 'cl-user::*a* 8) + t) + +(deftest find-source-stuff.6 + (matchp-name :variable 'cl-user::*b* 9) + t) + +(deftest find-source-stuff.7 + (matchp-name :class 'cl-user::a 10) + t) + +(deftest find-source-stuff.8 + (matchp-name :condition 'cl-user::b 11) + t) + +(deftest find-source-stuff.9 + (matchp-name :structure 'cl-user::c 12) + t) + +(deftest find-source-stuff.10 + (matchp-name :function 'cl-user::make-c 12) + t) + +(deftest find-source-stuff.11 + (matchp-name :function 'cl-user::c-e 12) + t) + +(deftest find-source-stuff.12 + (matchp-name :structure 'cl-user::d 13) + t) + +(deftest find-source-stuff.13 + (matchp-name :function 'cl-user::make-d 13) + t) + +(deftest find-source-stuff.14 + (matchp-name :function 'cl-user::d-e 13) + t) + +(deftest find-source-stuff.15 + (matchp-name :package 'cl-user::e 14) + t) + +(deftest find-source-stuff.16 + (matchp-name :symbol-macro 'cl-user::f 15) + t) + +(deftest find-source-stuff.17 + (matchp-name :type 'cl-user::g 16) + t) + +(deftest find-source-stuff.18 + (matchp-name :constant 'cl-user::+h+ 17) + t) + +(deftest find-source-stuff.19 + (matchp-length :method 'cl-user::j 2) + t) + +(deftest find-source-stuff.20 + (matchp-name :macro 'cl-user::l 20) + t) + +(deftest find-source-stuff.21 + (matchp-name :compiler-macro 'cl-user::m 21) + t) + +(deftest find-source-stuff.22 + (matchp-name :setf-expander 'cl-user::n 22) + t) + +(deftest find-source-stuff.23 + (matchp-name :function '(setf cl-user::o) 23) + t) + + +(deftest find-source-stuff.24 + (matchp-name :method '(setf cl-user::p) 24) + t) + + +(deftest find-source-stuff.25 + (matchp-name :macro 'cl-user::q 25) + t) + + +(deftest find-source-stuff.26 + (matchp-name :method-combination 'cl-user::r 26) + t) + + +(deftest find-source-stuff.27 + (matchp-name :setf-expander 'cl-user::s 27) + t) + +(deftest find-source-stuff.28 + (let ((fin (make-instance 'sb-mop:funcallable-standard-object))) + (sb-mop:set-funcallable-instance-function fin #'cl-user::one) + (matchp fin 2)) + t) + +(deftest find-source-stuff.29 + (unwind-protect + (progn + (sb-profile:profile cl-user::one) + (matchp-name :function 'cl-user::one 2)) + (sb-profile:unprofile cl-user::one)) + t) + +(deftest find-source-stuff.30 + ;; Test finding a type that isn't one + (not (find-definition-sources-by-name 'fboundp :type)) + t) ;;; Check wrt. interplay of generic functions and their methods. @@ -101,30 +204,32 @@ ;; ;; (GF.A GF.B &REST GF.REST &KEY GF.K-X M1.K-Z M1.K-Y M2.K-Q) ;; -(multiple-value-bind (required optional restp rest keyp keys allowp - auxp aux morep more-context more-count) - (sb-int:parse-lambda-list (function-lambda-list #'xuuq)) - (assert (equal required '(gf.a gf.b))) - (assert (null optional)) - (assert (and restp (eql rest 'gf.rest))) - (assert (and keyp - (member 'gf.k-X keys) - (member 'm1.k-Y keys) - (member 'm1.k-Z keys) - (member 'm2.k-Q keys))) - (assert (not allowp)) - (assert (and (not auxp) (null aux))) - (assert (and (not morep) (null more-context) (not more-count)))) +(deftest gf-interplay.1 + (multiple-value-bind (required optional restp rest keyp keys allowp + auxp aux morep more-context more-count) + (sb-int:parse-lambda-list (function-lambda-list #'xuuq)) + (and (equal required '(gf.a gf.b)) + (null optional) + (and restp (eql rest 'gf.rest)) + (and keyp + (member 'gf.k-X keys) + (member 'm1.k-Y keys) + (member 'm1.k-Z keys) + (member 'm2.k-Q keys)) + (not allowp) + (and (not auxp) (null aux)) + (and (not morep) (null more-context) (not more-count)))) + t) ;;; Check what happens when there's no explicit DEFGENERIC. (defmethod kroolz (r1 r2 &optional opt &aux aux) (declare (ignore r1 r2 opt aux)) 'kroolz) -(assert (equal (function-lambda-list #'kroolz) '(r1 r2 &optional opt))) -;;;; Test finding a type that isn't one -(assert (not (find-definition-sources-by-name 'fboundp :type))) +(deftest gf-interplay.2 + (equal (function-lambda-list #'kroolz) '(r1 r2 &optional opt)) + t) ;;;; Check correctness of DEFTYPE-LAMBDA-LIST. (deftype foobar-type @@ -132,18 +237,17 @@ (declare (ignore w e r1 r2 o rest k1 k2 k3)) nil) -(assert (multiple-value-bind (arglist found?) (deftype-lambda-list 'foobar-type) +(deftest deftype-lambda-list.1 + (multiple-value-bind (arglist found?) (deftype-lambda-list 'foobar-type) (and found? (equal arglist '(&whole w &environment e - r1 r2 &optional o &rest rest &key k1 k2 k3))))) - -(assert (equal (multiple-value-list (deftype-lambda-list (gensym))) - '(nil nil))) + r1 r2 &optional o &rest rest &key k1 k2 k3)))) + t) - -;;;; Test the xref facility - -(load (merge-pathnames "xref-test.lisp" *load-pathname*)) +(deftest deftype-lambda-list.2 + (equal (multiple-value-list (deftype-lambda-list (gensym))) + '(nil nil)) + t) ;;; Test allocation-information @@ -151,60 +255,78 @@ (multiple-value-bind (kind2 info2) (sb-introspect:allocation-information x) (unless (eq kind kind2) (error "wanted ~S, got ~S" kind kind2)) - (assert (equal info info2)))) - -(tai nil :heap '(:space :static)) -(tai t :heap '(:space :static)) -(tai 42 :immediate nil) -(tai #'cons :heap - #+(and (not ppc) gencgc) - ;; FIXME: This is the canonical GENCGC result, the one below for PPC is - ;; what we get there, but :LARGE T doesn't seem right. Figure out what's - ;; going on. - '(:space :dynamic :generation 6 :write-protected t :pinned nil :large nil) - #+(and ppc gencgc) - '(:space :dynamic :generation 6 :write-protected t :pinned nil :large t) - ;; FIXME: Figure out what's the right cheney-result, and which platforms - ;; return something else. The SPARC version here is what we get there, - ;; but quite possibly that is the result on all non-GENCGC platforms. - #+(and sparc (not gencgc)) - '(:space :read-only) - #+(and (not sparc) (not gencgc)) - '(:space :dynamic)) -#+sb-thread -(let ((x (list 1 2 3))) - (declare (dynamic-extent x)) - (tai x :stack sb-thread:*current-thread*)) + (equal info info2))) + +(deftest allocation-infromation.1 + (tai nil :heap '(:space :static)) + t) + +(deftest allocation-information.2 + (tai t :heap '(:space :static)) + t) + +(deftest allocation-information.3 + (tai 42 :immediate nil) + t) + +(deftest allocation-information.4 + (tai #'cons :heap + #+(and (not ppc) gencgc) + ;; FIXME: This is the canonical GENCGC result, the one below for PPC is + ;; what we get there, but :LARGE T doesn't seem right. Figure out what's + ;; going on. + '(:space :dynamic :generation 6 :write-protected t :pinned nil :large nil) + #+(and ppc gencgc) + '(:space :dynamic :generation 6 :write-protected t :pinned nil :large t) + ;; FIXME: Figure out what's the right cheney-result, and which platforms + ;; return something else. The SPARC version here is what we get there, + ;; but quite possibly that is the result on all non-GENCGC platforms. + #+(and sparc (not gencgc)) + '(:space :read-only) + #+(and (not sparc) (not gencgc)) + '(:space :dynamic)) + t) + #+sb-thread -(progn - (defun thread-tai () +(deftest allocation-information.thread.1 (let ((x (list 1 2 3))) (declare (dynamic-extent x)) - (let ((child (sb-thread:make-thread - (lambda () - (sb-introspect:allocation-information x))))) - (assert (equal (list :stack sb-thread:*current-thread*) - (multiple-value-list (sb-thread:join-thread child))))))) - (thread-tai) - (defun thread-tai2 () - (let* ((sem (sb-thread:make-semaphore)) - (obj nil) - (child (sb-thread:make-thread - (lambda () - (let ((x (list 1 2 3))) - (declare (dynamic-extent x)) - (setf obj x) - (sb-thread:wait-on-semaphore sem))) - :name "child"))) - (loop until obj) - (assert (equal (list :stack child) - (multiple-value-list - (sb-introspect:allocation-information obj)))) - (sb-thread:signal-semaphore sem) - (sb-thread:join-thread child) - nil)) - (thread-tai2)) - -;;;; Unix success convention for exit codes -(sb-ext:quit :unix-status 0) + (tai x :stack sb-thread:*current-thread*)) + t) +#+sb-thread +(progn + (defun thread-tai () + (let ((x (list 1 2 3))) + (declare (dynamic-extent x)) + (let ((child (sb-thread:make-thread + (lambda () + (sb-introspect:allocation-information x))))) + (equal (list :stack sb-thread:*current-thread*) + (multiple-value-list (sb-thread:join-thread child)))))) + + (deftest allocation-information.thread.2 + (thread-tai) + t) + + (defun thread-tai2 () + (let* ((sem (sb-thread:make-semaphore)) + (obj nil) + (child (sb-thread:make-thread + (lambda () + (let ((x (list 1 2 3))) + (declare (dynamic-extent x)) + (setf obj x) + (sb-thread:wait-on-semaphore sem))) + :name "child"))) + (loop until obj) + (assert (equal (list :stack child) + (multiple-value-list + (sb-introspect:allocation-information obj)))) + (sb-thread:signal-semaphore sem) + (sb-thread:join-thread child) + nil)) + + (deftest allocation-information.thread.3 + (thread-tai2) + t)) diff --git a/contrib/sb-introspect/xref-test-data.lisp b/contrib/sb-introspect/xref-test-data.lisp index a23c328..e76fbba 100644 --- a/contrib/sb-introspect/xref-test-data.lisp +++ b/contrib/sb-introspect/xref-test-data.lisp @@ -1,3 +1,17 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(defpackage :sb-introspect-test/xref + (:use "SB-INTROSPECT" "CL" "SB-RT")) + +(in-package :sb-introspect-test/xref) + (defvar *a* nil) (defconstant +z+ 'zzz) diff --git a/contrib/sb-introspect/xref-test.lisp b/contrib/sb-introspect/xref-test.lisp index e197090..dd3b338 100644 --- a/contrib/sb-introspect/xref-test.lisp +++ b/contrib/sb-introspect/xref-test.lisp @@ -1,46 +1,51 @@ -(defpackage :sb-introspect-test/xref - (:use "SB-INTROSPECT" "CL")) +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. (in-package :sb-introspect-test/xref) -(load (compile-file (merge-pathnames "xref-test-data.lisp" *load-pathname*))) - -(labels ((natural< (a b) - (string< (princ-to-string a) (princ-to-string b)))) - (let ((tests '(((sb-introspect::who-calls 'foo) ()) - ((sb-introspect::who-calls 'bar) (xref/1 xref/3)) - ((sb-introspect::who-calls 'xref/1) (xref/2)) - ((sb-introspect::who-calls 'xref/2) - (xref/5 xref/6 xref/8 xref/8 xref/12 - (sb-pcl::fast-method xref/10 - (t t t t t t t t fixnum)) - (sb-pcl::fast-method xref/11 (fixnum)))) - ((sb-introspect::who-calls 'xref/3) - (inline/1 (sb-pcl::fast-method xref/11 (float)))) - ((sb-introspect::who-calls 'xref/4) ()) - ((sb-introspect::who-calls 'xref/5) ()) - ((sb-introspect::who-calls 'xref/6) (xref/7)) - ((sb-introspect::who-calls 'xref/7) ()) - ((sb-introspect::who-calls 'xref/8) ()) - ((sb-introspect::who-calls 'xref/10) ()) - ((sb-introspect::who-calls 'xref/11) ()) - ((sb-introspect::who-calls 'inline/1) (xref/12)) - ((sb-introspect::who-calls 'xref/12) (macro/1)) - ((sb-introspect::who-macroexpands 'macro/1) - (macro-use/1 macro-use/2 macro-use/3 macro-use/4 inline/2)) - ((sb-introspect::who-binds '*a*) (xref/2)) - ((sb-introspect::who-sets '*a*) (xref/2 xref/13)) - ((sb-introspect::who-references '*a*) - (xref/1 xref/2 xref/4 inline/1 xref/14)) - ((sb-introspect::who-references '+z+) - (inline/1))))) - (loop for x in tests - for form = (first x) - for wanted = (sort (second x) #'natural<) - for result = (sort (loop for name in (eval form) - collect (car name)) - #'natural<) - do (assert (equalp wanted result) - nil - "form=~a~%wanted=~a~%result=~a~%" form wanted result)))) - +(deftest xrefs + (labels ((natural< (a b) + (string< (princ-to-string a) (princ-to-string b)))) + (let ((tests '(((sb-introspect::who-calls 'foo) ()) + ((sb-introspect::who-calls 'bar) (xref/1 xref/3)) + ((sb-introspect::who-calls 'xref/1) (xref/2)) + ((sb-introspect::who-calls 'xref/2) + (xref/5 xref/6 xref/8 xref/8 xref/12 + (sb-pcl::fast-method xref/10 + (t t t t t t t t fixnum)) + (sb-pcl::fast-method xref/11 (fixnum)))) + ((sb-introspect::who-calls 'xref/3) + (inline/1 (sb-pcl::fast-method xref/11 (float)))) + ((sb-introspect::who-calls 'xref/4) ()) + ((sb-introspect::who-calls 'xref/5) ()) + ((sb-introspect::who-calls 'xref/6) (xref/7)) + ((sb-introspect::who-calls 'xref/7) ()) + ((sb-introspect::who-calls 'xref/8) ()) + ((sb-introspect::who-calls 'xref/10) ()) + ((sb-introspect::who-calls 'xref/11) ()) + ((sb-introspect::who-calls 'inline/1) (xref/12)) + ((sb-introspect::who-calls 'xref/12) (macro/1)) + ((sb-introspect::who-macroexpands 'macro/1) + (macro-use/1 macro-use/2 macro-use/3 macro-use/4 inline/2)) + ((sb-introspect::who-binds '*a*) (xref/2)) + ((sb-introspect::who-sets '*a*) (xref/2 xref/13)) + ((sb-introspect::who-references '*a*) + (xref/1 xref/2 xref/4 inline/1 xref/14)) + ((sb-introspect::who-references '+z+) + (inline/1))))) + (loop for x in tests + for form = (first x) + for wanted = (sort (second x) #'natural<) + for result = (sort (loop for name in (eval form) + collect (car name)) + #'natural<) + do (unless (equalp wanted result) + (return (format nil "form=~a~%wanted=~a~%result=~a~%" + form wanted result)))))) + nil) diff --git a/version.lisp-expr b/version.lisp-expr index e822dfe..aadb4c2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.30.34" +"1.0.30.35" -- 1.7.10.4