From f4f6325e34564593199574698de96ae446345b6e Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Tue, 6 Apr 2004 20:44:03 +0000 Subject: [PATCH] Add support for source location recording, from Helmut Eller on cmucl-imp: The patch below adds a somewhat general mechanism to the get the "current location". So every macro that wants to record the source location, can insert a call to SOURCE-LOCATION in the generated code and safe the result in a appropriate place. SOURCE-LOCATION is a compiler-macro and returns a quoted struct with the source info. The patch adds the definition for SOURCE-LOCATION some modifications for the defclass, defgeneric and defmethod macros. Classes, generic functions and methods have already a "source" slot and the result of SOURCE-LOCATION is just stored into that slot. (The source slot contains currently only the *loadpath*, which is is not very useful, if the fasl file is in a different directory than the source file.) --- bootfiles/18e/boot24.lisp | 43 +++++++++++++++++++++++++++++ compiler/ir1util.lisp | 58 ++++++++++++++++++++++++++++++++++++++- compiler/main.lisp | 8 +++++- pcl/boot.lisp | 26 ++++++++---------- pcl/defclass.lisp | 53 +++++++++++++++++++---------------- pcl/defcombin.lisp | 17 ++++++------ pcl/std-class.lisp | 3 +- 7 files changed, 157 insertions(+), 51 deletions(-) create mode 100644 bootfiles/18e/boot24.lisp diff --git a/bootfiles/18e/boot24.lisp b/bootfiles/18e/boot24.lisp new file mode 100644 index 000000000..5cf89d145 --- /dev/null +++ b/bootfiles/18e/boot24.lisp @@ -0,0 +1,43 @@ +;;; +;;; Bootstrap file for adding support for source location recording +;;; from Helmut Eller. +;;; + +(in-package "C") + +(setf lisp::*enable-package-locked-errors* nil) + +(defstruct (form-numbers) + ;; The tlf-number and form-number encoded in a fixnum. + (form-numbers (required-argument) :type fixnum)) + +(defstruct (file-source-location + (:include form-numbers) + (:make-load-form-fun :just-dump-it-normally) + (:pure t)) + (pathname (required-argument) :type simple-string)) + +(defstruct (stream-source-location + (:include form-numbers) + (:make-load-form-fun :just-dump-it-normally) + (:pure t)) + user-info) + +(defun encode-form-numbers (tlf-number form-number) + "Return the TLF-NUMBER and FORM-NUMBER encoded as fixnum." + (declare (type (unsigned-byte 14) tlf-number form-number)) + (logior tlf-number (ash form-number 14))) + +(defun namestring-for-debug-source (file-info) + "Extract the namestring from FILE-INFO for the DEBUG-SOURCE. +Return FILE-INFO's untruename (e.g., target:foo) if it is absolute; +otherwise the truename." + (let* ((untruename (file-info-untruename file-info)) + (dir (pathname-directory untruename))) + (namestring (if (and dir (eq (first dir) :absolute)) + untruename + (file-info-name file-info))))) + +(defun source-location () + "Return a source-location for the call site." + nil) diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp index 82c800bd4..0f8753749 100644 --- a/compiler/ir1util.lisp +++ b/compiler/ir1util.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.101 2004/03/24 13:27:43 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.102 2004/04/06 20:44:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -410,6 +410,62 @@ (values (node-source-form use) t) (values nil nil)))) + +;;; Utilities for source location recording. SOURCE-LOCATION returns +;;; a data structure describing the source location of the call site. +;;; The structure includes form numbers and the filename, if we +;;; compile a file, or the user supplied info, if we compile from a +;;; stream. +;;; +;;; Some effort was made to keep the structures small. We restrict +;;; form numbers to two 14 bit integers and encode them in a single +;;; fixnum. Both FILE-SOURCE-LOCATION and STREAM-SOURCE-LOCATION +;;; require 4 words (usually 16 bytes). + +(defstruct (form-numbers) + ;; The tlf-number and form-number encoded in a fixnum. + (form-numbers (required-argument) :type fixnum)) + +(defstruct (file-source-location + (:include form-numbers) + (:make-load-form-fun :just-dump-it-normally) + (:pure t)) + (pathname (required-argument) :type simple-string)) + +(defstruct (stream-source-location + (:include form-numbers) + (:make-load-form-fun :just-dump-it-normally) + (:pure t)) + user-info) + +(defun encode-form-numbers (tlf-number form-number) + "Return the TLF-NUMBER and FORM-NUMBER encoded as fixnum." + (declare (type (unsigned-byte 14) tlf-number form-number)) + (logior tlf-number (ash form-number 14))) + +(defun decode-form-numbers (fixnum) + "Return the tlf-number and form-number from an encoded FIXNUM." + (values (ldb (byte 14 0) fixnum) + (ldb (byte 14 14) fixnum))) + +(defun source-location () + "Return a source-location for the call site." + nil) + +(define-compiler-macro source-location () + (let ((file-info (car (source-info-current-file *source-info*))) + (form-numbers (encode-form-numbers + (source-path-tlf-number *current-path*) + (source-path-form-number *current-path*)))) + (etypecase (file-info-name file-info) + ((member :stream) + `(quote ,(make-stream-source-location :form-numbers form-numbers + :user-info *user-source-info*))) + (pathname + `(quote ,(make-file-source-location + :form-numbers form-numbers + :pathname (namestring-for-debug-source file-info))))))) + ;;; MAKE-LEXENV -- Interface ;;; diff --git a/compiler/main.lisp b/compiler/main.lisp index d3fa014a4..61084ec84 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.139 2004/01/16 14:15:16 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.140 2004/04/06 20:44:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -131,6 +131,11 @@ ;;; (defvar *source-info* nil) +(defvar *user-source-info* nil + "The user supplied source-info for the current compilation. +This is the :source-info argument to COMPILE-FROM-STREAM and will be +stored in the INFO slot of the DEBUG-SOURCE in code components and +in the user USER-INFO slot of STREAM-SOURCE-LOCATIONs.") ;;; Maybe-Mumble -- Internal ;;; @@ -1505,6 +1510,7 @@ (*lexical-environment* (make-null-environment)) (*converting-for-interpreter* nil) (*source-info* info) + (*user-source-info* d-s-info) (*compile-file-pathname* nil) (*compile-file-truename* nil) (*top-level-lambdas* ()) diff --git a/pcl/boot.lisp b/pcl/boot.lisp index 72530d079..4cf83757b 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.71 2004/01/09 05:18:08 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.72 2004/04/06 20:44:02 rtoy Exp $") (in-package :pcl) @@ -302,7 +302,9 @@ work during bootstrapping. ,(make-top-level-form `(defgeneric ,function-specifier) '(:load-toplevel :execute) - `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)) + `(load-defgeneric ',function-specifier ',lambda-list + :definition-source (c::source-location) + ,@initargs)) ,@methods `,(function ,function-specifier)))) @@ -320,8 +322,6 @@ work during bootstrapping. (apply #'ensure-generic-function function-specifier :lambda-list lambda-list - :definition-source `((defgeneric ,function-specifier) - ,*load-pathname*) initargs)) @@ -512,7 +512,7 @@ work during bootstrapping. ',qualifiers ,specializers-form ',unspecialized-lambda-list - ,initargs-form + (list* :definition-source (c::source-location) ,initargs-form) ;;Paper over a bug in KCL by passing the cache-symbol ;;here in addition to in the list. ',pv-table-symbol @@ -1335,12 +1335,7 @@ work during bootstrapping. (maybe-compile :function))) ;; (let ((method (apply #'add-named-method - gf-name qualifiers specializers lambda-list - :definition-source `((defmethod ,gf-name - ,@qualifiers - ,specializers) - ,*load-pathname*) - initargs))) + gf-name qualifiers specializers lambda-list initargs))) ;; (record-inline-access-info method inline-access method-info) ;; @@ -1753,7 +1748,8 @@ work during bootstrapping. #-loadable-pcl (defun ensure-generic-function-using-class (existing spec &rest keys - &key (lambda-list nil lambda-list-p) argument-precedence-order + &key (lambda-list nil lambda-list-p) argument-precedence-order + definition-source &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) @@ -1769,10 +1765,10 @@ work during 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 definition-source)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p function - argument-precedence-order) + argument-precedence-order source) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function fin @@ -1787,7 +1783,7 @@ work during bootstrapping. has not been set.~@:>" fin))))) (setf (gdefinition spec) fin) (bootstrap-set-slot 'standard-generic-function fin 'name spec) - (bootstrap-set-slot 'standard-generic-function fin 'source *load-pathname*) + (bootstrap-set-slot 'standard-generic-function fin 'source source) (set-function-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index 66fc1046f..2232dd14b 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.29 2003/05/13 10:16:59 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.30 2004/04/06 20:44:03 rtoy Rel $") ;;; (in-package :pcl) @@ -165,10 +165,12 @@ ',metaclass ',supers (list ,@canonical-slots) - (list ,@(apply #'append - (when defstruct-p - '(:from-defclass-p t)) - other-initargs)))))))) + (list + :definition-source (c::source-location) + ,@(apply #'append + (when defstruct-p + '(:from-defclass-p t)) + other-initargs)))))))) (if defstruct-p (progn (eval defclass-form) ; define the class now, so that @@ -356,12 +358,15 @@ (others (ecd-other-initargs definition))) (loop (when (null others) (return nil)) (let ((initarg (pop others))) - (unless (eq initarg :direct-default-initargs) - (error "~@<The defclass option ~S is not supported by ~ - the bootstrap object system.~@:>" - initarg))) - (setq default-initargs - (nconc default-initargs (reverse (pop others))))))) + (cond ((eq initarg :direct-default-initargs) + (setq default-initargs + (nconc default-initargs (reverse (pop others))))) + (t + (cerror "Discard it." + "~@<The defclass option ~S is not supported by ~ + the bootstrap object system.~@:>" + initarg) + (pop others))))))) (reverse default-initargs))) (defun bootstrap-slot-index (class-name slot-name) @@ -425,16 +430,18 @@ canonical-options (copy-tree canonical-options)) (when (eq metaclass 'standard-class) (inform-type-system-about-std-class name)) - (let ((ecd - (make-early-class-definition name - *load-pathname* - metaclass - supers - canonical-slots - canonical-options)) - (existing - (find name *early-class-definitions* :key #'ecd-class-name))) - (setq *early-class-definitions* - (cons ecd (remove existing *early-class-definitions*))) - ecd)) + (let ((source (getf canonical-options :definition-source))) + (remf canonical-options :definition-source) + (let ((ecd + (make-early-class-definition name + source + metaclass + supers + canonical-slots + canonical-options)) + (existing + (find name *early-class-definitions* :key #'ecd-class-name))) + (setq *early-class-definitions* + (cons ecd (remove existing *early-class-definitions*))) + ecd))) diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp index 747af7fe3..1a58fc977 100644 --- a/pcl/defcombin.lisp +++ b/pcl/defcombin.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.25 2003/08/25 20:10:41 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.26 2004/04/06 20:44:03 rtoy Exp $") (in-package :pcl) @@ -117,7 +117,8 @@ (make-top-level-form `(define-method-combination ,type) '(:load-toplevel :execute) `(load-short-defcombin - ',type ',operator ',identity-with-one-arg ',documentation)))) + ',type ',operator ',identity-with-one-arg + ',documentation (c::source-location))))) (defun set-random-documentation (type doc-type doc) (let ((pair (assoc doc-type @@ -127,7 +128,7 @@ (push (cons doc-type doc) (info random-documentation stuff type))))) -(defun load-short-defcombin (type operator ioa doc) +(defun load-short-defcombin (type operator ioa doc source) (let* ((specializers (list (find-class 'generic-function) (intern-eql-specializer type) @@ -148,8 +149,7 @@ (make-short-method-combination type options operator ioa new-method doc)) args)) - :definition-source `((define-method-combination ,type) - ,*load-pathname*))) + :definition-source source)) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) @@ -252,9 +252,9 @@ (make-top-level-form `(define-method-combination ,type) '(:load-toplevel :execute) `(load-long-defcombin ',type ',documentation #',function - ',arguments-option))))) + ',arguments-option (c::source-location)))))) -(defun load-long-defcombin (type doc function args-lambda-list) +(defun load-long-defcombin (type doc function args-lambda-list source) (let* ((specializers (list (find-class 'generic-function) (intern-eql-specializer type) @@ -278,8 +278,7 @@ :args-lambda-list args-lambda-list :documentation doc)) args)) - :definition-source `((define-method-combination ,type) - ,*load-pathname*)))) + :definition-source source))) (when old-method (remove-method #'find-method-combination old-method)) (add-method #'find-method-combination new-method) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 7bb08c55f..62b139ca3 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.71 2003/10/29 12:14:35 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.72 2004/04/06 20:44:03 rtoy Exp $") (in-package :pcl) @@ -352,7 +352,6 @@ (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots slots - :definition-source `((defclass ,name) ,*load-pathname*) other)) (setf (gdefinition 'load-defclass) #'real-load-defclass) -- GitLab