Menu
▾
▴
[Sbcl-commits] CVS: sbcl/contrib/sb-introspect introspect.lisp, NONE, 1.1 sb-introspect.asd, NONE, 1.1 Makefile, 1.2, 1.3 test-driver.lisp, 1.17, 1.18 xref-test-data.lisp, 1.2, 1.3 xref-test.lisp, 1.2, 1.3 sb-introspect.lisp, 1.36, NONE
Update of /cvsroot/sbcl/sbcl/contrib/sb-introspect In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv29666/contrib/sb-introspect Modified Files: Makefile test-driver.lisp xref-test-data.lisp xref-test.lisp Added Files: introspect.lisp sb-introspect.asd Removed Files: sb-introspect.lisp Log Message: 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. --- NEW FILE: introspect.lisp --- ;;; 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))))) --- NEW FILE: sb-introspect.asd --- ;;; -*- 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))) Index: Makefile =================================================================== RCS file: /cvsroot/sbcl/sbcl/contrib/sb-introspect/Makefile,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- Makefile 13 Mar 2005 17:44:36 -0000 1.2 +++ Makefile 5 Aug 2009 12:11:43 -0000 1.3 @@ -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 Index: test-driver.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/contrib/sb-introspect/test-driver.lisp,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- test-driver.lisp 21 Jun 2009 12:16:04 -0000 1.17 +++ test-driver.lisp 5 Aug 2009 12:11:43 -0000 1.18 @@ -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")) + (:use "SB-INTROSPECT" "CL" "SB-RT")) + (in-package :sb-introspect-test) -(with-compilation-unit (:source-plist (list :test-outer "OUT")) - (load (compile-file (merge-pathnames "test.lisp" *load-pathname*)))) +(deftest function-lambda-list.1 + (function-lambda-list 'cl-user::one) + (cl-user::a cl-user::b cl-user::c)) -(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 function-lambda-list.2 + (function-lambda-list 'the) + (sb-c::value-type sb-c::form)) -(assert (equal (function-lambda-list #'(sb-pcl::slow-method cl-user::j (t))) - '(sb-pcl::method-args sb-pcl::next-methods))) +(deftest function-lambda-list.3 + (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"))) +(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) -(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 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)) +(deftest find-source-stuff.1 + (matchp-name :function 'cl-user::one 2) + t) -(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)) +(deftest find-source-stuff.2 + (matchp #'cl-user::one 2) + t) -(let ((fin (make-instance 'sb-mop:funcallable-standard-object))) - (sb-mop:set-funcallable-instance-function fin #'cl-user::one) - (assert (matchp fin 2))) +(deftest find-source-stuff.3 + (matchp-name :generic-function 'cl-user::two 3) + t) -(sb-profile:profile cl-user::one) -(assert (matchp-name :function 'cl-user::one 2)) -(sb-profile:unprofile cl-user::one) +(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) -;;;; Check correctness of FUNCTION-LAMBDA-LIST. +(deftest find-source-stuff.6 + (matchp-name :variable 'cl-user::*b* 9) + t) -(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.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))) - - -;;;; Test the xref facility + r1 r2 &optional o &rest rest &key k1 k2 k3)))) + t) -(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)))) + (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) -(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*)) #+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)) + (tai x :stack sb-thread:*current-thread*)) + t) -;;;; Unix success convention for exit codes -(sb-ext:quit :unix-status 0) +#+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)) Index: xref-test-data.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/contrib/sb-introspect/xref-test-data.lisp,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- xref-test-data.lisp 29 Jan 2008 12:51:28 -0000 1.2 +++ xref-test-data.lisp 5 Aug 2009 12:11:43 -0000 1.3 @@ -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) Index: xref-test.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/contrib/sb-introspect/xref-test.lisp,v retrieving revision 1.2 retrieving revision 1.3 diff -u -d -r1.2 -r1.3 --- xref-test.lisp 29 Jan 2008 12:51:28 -0000 1.2 +++ xref-test.lisp 5 Aug 2009 12:11:43 -0000 1.3 @@ -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) --- sb-introspect.lisp DELETED --- |