From ab9ae982b1b242fc1b25547b5ef5939ee44aec1c Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 13 Mar 2005 17:44:34 +0000 Subject: [PATCH] 0.8.20.19: Merge sb-introspect improvements from Luke Gorrie (sbcl-devel "Re: definition-source-created in sb-introspect.lisp" 2005-03-13 --- NEWS | 3 + contrib/sb-introspect/Makefile | 2 +- contrib/sb-introspect/sb-introspect.lisp | 240 +++++++++++++++++------------- contrib/sb-introspect/test-driver.lisp | 13 +- version.lisp-expr | 2 +- 5 files changed, 157 insertions(+), 103 deletions(-) diff --git a/NEWS b/NEWS index 2fdd5c5..4caf632 100644 --- a/NEWS +++ b/NEWS @@ -35,6 +35,9 @@ changes in sbcl-0.8.21 (0.9alpha.1?) relative to sbcl-0.8.20: * contrib improvement: the SB-SIMPLE-STREAMS contrib now defines STRING-SIMPLE-STREAM and FILE-SIMPLE-STREAM as subclasses of STRING-STREAM and FILE-STREAM, respectively. + * contrib improvement: SB-INTROSPECT handles more of SLIME's needs + than previously; in addition, its test suite is now run on build. + (thanks to Luke Gorrie) * a more robust x86-64 disassembler. (thanks to Lutz Euler) * fixed some bugs revealed by Paul Dietz' test suite: ** MISC.564: defined out-of-line version of %ATAN2 on x86. diff --git a/contrib/sb-introspect/Makefile b/contrib/sb-introspect/Makefile index 9ebf1a4..525f235 100644 --- a/contrib/sb-introspect/Makefile +++ b/contrib/sb-introspect/Makefile @@ -2,4 +2,4 @@ MODULE=sb-introspect include ../vanilla-module.mk test:: - true + $(SBCL) --disable-debugger --load test-driver.lisp diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index 1ca2d2a..61fe935 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -1,3 +1,5 @@ +;;; 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. @@ -24,8 +26,6 @@ ;;; 5) would be nice to have some interface to the compiler that lets us ;;; fake the filename and position, for use with C-M-x -(declaim (optimize (debug 1))) - (defpackage :sb-introspect (:use "CL") (:export "FUNCTION-ARGLIST" "VALID-FUNCTION-NAME-P" @@ -34,41 +34,118 @@ "DEFINITION-NOT-FOUND" "DEFINITION-NAME" "DEFINITION-SOURCE-FORM-PATH" "DEFINITION-SOURCE-CHARACTER-OFFSET" + "DEFINITION-SOURCE-FILE-WRITE-DATE" "FIND-FUNCTION-CALLEES" "FIND-FUNCTION-CALLERS" )) (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::%closure-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) + (destructuring-bind (debug-source &rest other-debug-sources) + (sb-c::compiled-debug-info-source debug-info) + ;; COMPILED-DEBUG-INFO-SOURCES can return a list but we expect + ;; this to always contain exactly one element in SBCL. The list + ;; interface is inherited from CMUCL. -luke (12/Mar/2005) + (assert (null other-debug-sources)) + debug-source)) + +(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)) -;;; FIXME: maybe this should be renamed as FUNCTION-LAMBDA-LIST? -(defun function-arglist (function) - "Describe the lambda list for the function designator FUNCTION. -Works for special-operators, macros, simple functions and generic -functions. Signals error if not found" - (cond ((valid-function-name-p function) - (function-arglist - (or (macro-function function) (fdefinition function)))) - ((typep function 'generic-function) - (sb-pcl::generic-function-pretty-arglist function)) - (t (sb-impl::%simple-fun-arglist - (sb-impl::%closure-fun function))))) - -(defgeneric find-definition-source (thing) - (:documentation "Find the source location that defines THING. -Returns a DEFINITION-SOURCE object")) - -;;; This is an opaque object with accessors as per export list. -;;; Might not be a struct. +;;;; Finding definitions (defstruct definition-source - pathname ; source file, not fasl - form-path - character-offset - ) + ;; 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))) + +(defun find-definition-source (object) + (etypecase object + (method + (find-definition-source (or (sb-pcl::method-fast-function object) + (sb-pcl:method-function object)))) + (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)))) + (structure-class + (let ((constructor + (sb-kernel::structure-classoid-constructor + (sb-kernel:classoid-cell-classoid + (sb-int:info :type :classoid (class-name object)))))) + (find-definition-source constructor))) + (t + (if (valid-function-name-p object) + (find-definition-source (or (macro-function object) + (fdefinition 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 + (if (eql (sb-c::debug-source-from debug-source) :file) + (parse-namestring (sb-c::debug-source-name 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)))) ;;; This is kludgey. We expect these functions (the underlying functions, ;;; not the closures) to be in static space and so not move ever. @@ -81,47 +158,6 @@ Returns a DEFINITION-SOURCE object")) (defvar *struct-predicate* (sb-vm::%simple-fun-self #'definition-source-p)) -;; Internal-only, don't call this directly -(defun find-function-definition-source (o) - (let* ((debug-info - (sb-kernel:%code-debug-info - (sb-kernel:fun-code-header(sb-kernel::%closure-fun o)))) - (debug-source - (car (sb-c::compiled-debug-info-source debug-info))) - (debug-fun (elt (sb-c::compiled-debug-info-fun-map debug-info) 0)) - (tlf (and debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun)))) - ;; HAZARDOUS ASSUMPTION: in CMUCL it's possible to get >1 debug-source - ;; for a debug-info (one per file). In SBCL the function that builds - ;; debug-sources always produces singleton lists - (sb-int:aver (not (cdr (sb-c::compiled-debug-info-source debug-info)))) - (make-definition-source - :pathname - (and (eql (sb-c::debug-source-from debug-source) :file) - (parse-namestring (sb-c::debug-source-name debug-source))) - ;; we don't have a real sexp path, annoyingly. Fake one from the - ;; top-level form number - :character-offset - (and tlf - (elt (sb-c::debug-source-start-positions debug-source) tlf)) - :form-path (and tlf (list tlf))))) - -(defmethod find-definition-source ((o function)) - (cond - ((struct-accessor-p o) - (find-definition-source (struct-accessor-structure-class o))) - ((struct-predicate-p o) - (find-definition-source (struct-predicate-structure-class o))) - (t (find-function-definition-source o)))) - -(defmethod find-definition-source ((o method)) - (find-definition-source (or (sb-pcl::method-fast-function o) - (sb-pcl:method-function o)))) - -(defmethod find-definition-source (name) - (and (valid-function-name-p name) - (find-definition-source (or (macro-function name) (fdefinition name))))) - -;; these are internal functions, and probably incomplete (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 @@ -133,7 +169,18 @@ Returns a DEFINITION-SOURCE object")) ;; FIXME there may be other structure predicate functions (member self (list *struct-predicate*)))) -;; FIXME need one for constructor too, perhaps +;;; FIXME: maybe this should be renamed as FUNCTION-LAMBDA-LIST? +(defun function-arglist (function) + "Describe the lambda list for the function designator FUNCTION. +Works for special-operators, macros, simple functions and generic +functions. Signals error if not found" + (cond ((valid-function-name-p function) + (function-arglist + (or (macro-function function) (fdefinition function)))) + ((typep function 'generic-function) + (sb-pcl::generic-function-pretty-arglist function)) + (t (sb-impl::%simple-fun-arglist + (sb-impl::%closure-fun function))))) (defun struct-accessor-structure-class (function) (let ((self (sb-vm::%simple-fun-self function))) @@ -155,14 +202,6 @@ Returns a DEFINITION-SOURCE object")) (sb-kernel:%closure-index-ref function 0))))) ))) -(defmethod find-definition-source ((o structure-class)) - ;; FIXME we don't get form-number from this, which is a shame - (let ((constructor - (sb-kernel::structure-classoid-constructor - (sb-kernel:classoid-cell-classoid - (sb-int:info :type :classoid (class-name o)))))) - (find-definition-source constructor))) - ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME ;;; This interface is trmendously experimental. @@ -177,14 +216,6 @@ Returns a DEFINITION-SOURCE object")) ;;; strategy would be to use the disassembler to find actual ;;; call-sites. -(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)))) - (defun find-function-callees (function) "Return functions called by FUNCTION." (let ((callees '())) @@ -196,6 +227,32 @@ Returns a DEFINITION-SOURCE object")) 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 @@ -225,21 +282,4 @@ constant pool." function)) (funcall fn obj)))))))) -(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)) - (provide 'sb-introspect) diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp index 5068d8c..334b489 100644 --- a/contrib/sb-introspect/test-driver.lisp +++ b/contrib/sb-introspect/test-driver.lisp @@ -1,18 +1,29 @@ +(require :sb-introspect) + (defpackage :sb-introspect-test (:use "SB-INTROSPECT" "CL")) +(in-package :sb-introspect-test) + (load (compile-file (merge-pathnames "test.lisp" *load-pathname*))) (assert (equal (function-arglist 'cl-user::one) '(cl-user::a cl-user::b cl-user::c))) (assert (equal (function-arglist 'the) '(type sb-c::value))) +(assert (= (definition-source-file-write-date + (find-definition-source 'cl-user::one)) + (file-write-date (merge-pathnames "test.lisp" *load-pathname*)))) (defun matchp (object form-number) (let ((ds (sb-introspect:find-definition-source object))) (and (pathnamep (sb-introspect:definition-source-pathname ds)) - (= form-number (sb-introspect:definition-source-form-number ds))))) + (= form-number + (first (sb-introspect:definition-source-form-path ds)))))) (assert (matchp 'cl-user::one 2)) (assert (matchp #'cl-user::one 2)) ; (assert (matchp 'two 2)) ; defgenerics don't work yet (assert (matchp (car (sb-pcl:generic-function-methods #'cl-user::two)) 4)) + +;;; Unix success convention for exit codes +(sb-ext:quit :unix-status 0) diff --git a/version.lisp-expr b/version.lisp-expr index 0bca51a..394b37b 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".) -"0.8.20.18" +"0.8.20.19" -- 1.7.10.4