From 31f072311935e32751508ecf824905c6b58a1d95 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Sun, 6 Nov 2005 08:40:28 +0000 Subject: [PATCH] 0.9.6.25: Have you ever tried jumping to the definition of a method combination with M-. only to be thwarted by Slime/SBCL? Yeah, me neither... * Record source location information for all definition forms. (Except when (AND (> SPACE DEBUG) (> SPACE 1))). * On by default, can be disabled by removing :SB-SOURCE-LOCATIONS from build-features (if you really want to save that last 60kB of space...) * Add structure SB-C:DEFINITION-SOURCE-LOCATION for saving the source locations * Annotate all definition form macros with calls to SB-C:SOURCE-LOCATION, which is compiler-macro-expanded to a D-S-L instance and saved into an appropriate place. * For cases where no appropriate place exists, add new info class :SOURCE-LOCATION. * Some trickery required to get the source locations recorded for early definitions. * SB-INTROSPECT:FIND-DEFINITION-SOURCE no longer tries to guess what definition to search for when given a symbol. (I don't feel too bad about this, since the interface is explicitly not supported yet). * New function SB-INTROSPECT:FIND-DEFINITION-SOURCES-BY-NAME for querying, e.g (FIND-DEFINITION-SOURCES-BY-NAME '*FOO* :VARIABLE). Returns a list of locations (to support things like (F-D-S-B-N 'FOO :METHOD) or (F-D-S-B-N 'foo :VOP)). * Stalate the fasls. --- base-target-features.lisp-expr | 5 + build-order.lisp-expr | 5 + contrib/sb-introspect/sb-introspect.lisp | 236 +++++++++++++++++++++++++++--- contrib/sb-introspect/test-driver.lisp | 44 +++++- contrib/sb-introspect/test.lisp | 53 +++++++ package-data-list.lisp-expr | 10 +- src/code/class.lisp | 4 +- src/code/condition.lisp | 9 +- src/code/defboot.lisp | 21 ++- src/code/defpackage.lisp | 8 +- src/code/defstruct.lisp | 10 +- src/code/early-fasl.lisp | 4 +- src/code/early-source-location.lisp | 46 ++++++ src/code/macros.lisp | 6 +- src/code/package.lisp | 4 +- src/code/source-location.lisp | 65 ++++++++ src/compiler/debug-dump.lisp | 17 +-- src/compiler/defconstant.lisp | 7 +- src/compiler/generic/genesis.lisp | 2 +- src/compiler/globaldb.lisp | 27 ++++ src/pcl/boot.lisp | 33 +++-- src/pcl/braid.lisp | 4 +- src/pcl/defclass.lisp | 13 +- src/pcl/defcombin.lisp | 17 +-- src/pcl/defs.lisp | 6 +- src/pcl/std-class.lisp | 5 +- version.lisp-expr | 2 +- 27 files changed, 564 insertions(+), 99 deletions(-) create mode 100644 src/code/early-source-location.lisp create mode 100644 src/code/source-location.lisp diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index a760984..3523114 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -173,6 +173,11 @@ ;; character set. :sb-unicode + ;; Record source location information for variables, classes, conditions, + ;; packages, etc. Gives much better information on M-. in Slime, but + ;; increases core size by about 100kB. + :sb-source-locations + ;; This affects the definition of a lot of things in bignum.lisp. It ;; doesn't seem to be documented anywhere what systems it might apply ;; to. It doesn't seem to be needed for X86 systems anyway. diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 380b26a..f923961 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -39,6 +39,10 @@ ;; This comes early because it's useful for debugging everywhere. ("src/code/show") + ;; This comes as early as possible, so that we catch the source locations + ;; for everything. + ("src/code/early-source-location") + ;; This comes early because the cross-compilation host's backquote ;; logic can expand into something which can't be executed on the ;; target Lisp (e.g. in CMU CL where it expands into internal @@ -474,6 +478,7 @@ ("src/compiler/dump") ("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp + ("src/code/source-location") ("src/compiler/target-main" :not-host) ("src/compiler/ir1tran") ("src/compiler/ir1tran-lambda") diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index c48eb28..a9af9c4 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -18,19 +18,16 @@ ;;; TODO ;;; 1) structs don't have within-file location info. problem for the ;;; structure itself, accessors and the predicate -;;; 2) what should find-definition-source on a symbol return? there may be -;;; several definitions (class, function, etc) ;;; 3) error handling. Signal random errors, or handle and resignal 'our' ;;; error, or return NIL? ;;; 4) FIXMEs -;;; 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 (defpackage :sb-introspect (:use "CL") (:export "FUNCTION-ARGLIST" "VALID-FUNCTION-NAME-P" "FIND-DEFINITION-SOURCE" + "FIND-DEFINITION-SOURCES-BY-NAME" "DEFINITION-SOURCE" "DEFINITION-SOURCE-PATHNAME" "DEFINITION-SOURCE-FORM-PATH" @@ -104,29 +101,214 @@ include the pathname of the file and the position of the definition." ;; Null if not compiled from a file. (file-write-date nil :type (or null integer)) ;; plist from WITH-COMPILATION-UNIT - (plist nil)) + (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)))) + (listify + (case type + ((:variable) + (when (eq (sb-int:info :variable :kind name) :special) + (translate-source-location (sb-int:info :source-location type name)))) + ((:constant) + (when (eq (sb-int:info :variable :kind name) :constant) + (translate-source-location (sb-int:info :source-location type name)))) + ((:symbol-macro) + (when (eq (sb-int:info :variable :kind name) :macro) + (translate-source-location (sb-int:info :source-location type name)))) + ((:macro) + (when (and (symbolp name) + (macro-function name)) + (find-definition-source (macro-function name)))) + ((:compiler-macro) + (when (compiler-macro-function name) + (find-definition-source (compiler-macro-function name)))) + ((:function :generic-function) + (when (and (fboundp name) + (or (not (symbolp name)) + (not (macro-function name)))) + (let ((fun (fdefinition name))) + (when (eq (not (typep fun 'generic-function)) + (not (eq type :generic-function))) + (find-definition-source fun))))) + ((:type) + (let ((expander-fun (sb-int:info :type :expander name))) + (when expander-fun + (find-definition-source expander-fun)))) + ((:method) + (when (and (fboundp name) + (typep (fdefinition name) 'generic-function)) + (loop for method in (sb-mop::generic-function-methods + (fdefinition name)) + for source = (find-definition-source method) + when source collect source))) + ((:setf-expander) + (when (and (consp name) + (eq (car name) 'setf)) + (setf name (cadr name))) + (let ((expander-fun (or (sb-int:info :setf :inverse name) + (sb-int:info :setf :expander name)))) + (when expander-fun + (sb-introspect:find-definition-source expander-fun)))) + ((:structure) + (let ((class (ignore-errors (find-class name)))) + (if class + (when (typep class 'sb-pcl::structure-class) + (find-definition-source class)) + (when (sb-int:info :typed-structure :info name) + (translate-source-location + (sb-int:info :source-location :typed-structure name)))))) + ((:condition :class) + (let ((class (ignore-errors (find-class name)))) + (when class + (when (eq (not (typep class 'sb-pcl::condition-class)) + (not (eq type :condition))) + (find-definition-source class))))) + ((:method-combination) + (let ((combination-fun + (ignore-errors (find-method #'sb-mop:find-method-combination + nil + (list (find-class 'generic-function) + (list 'eql name) + t))))) + (when combination-fun + (find-definition-source combination-fun)))) + ((:package) + (when (symbolp name) + (let ((package (find-package name))) + (when package + (find-definition-source package))))) + ;;; TRANSFORM and OPTIMIZER handling from swank-sbcl + ((:transform) + (let ((fun-info (sb-int:info :function :info name))) + (when fun-info + (loop for xform in (sb-c::fun-info-transforms fun-info) + for source = (find-definition-source + (sb-c::transform-function xform)) + for typespec = (sb-kernel:type-specifier + (sb-c::transform-type xform)) + for note = (sb-c::transform-note xform) + do (setf (definition-source-description source) + (if (consp typespec) + (list (second typespec) note) + (list note))) + collect source)))) + ((:optimizer) + (let ((fun-info (sb-int:info :function :info name))) + (when fun-info + (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type) + (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate) + (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate) + (sb-c::fun-info-optimizer . sb-c:optimizer)))) + (loop for (reader . name) in otypes + for fn = (funcall reader fun-info) + when fn collect + (let ((source (find-definition-source fn))) + (setf (definition-source-description source) + (list name)) + source)))))) + ((:vop) + (let ((fun-info (sb-int:info :function :info name))) + (when fun-info + (loop for vop in (sb-c::fun-info-templates fun-info) + for source = (find-definition-source + (sb-c::vop-info-generator-function vop)) + do (setf (definition-source-description source) + (list (sb-c::template-name vop) + (sb-c::template-note vop))) + collect source)))) + ((:source-transform) + (let ((transform-fun (sb-int:info :function :source-transform name))) + (when transform-fun + (sb-introspect:find-definition-source transform-fun)))) + (t + nil))))) (defun find-definition-source (object) - (etypecase 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 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 - (find-definition-source (or (sb-pcl::method-fast-function object) - (sb-pcl:method-function object)))) + (let ((source (translate-source-location + (sb-pcl::definition-source object)))) + (when source + (setf (definition-source-description source) + (append (method-qualifiers object) + (sb-pcl::unparse-specializers + (sb-mop:method-specializers object))))) + source)) (function (cond ((struct-accessor-p object) - (find-definition-source (struct-accessor-structure-class 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))) + (find-definition-source + (struct-predicate-structure-class object))) + (t + (find-function-definition-source object)))) (t - (if (valid-function-name-p object) - (find-definition-source (or (macro-function object) - (fdefinition object))))))) + (error "Don't know how to retrive source location for a ~S~%" + (type-of object))))) (defun find-function-definition-source (function) (let* ((debug-info (function-debug-info function)) @@ -147,6 +329,20 @@ include the pathname of the file and the position of the definition." :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 diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp index b93d3de..f647fab 100644 --- a/contrib/sb-introspect/test-driver.lisp +++ b/contrib/sb-introspect/test-driver.lisp @@ -12,13 +12,14 @@ (assert (equal (function-arglist 'the) '(type sb-c::value))) -(let ((source (find-definition-source 'cl-user::one))) +(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"))) -(let ((plist (definition-source-plist (find-definition-source 'cl-user::four)))) +(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"))) @@ -28,10 +29,45 @@ (= form-number (first (sb-introspect:definition-source-form-path ds)))))) -(assert (matchp 'cl-user::one 2)) +(defun matchp-name (type object form-number) + (let ((ds (car (sb-introspect:find-definition-sources-by-name object type)))) + (and (pathnamep (sb-introspect:definition-source-pathname ds)) + (= form-number + (first (sb-introspect:definition-source-form-path ds)))))) + +(defun matchp-length (type object form-numbers) + (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 'two 2)) ; defgenerics don't work yet +(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)) + + ;;; Unix success convention for exit codes (sb-ext:quit :unix-status 0) diff --git a/contrib/sb-introspect/test.lisp b/contrib/sb-introspect/test.lisp index 0afafe5..1b66b2b 100644 --- a/contrib/sb-introspect/test.lisp +++ b/contrib/sb-introspect/test.lisp @@ -12,3 +12,56 @@ (with-compilation-unit (:source-plist (list :test-inner "IN")) (eval '(defun four () 4))) + +"oops-off-by-one" + +(defparameter *a* 1) + +(defvar *b* 2) + +(defclass a () + (a)) + +(define-condition b (warning) (a)) + +(defstruct c e f) + +(defstruct (d (:type list)) e f) + +(defpackage e (:use :cl)) + +(define-symbol-macro f 'e) + +(deftype g () 'fixnum) + +(defconstant +h+ 1) + +(defmethod j ((a t)) + 2) + +(defmethod j ((b null)) + 2) + +(defmacro l (a) + a) + +(define-compiler-macro m (a) + (declare (ignore a)) + 'b) + +(defsetf n (a) (store) + (format t "~a ~a~%" a store)) + +(defun (setf o) (x) + (print x)) + +(defmethod (setf p) (x y) + (format t "~a ~a~%" x y)) + +(define-modify-macro q (x) logand) + +(define-method-combination r nil) + +(define-setf-expander s (a b) + (format t "~a ~a~%" a b)) + diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 1002431..f951683 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -248,6 +248,10 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS" "DEFINE-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE" "DEFINE-ASSEMBLY-ROUTINE" + "DEFINITION-SOURCE-LOCATION" + "DEFINITION-SOURCE-LOCATION-NAMESTRING" + "DEFINITION-SOURCE-LOCATION-TOPLEVEL-FORM-NUMBER" + "DEFINITION-SOURCE-LOCATION-PLIST" "DEFINE-MODULAR-FUN" "DEFINE-MOVE-FUN" "DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE" @@ -307,6 +311,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "SC-OFFSET-OFFSET" "SC-OFFSET-SCN" "SC-OR-LOSE" "SC-P" "SC-SB" "SET-UNWIND-PROTECT" "SET-VECTOR-SUBTYPE" "SETUP-CLOSURE-ENVIRONMENT" "SETUP-ENVIRONMENT" + "SOURCE-LOCATION" "SOURCE-TRANSFORM-LAMBDA" "SPECIFY-SAVE-TN" "TAIL-CALL" "TAIL-CALL-NAMED" @@ -364,7 +369,10 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "VM-SUPPORT-ROUTINES-GENERATE-CALL-SEQUENCE" "VM-SUPPORT-ROUTINES-GENERATE-RETURN-SEQUENCE" "VM-SUPPORT-ROUTINES-EMIT-NOP" - "VM-SUPPORT-ROUTINES-LOCATION-NUMBER")) + "VM-SUPPORT-ROUTINES-LOCATION-NUMBER" + + "WITH-SOURCE-LOCATION" + "*SOURCE-LOCATION-THUNKS*")) #s(sb-cold:package-data :name "SB!DEBUG" diff --git a/src/code/class.lisp b/src/code/class.lisp index 4cd2a92..a1099ec 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -199,7 +199,9 @@ (pure nil :type (member t nil 0)) ;; Number of raw words at the end. ;; This slot is known to the C runtime support code. - (n-untagged-slots 0 :type index)) + (n-untagged-slots 0 :type index) + ;; Definition location + (source-location nil)) (def!method print-object ((layout layout) stream) (print-unreadable-object (layout stream :type t :identity t) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index a9f9fe8..c0f051d 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -392,10 +392,14 @@ (condition-writer-function condition new-value slot-name)))) (defun %define-condition (name parent-types layout slots documentation - report default-initargs all-readers all-writers) + report default-initargs all-readers all-writers + source-location) (with-single-package-locked-error (:symbol name "defining ~A as a condition") (%compiler-define-condition name parent-types layout all-readers all-writers) + (sb!c:with-source-location (source-location) + (setf (layout-source-location layout) + source-location)) (let ((class (find-classoid name))) (setf (condition-classoid-slots class) slots) (setf (condition-classoid-report class) report) @@ -564,7 +568,8 @@ ,report (list ,@default-initargs) ',(all-readers) - ',(all-writers))))))) + ',(all-writers) + (sb!c:source-location))))))) ;;;; DESCRIBE on CONDITIONs diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index f87d263..b7d3c0f 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -19,6 +19,7 @@ ;;;; files for more information. (in-package "SB!IMPL") + ;;;; IN-PACKAGE @@ -200,10 +201,12 @@ #-sb-xc-host ,named-lambda #+sb-xc-host (fdefinition ',name) ,doc - ',inline-lambda)))))) + ',inline-lambda + (sb!c:source-location))))))) #-sb-xc-host -(defun %defun (name def doc inline-lambda) +(defun %defun (name def doc inline-lambda source-location) + (declare (ignore source-location)) (declare (type function def)) (declare (type (or null simple-string) doc)) (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN @@ -235,7 +238,9 @@ (eval-when (:compile-toplevel) (%compiler-defvar ',var)) (eval-when (:load-toplevel :execute) - (%defvar ',var (unless (boundp ',var) ,val) ',valp ,doc ',docp)))) + (%defvar ',var (unless (boundp ',var) ,val) + ',valp ,doc ',docp + (sb!c:source-location))))) (defmacro-mundanely defparameter (var val &optional (doc nil docp)) #!+sb-doc @@ -248,27 +253,31 @@ (eval-when (:compile-toplevel) (%compiler-defvar ',var)) (eval-when (:load-toplevel :execute) - (%defparameter ',var ,val ,doc ',docp)))) + (%defparameter ',var ,val ,doc ',docp (sb!c:source-location))))) (defun %compiler-defvar (var) (sb!xc:proclaim `(special ,var))) #-sb-xc-host -(defun %defvar (var val valp doc docp) +(defun %defvar (var val valp doc docp source-location) (%compiler-defvar var) (when valp (unless (boundp var) (set var val))) (when docp (setf (fdocumentation var 'variable) doc)) + (sb!c:with-source-location (source-location) + (setf (info :source-location :variable var) source-location)) var) #-sb-xc-host -(defun %defparameter (var val doc docp) +(defun %defparameter (var val doc docp source-location) (%compiler-defvar var) (set var val) (when docp (setf (fdocumentation var 'variable) doc)) + (sb!c:with-source-location (source-location) + (setf (info :source-location :variable var) source-location)) var) ;;;; iteration constructs diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index 01d38ce..1d6a191 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -142,7 +142,8 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) (%defpackage ,(stringify-name package "package") ',nicknames ',size ',shadows ',shadowing-imports ',(if use-p use :default) - ',imports ',interns ',exports ',implement ',lock ',doc)))) + ',imports ',interns ',exports ',implement ',lock ',doc + (sb!c:source-location))))) (defun check-disjoint (&rest args) ;; An arg is (:key . set) @@ -172,7 +173,8 @@ names)) (defun %defpackage (name nicknames size shadows shadowing-imports - use imports interns exports implement lock doc-string) + use imports interns exports implement lock doc-string + source-location) (declare (type simple-string name) (type list nicknames shadows shadowing-imports imports interns exports) @@ -188,6 +190,8 @@ :use nil :internal-symbols (or size 10) :external-symbols (length exports)))))) + (sb!c:with-source-location (source-location) + (setf (package-source-location package) source-location)) (unless (string= (the string (package-name package)) name) (error 'simple-package-error :package name diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 5ba663c..2cd30d7 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -360,7 +360,7 @@ ;; class. (with-single-package-locked-error (:symbol ',name "defining ~A as a structure")) - (%defstruct ',dd ',inherits) + (%defstruct ',dd ',inherits (sb!c:source-location)) (eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-defstruct ',dd ',inherits)) ,@(unless expanding-into-code-for-xc-host-p @@ -376,6 +376,9 @@ (:symbol ',name "defining ~A as a structure")) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (info :typed-structure :info ',name) ',dd)) + (eval-when (:load-toplevel :execute) + (setf (info :source-location :typed-structure ',name) + (sb!c:source-location))) ,@(unless expanding-into-code-for-xc-host-p (append (typed-accessor-definitions dd) (typed-predicate-definitions dd) @@ -858,7 +861,7 @@ ;;; incompatible redefinition. Define those functions which are ;;; sufficiently stereotyped that we can implement them as standard ;;; closures. -(defun %defstruct (dd inherits) +(defun %defstruct (dd inherits source-location) (declare (type defstruct-description dd)) ;; We set up LAYOUTs even in the cross-compilation host. @@ -878,6 +881,9 @@ (setq layout (classoid-layout classoid)))) (setf (find-classoid (dd-name dd)) classoid) + (sb!c:with-source-location (source-location) + (setf (layout-source-location layout) source-location)) + ;; Various other operations only make sense on the target SBCL. #-sb-xc-host (%target-defstruct dd layout)) diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index b1734d2..52a21aa 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -76,7 +76,7 @@ ;;; versions which break binary compatibility. But it certainly should ;;; be incremented for release versions which break binary ;;; compatibility. -(def!constant +fasl-file-version+ 60) +(def!constant +fasl-file-version+ 61) ;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so) ;;; 38: (2003-01-05) changed names of internal SORT machinery ;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to @@ -126,6 +126,8 @@ ;;; 59: (2005-09-18) METAOBJECT implementation, removal of INSTANCE and ;;; FUNCALLABLE-INSTANCE classes. ;;; 60: (2005-10-24) Bumped for 0.9.6 +;;; 61: (2005-11-06) Improved source location recording added extra parameters +;;; to multiple %DEFMUMBLE functions. ;;; the conventional file extension for our fasl files (declaim (type simple-string *fasl-file-type*)) diff --git a/src/code/early-source-location.lisp b/src/code/early-source-location.lisp new file mode 100644 index 0000000..022af85 --- /dev/null +++ b/src/code/early-source-location.lisp @@ -0,0 +1,46 @@ +;;;; Minimal implementation of the source-location tracking machinery, which +;;;; defers the real work to until source-location.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. + +(in-package "SB!C") + +(defvar *source-location-thunks* nil) + +;; Should get called only in unusual circumstances. Normally handled +;; by a compiler macro. +(defun source-location () + nil) + +;; Will be redefined in src/code/source-location.lisp +#-sb-xc-host +(define-compiler-macro source-location () + (when (and (boundp '*source-info*) + (symbol-value '*source-info*)) + `(cons ,(make-file-info-namestring + *compile-file-pathname* + (source-info-file-info (symbol-value '*source-info*))) + ,(when (boundp '*current-path*) + (source-path-tlf-number (symbol-value '*current-path*)))))) + +;; If the whole source location tracking machinery has been loaded +;; (detected by the type of SOURCE-LOCATION), execute BODY. Otherwise +;; wrap it in a lambda and execute later. +(defmacro with-source-location ((source-location) &body body) + `(when ,source-location + (if (consp ,source-location) + (push (lambda () + (let ((,source-location + (make-definition-source-location + :namestring (car ,source-location) + :toplevel-form-number (cdr ,source-location)))) + ,@body)) + *source-location-thunks*) + ,@body))) diff --git a/src/code/macros.lisp b/src/code/macros.lisp index b860377..856edea 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -72,15 +72,17 @@ (defmacro-mundanely define-symbol-macro (name expansion) `(eval-when (:compile-toplevel :load-toplevel :execute) - (sb!c::%define-symbol-macro ',name ',expansion))) + (sb!c::%define-symbol-macro ',name ',expansion (sb!c:source-location)))) -(defun sb!c::%define-symbol-macro (name expansion) +(defun sb!c::%define-symbol-macro (name expansion source-location) (unless (symbolp name) (error 'simple-type-error :datum name :expected-type 'symbol :format-control "Symbol macro name is not a symbol: ~S." :format-arguments (list name))) (with-single-package-locked-error (:symbol name "defining ~A as a symbol-macro")) + (sb!c:with-source-location (source-location) + (setf (info :source-location :symbol-macro name) source-location)) (ecase (info :variable :kind name) ((:macro :global nil) (setf (info :variable :kind name) :macro) diff --git a/src/code/package.lisp b/src/code/package.lisp index c636fdd..4bed38b 100644 --- a/src/code/package.lisp +++ b/src/code/package.lisp @@ -104,7 +104,9 @@ #!+sb-package-locks (lock nil :type boolean) #!+sb-package-locks - (%implementation-packages nil :type list)) + (%implementation-packages nil :type list) + ;; Definition source location + (source-location nil :type (or null sb!c:definition-source-location))) ;;;; iteration macros diff --git a/src/code/source-location.lisp b/src/code/source-location.lisp new file mode 100644 index 0000000..b96898b --- /dev/null +++ b/src/code/source-location.lisp @@ -0,0 +1,65 @@ +;;;; Source location tracking. + +;;;; 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!C") + +(def!struct (definition-source-location + (:make-load-form-fun sb!kernel:just-dump-it-normally)) + ;; Namestring of the source file that the definition was compiled from. + ;; This is null if the definition was not compiled from a file. + (namestring + (when (and (boundp '*source-info*) + *source-info*) + (make-file-info-namestring *compile-file-pathname* + (source-info-file-info *source-info*))) + :type (or string null)) + ;; Toplevel form index + (toplevel-form-number + (when (boundp '*current-path*) + (source-path-tlf-number *current-path*)) + :type (or fixnum null)) + ;; plist from WITH-COMPILATION-UNIT + (plist *source-plist*)) + +(defun make-file-info-namestring (name file-info) + (let* ((untruename (file-info-untruename file-info)) + (dir (and untruename (pathname-directory untruename)))) + #+sb-xc-host + (let ((src (position "src" dir :test #'string= + :from-end t))) + (if src + (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP" + (subseq dir src) (pathname-name untruename)) + ;; FIXME: just output/stuff-groveled-from-headers.lisp + (namestring untruename))) + #-sb-xc-host + (if (and dir (eq (first dir) :absolute)) + (namestring untruename) + (if name + (namestring name) + nil)))) + +#!+sb-source-locations +(define-compiler-macro source-location (&environment env) + #-sb-xc-host + (unless (policy env (and (> space 1) + (> space debug))) + (make-definition-source-location))) + +(/show0 "/Processing source location thunks") +#!+sb-source-locations +(dolist (fun *source-location-thunks*) + (/show0 ".") + (funcall fun)) +;; Unbind the symbol to ensure that we detect any attempts to add new +;; thunks after this. +(makunbound '*source-location-thunks*) +(/show0 "/Done with source location thunks") diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index b098797..82c128c 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -255,21 +255,8 @@ (setf (debug-source-from res) name (debug-source-name res) (file-info-forms file-info))) (pathname - (let* ((untruename (file-info-untruename file-info)) - (dir (pathname-directory untruename))) - (setf (debug-source-name res) - #+sb-xc-host - (let ((src (position "src" dir :test #'string= :from-end t))) - (if src - (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP" - (subseq dir src) (pathname-name untruename)) - ;; FIXME: just output/stuff-groveled-from-headers.lisp - (namestring untruename))) - #-sb-xc-host - (namestring - (if (and dir (eq (first dir) :absolute)) - untruename - name)))))) + (setf (debug-source-name res) + (make-file-info-namestring name file-info)))) res)) ;;; Given an arbitrary sequence, coerce it to an unsigned vector if diff --git a/src/compiler/defconstant.lisp b/src/compiler/defconstant.lisp index 403db52..735f29a 100644 --- a/src/compiler/defconstant.lisp +++ b/src/compiler/defconstant.lisp @@ -16,10 +16,11 @@ EQL to the new value, the code is not portable (undefined behavior). The third argument is an optional documentation string for the variable." `(eval-when (:compile-toplevel :load-toplevel :execute) - (sb!c::%defconstant ',name ,value ',documentation))) + (sb!c::%defconstant ',name ,value ',documentation + (sb!c:source-location)))) ;;; the guts of DEFCONSTANT -(defun sb!c::%defconstant (name value doc) +(defun sb!c::%defconstant (name value doc source-location) (unless (symbolp name) (error "The constant name is not a symbol: ~S" name)) (about-to-modify-symbol-value name) @@ -27,6 +28,8 @@ (style-warn "defining ~S as a constant, even though the name follows~@ the usual naming convention (names like *FOO*) for special variables" name)) + (sb!c:with-source-location (source-location) + (setf (info :source-location :constant name) source-location)) (let ((kind (info :variable :kind name))) (case kind (:constant diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 4ba0bc2..8d6a047 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -854,7 +854,7 @@ core and return a descriptor to it." ;;; FIXME: This information should probably be pulled out of the ;;; cross-compiler's tables at genesis time instead of inserted by ;;; hand here as a bare numeric constant. -(defconstant target-layout-length 17) +(defconstant target-layout-length 18) ;;; Return a list of names created from the cold layout INHERITS data ;;; in X. diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 3e6476d..6a8fa7b 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1376,6 +1376,33 @@ :type-spec list :default ()) +;;; Used to record the source location of definitions. +(define-info-class :source-location) + +(define-info-type + :class :source-location + :type :variable + :type-spec t + :default nil) + +(define-info-type + :class :source-location + :type :constant + :type-spec t + :default nil) + +(define-info-type + :class :source-location + :type :typed-structure + :type-spec t + :default nil) + +(define-info-type + :class :source-location + :type :symbol-macro + :type-spec t + :default nil) + #!-sb-fluid (declaim (freeze-type info-env)) ;;; Now that we have finished initializing *INFO-CLASSES* and diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index c37947e..1d25ea5 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -227,7 +227,8 @@ bootstrapping. `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (compile-or-load-defgeneric ',fun-name)) - (load-defgeneric ',fun-name ',lambda-list ,@initargs) + (load-defgeneric ',fun-name ',lambda-list + (sb-c:source-location) ,@initargs) ,@(mapcar #'expand-method-definition methods) (fdefinition ',fun-name))))) @@ -239,7 +240,7 @@ bootstrapping. (setf (info :function :type fun-name) (specifier-type 'function)))) -(defun load-defgeneric (fun-name lambda-list &rest initargs) +(defun load-defgeneric (fun-name lambda-list source-location &rest initargs) (when (fboundp fun-name) (style-warn "redefining ~S in DEFGENERIC" fun-name) (let ((fun (fdefinition fun-name))) @@ -250,7 +251,7 @@ bootstrapping. (apply #'ensure-generic-function fun-name :lambda-list lambda-list - :definition-source `((defgeneric ,fun-name) ,*load-pathname*) + :definition-source source-location initargs)) (define-condition generic-function-lambda-list-error @@ -464,7 +465,8 @@ bootstrapping. ;; addition to in the list. FIXME: We should no longer need to do ;; this, since the CLOS code is now SBCL-specific, and doesn't ;; need to be ported to every buggy compiler in existence. - ',pv-table-symbol)) + ',pv-table-symbol + (sb-c:source-location))) (defmacro make-method-function (method-lambda &environment env) (make-method-function-internal method-lambda env)) @@ -1417,17 +1419,18 @@ bootstrapping. `(method-function-get ,method-function 'closure-generator)) (defun load-defmethod - (class name quals specls ll initargs &optional pv-table-symbol) + (class name quals specls ll initargs pv-table-symbol source-location) (setq initargs (copy-tree initargs)) (let ((method-spec (or (getf initargs :method-spec) (make-method-spec name quals specls)))) (setf (getf initargs :method-spec) method-spec) (load-defmethod-internal class name quals specls - ll initargs pv-table-symbol))) + ll initargs pv-table-symbol + source-location))) (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list - initargs pv-table-symbol) + initargs pv-table-symbol source-location) (when pv-table-symbol (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)) @@ -1445,10 +1448,7 @@ bootstrapping. gf-spec qualifiers specializers)))) (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list - :definition-source `((defmethod ,gf-spec - ,@qualifiers - ,specializers) - ,*load-pathname*) + :definition-source source-location initargs))) (unless (or (eq method-class 'standard-method) (eq (find-class method-class nil) (class-of method))) @@ -1591,7 +1591,7 @@ bootstrapping. (defun ensure-generic-function (fun-name &rest all-keys - &key environment + &key environment source-location &allow-other-keys) (declare (ignore environment)) (let ((existing (and (fboundp fun-name) @@ -1862,6 +1862,7 @@ bootstrapping. &key (lambda-list nil lambda-list-p) argument-precedence-order + source-location &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) @@ -1871,7 +1872,7 @@ bootstrapping. ((assoc spec *!generic-function-fixups* :test #'equal) (if existing (make-early-gf spec lambda-list lambda-list-p existing - argument-precedence-order) + argument-precedence-order source-location) (error "The function ~S is not already defined." spec))) (existing (error "~S should be on the list ~S." @@ -1880,10 +1881,10 @@ bootstrapping. (t (pushnew spec *!early-generic-functions* :test #'equal) (make-early-gf spec lambda-list lambda-list-p nil - argument-precedence-order)))) + argument-precedence-order source-location)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p - function argument-precedence-order) + function argument-precedence-order source-location) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function fin @@ -1901,7 +1902,7 @@ bootstrapping. (!bootstrap-set-slot 'standard-generic-function fin 'source - *load-pathname*) + source-location) (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 776822f..9955583 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -150,7 +150,7 @@ (dolist (definition *early-class-definitions*) (let ((name (ecd-class-name definition)) (meta (ecd-metaclass definition)) - (source (ecd-source definition)) + (source (ecd-source-location definition)) (direct-supers (ecd-superclass-names definition)) (direct-slots (ecd-canonical-slots definition)) (other-initargs (ecd-other-initargs definition))) @@ -247,7 +247,7 @@ smc name value))) - (set-slot 'source *load-pathname*) + (set-slot 'source nil) (set-slot 'type 'standard) (set-slot 'documentation "The standard method combination.") (set-slot 'options ())) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index c07a4ee..6a2bc19 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -71,7 +71,8 @@ canonical-options)) ',*readers-for-this-defclass* ',*writers-for-this-defclass* - ',*slot-names-for-this-defclass*)))) + ',*slot-names-for-this-defclass* + (sb-c:source-location))))) (if defstruct-p (progn ;; FIXME: (YUK!) Why do we do this? Because in order @@ -327,14 +328,14 @@ (error "~S is not a class in *early-class-definitions*." class-name))) (defun make-early-class-definition - (name source metaclass + (name source-location metaclass superclass-names canonical-slots other-initargs) (list 'early-class-definition - name source metaclass + name source-location metaclass superclass-names canonical-slots other-initargs)) (defun ecd-class-name (ecd) (nth 1 ecd)) -(defun ecd-source (ecd) (nth 2 ecd)) +(defun ecd-source-location (ecd) (nth 2 ecd)) (defun ecd-metaclass (ecd) (nth 3 ecd)) (defun ecd-superclass-names (ecd) (nth 4 ecd)) (defun ecd-canonical-slots (ecd) (nth 5 ecd)) @@ -462,14 +463,14 @@ (declaim (notinline load-defclass)) (defun load-defclass (name metaclass supers canonical-slots canonical-options - readers writers slot-names) + readers writers slot-names source-location) (%compiler-defclass name readers writers slot-names) (setq supers (copy-tree supers) canonical-slots (copy-tree canonical-slots) canonical-options (copy-tree canonical-options)) (let ((ecd (make-early-class-definition name - *load-pathname* + source-location metaclass supers canonical-slots diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 46f0677..676bf9b 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -74,11 +74,11 @@ (operator (getf (cddr whole) :operator type))) `(load-short-defcombin - ',type ',operator ',identity-with-one-arg ',documentation))) + ',type ',operator ',identity-with-one-arg ',documentation + (sb-c:source-location)))) -(defun load-short-defcombin (type operator ioa doc) - (let* ((pathname *load-pathname*) - (specializers +(defun load-short-defcombin (type operator ioa doc source-location) + (let* ((specializers (list (find-class 'generic-function) (intern-eql-specializer type) *the-class-t*)) @@ -98,7 +98,7 @@ (short-combine-methods type options operator ioa new-method doc)) args)) - :definition-source `((define-method-combination ,type) ,pathname))) + :definition-source source-location)) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) @@ -226,11 +226,11 @@ type lambda-list method-group-specifiers args-option gf-var body) `(load-long-defcombin ',type ',documentation #',function - ',args-option)))) + ',args-option (sb-c:source-location))))) (defvar *long-method-combination-functions* (make-hash-table :test 'eq)) -(defun load-long-defcombin (type doc function args-lambda-list) +(defun load-long-defcombin (type doc function args-lambda-list source-location) (let* ((specializers (list (find-class 'generic-function) (intern-eql-specializer type) @@ -253,8 +253,7 @@ :args-lambda-list args-lambda-list :documentation doc)) args)) - :definition-source `((define-method-combination ,type) - ,*load-pathname*)))) + :definition-source source-location))) (setf (gethash type *long-method-combination-functions*) function) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 5f943e4..03ac566 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -676,8 +676,10 @@ :initarg :from-defclass-p))) (defclass definition-source-mixin (standard-object) - ((source :initform *load-pathname* :reader definition-source - :initarg :definition-source))) + ((source + :initform nil + :reader definition-source + :initarg :definition-source))) (defclass plist-mixin (standard-object) ((plist :initform () :accessor object-plist))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 19377bb..255c316 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -291,14 +291,13 @@ (constantly (make-member-type :members (list (specializer-object specl)))))) (defun real-load-defclass (name metaclass-name supers slots other - readers writers slot-names) + readers writers slot-names source-location) (with-single-package-locked-error (:symbol name "defining ~S as a class") (%compiler-defclass name readers writers slot-names) (let ((res (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots slots - :definition-source `((defclass ,name) - ,*load-pathname*) + :definition-source source-location other))) res))) diff --git a/version.lisp-expr b/version.lisp-expr index 4337bf5..3a322c0 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.9.6.24" +"0.9.6.25" -- 1.7.10.4