diff --git a/RELEASE_NOTES.md b/RELEASE_NOTES.md index cab38dc9d8..8c618354ce 100644 --- a/RELEASE_NOTES.md +++ b/RELEASE_NOTES.md @@ -9,6 +9,7 @@ * Arguments to bytecode functions are made available to debuggers. * `ext:deoptimize` can temporarily replace almost all native-compiled functions with a simpler bytecode version with better debuggability. `ext:reoptimize` restores the native version. * A style warning is signaled if the compiler assumes a symbol names a function and then sees it defined as a macro. +* New interfaces for reading and evaluating code with tracked source locations: `ext:with-source-tracking`, `ext:stream-source-location`, `ext:read-source`, `ext:augment-source`, `ext:eval-source`, `ext:compile-source`. ## Changed * Use Khazern extended for CL:LOOP diff --git a/src/core/bytecode_compiler.cc b/src/core/bytecode_compiler.cc index 5dcbfdd202..2cd71eaa26 100644 --- a/src/core/bytecode_compiler.cc +++ b/src/core/bytecode_compiler.cc @@ -1677,7 +1677,7 @@ static void warn_ignorance(List_sp bindings) { } } -static T_sp source_location_for(T_sp form, T_sp fallback) { +static T_sp source_location_for(T_sp form, T_sp fallback = core::_sym_STARcurrentSourcePosInfoSTAR->symbolValue()) { if (_sym_STARsourceLocationsSTAR->boundP()) { T_sp table = _sym_STARsourceLocationsSTAR->symbolValue(); if (gc::IsA(table)) @@ -2086,6 +2086,8 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con // Compile the lambda expression in MODULE, returning the resulting CFUNCTION. CL_DEFUN Cfunction_sp compile_lambda(T_sp lambda_list, List_sp body, Lexenv_sp env, Module_sp module, T_sp source_info) { + DynamicScopeManager cspi(core::_sym_STARcurrentSourcePosInfoSTAR, + source_info); List_sp declares = nil(); Label_sp begin = Label_O::make(), end = Label_O::make(); gc::Nilable docstring; @@ -3010,17 +3012,27 @@ void compile_form(T_sp form, Lexenv_sp env, const Context context) { if (code_walking_p()) form = eval::funcall(_sym_STARcodeWalkerSTAR->symbolValue(), form, env); // Record source location if we have it. + // (as in, we use default NIL so that we can tell if there's no + // specific source info) T_sp source_location = source_location_for(form, nil()); + bool specific_sl = source_location.notnilp(); Label_sp begin_label = Label_O::make(); Label_sp end_label = Label_O::make(); Context ncontext = context; - if (source_location.notnilp()) { + if (specific_sl) { ncontext = context.sub_source(source_location); begin_label->contextualize(ncontext); // We push the info BEFORE compiling the form so that the infos // are naturally sorted by their start position. context.push_debug_info(BytecodeDebugLocation_O::make(begin_label, end_label, source_location)); + } else { + // We don't have specific source info, but we still want to + // communicate the best source info we can get to macroexpanders + // etc. even if we don't put it in the debug info. + source_location = context.source_info(); } + DynamicScopeManager cspi(core::_sym_STARcurrentSourcePosInfoSTAR, + source_location); // Compile if (gc::IsA(form)) compile_symbol(gc::As_unsafe(form), env, ncontext); @@ -3029,7 +3041,7 @@ void compile_form(T_sp form, Lexenv_sp env, const Context context) { else compile_literal(form, env, ncontext); // And finish off the source info. - if (source_location.notnilp()) { + if (specific_sl) { end_label->contextualize(ncontext); } } @@ -3050,7 +3062,7 @@ CL_DEFUN Cfunction_sp bytecompile_into(Module_sp module, T_sp lambda_expression, T_sp lambda_list = oCadr(lambda_expression); T_sp body = oCddr(lambda_expression); return compile_lambda(lambda_list, body, env, module, - source_location_for(lambda_expression, core::_sym_STARcurrentSourcePosInfoSTAR->symbolValue())); + source_location_for(lambda_expression)); } CL_LAMBDA(lambda-expression &optional env) diff --git a/src/lisp/kernel/cleavir/cmpintrinsics.lisp b/src/lisp/kernel/cleavir/cmpintrinsics.lisp index 052c284e59..a536def97f 100644 --- a/src/lisp/kernel/cleavir/cmpintrinsics.lisp +++ b/src/lisp/kernel/cleavir/cmpintrinsics.lisp @@ -908,17 +908,7 @@ Boehm and MPS use a single pointer" ;; ;; -(defvar *compile-file-pathname* nil "Store the pathname of the currently compiled file") -(defvar *compile-file-truename* nil "Store the truename of the currently compiled file") (defvar *compile-file-unique-symbol-prefix* "" "Store a unique prefix for symbols that are external-linkage") -;;; These variables are used to let compile-file insert debug information that does not -;;; correspond to the actual file being compiled. This is useful for editors (SLIME) that -;;; may present Clasp with a temporary file containing a portion of some other file; we want -;;; the debug data in the compilation of this file to reflect the other file, not the temp. -(defvar *compile-file-source-debug-pathname*) ; Pathname for source info -(defvar *compile-file-file-scope*) ; File scope bound by compile-file etc for source file info -(defvar *compile-file-source-debug-offset*) ; Offset bound by compile-file etc for SFIs -(defvar *compile-file-source-debug-lineno*) ; ditto (defvar *gv-boot-functions* nil "A global value that stores a pointer to the boot function for the Module. diff --git a/src/lisp/kernel/cmp/cmpltv.lisp b/src/lisp/kernel/cmp/cmpltv.lisp index a3e23a78c9..744ecfc94e 100644 --- a/src/lisp/kernel/cmp/cmpltv.lisp +++ b/src/lisp/kernel/cmp/cmpltv.lisp @@ -2002,10 +2002,10 @@ (cmp:lexenv/frame-end env) (cmp:lexenv/global env))))) (defun bytecode-compile-toplevel (form &optional (env *environment*)) - (let ((core:*current-source-pos-info* - (or (gethash form cmp:*source-locations*) - core:*current-source-pos-info*)) - (form (macroexpand form env))) + (let* ((core:*current-source-pos-info* + (or (gethash form cmp:*source-locations*) + core:*current-source-pos-info*)) + (form (macroexpand form env))) (if (consp form) (case (car form) ((progn) (bytecode-compile-toplevel-progn (cdr form) env)) diff --git a/src/lisp/kernel/cmp/compile-file.lisp b/src/lisp/kernel/cmp/compile-file.lisp index 15d2058f6e..8cf432e44e 100644 --- a/src/lisp/kernel/cmp/compile-file.lisp +++ b/src/lisp/kernel/cmp/compile-file.lisp @@ -68,11 +68,6 @@ (defvar *compile-file-output-pathname* nil) -(defun compile-file-source-pos-info (stream) - (core:input-stream-source-pos-info - stream *compile-file-file-scope* - *compile-file-source-debug-lineno* *compile-file-source-debug-offset*)) - (defun compile-file (input-file &rest args &key diff --git a/src/lisp/kernel/cmp/compile.lisp b/src/lisp/kernel/cmp/compile.lisp index b5dec494ee..47879612f8 100644 --- a/src/lisp/kernel/cmp/compile.lisp +++ b/src/lisp/kernel/cmp/compile.lisp @@ -69,3 +69,11 @@ (setf (fdefinition name) function) (values name warnp failp)) (t (values function warnp failp))))) + +(defun ext:compile-source (lambda-expression &optional source environment) + "Compile LAMBDA-EXPRESSION in ENVIRONMENT. If SOURCE is non-null it must be a source object returned from EXT:READ-SOURCE or EXT:AUGMENT-SOURCE, and is used to provide source locations for compiled code and error messages." + (cond (source + (check-type source hash-table) + (let ((*source-locations* source)) + (compile-definition lambda-expression environment))) + (t (compile-definition lambda-expression environment)))) diff --git a/src/lisp/kernel/cmp/eclector.lisp b/src/lisp/kernel/cmp/eclector.lisp index 8f6f289186..9c52e1133d 100644 --- a/src/lisp/kernel/cmp/eclector.lisp +++ b/src/lisp/kernel/cmp/eclector.lisp @@ -1,5 +1,41 @@ (in-package #:cmp) +;;; general source tracking + +(defmacro ext:with-source-tracking + ((stream &key (pathname nil pathnamep) (lineno 0) (offset 0)) + &body body) + "Evaluate BODY such that STREAM tracks source locations. +EXT:STREAM-SOURCE-LOCATION can be used to get the current source location from the stream." + `(let ((*compile-file-source-debug-pathname* + ;; (pathname stream) will signal an error if stream is not + ;; associated with a file. We want an error, since if a + ;; string-stream or something was passed in, the user needs + ;; to specify their own pathname. + ;; Maybe the error should be more specific though? FIXME + ,(if pathnamep + `(pathname ,pathname) + `(truename ,stream))) + (*compile-file-file-scope* + (core:file-scope *compile-file-source-debug-pathname*)) + (*compile-file-source-debug-lineno* ,lineno) + (*compile-file-source-debug-offset* ,offset)) + ,@body)) + +(defun ext:stream-source-location (stream) + "Get the current source location from STREAM. This can only be used within EXT:WITH-SOURCE-TRACKING." + (core:input-stream-source-pos-info + stream *compile-file-file-scope* + *compile-file-source-debug-lineno* + *compile-file-source-debug-offset*)) + +;;; these two basically exist to keep uniform source-location- names +(declaim (inline ext:source-location-lineno ext:source-location-column)) +(defun ext:source-location-lineno (spi) + (core:source-pos-info-lineno spi)) +(defun ext:source-location-column (spi) + (core:source-pos-info-column spi)) + ;;; So that non-cst-client can inherit behaviour (defclass clasp-eclector-client-mixin ()()) @@ -128,7 +164,7 @@ (defmethod eclector.base:source-position ((client clasp-tracking-eclector-client) stream) - (compile-file-source-pos-info stream)) + (ext:stream-source-location stream)) (defmethod eclector.parse-result:make-expression-result ((client clasp-tracking-eclector-client) result children source) @@ -282,3 +318,59 @@ (let ((patcher (core:make-record-patcher (lambda (object) (patch-object client object seen-objects))))) (core:patch-object object patcher))) + +(defvar *source-client* (make-instance 'clasp-tracking-eclector-client)) + +(defun ext:read-source (&optional + input-stream-designator (eof-error-p t) + eof-value recursive-p environment) + "READ with source tracking. Returns two values: the form read, and an object representing a source location map for that form. This object is not defined for users, but may be passed to EVAL-SOURCE or COMPILE-SOURCE to give the evaluator and/or compiled code source locations. +If EOF-ERROR-P is NIL and the stream hits EOF, the first value will be ELF-VALUE and the second value is undefined." + (let ((eclector.reader:*client* + (if environment + (make-instance 'cmp::clasp-alternate-env-client + :environment *environment*) + *source-client*)) + (*source-locations* (make-hash-table :test #'eq))) + (values (eclector.parse-result:read eclector.reader:*client* + (or input-stream-designator + *standard-input*) + eof-error-p eof-value) + *source-locations*))) + +(defun ext:eval-source (form &optional source environment) + "Evaluate FORM in ENVIRONMENT. If SOURCE is non-null it must be a source object returned from EXT:READ-SOURCE or EXT:AUGMENT-SOURCE, and is used to provide source locations for code and error messages." + (cond (source + (check-type source hash-table) + (let ((*source-locations* source)) + (core:interpret form environment))) + (t (core:interpret form environment)))) + +(defun ext:augment-source (new-form source + &optional (default (ext:current-source-location))) + "Create a new source object (as returned by READ-SOURCE) for NEW-FORM, based on the mapping SOURCE which is presumably to some but not all subforms of NEW-FORM. Any subforms of NEW-FORM that are not present in the SOURCE mapping will be given DEFAULT as their source location if provided; DEFAULT must be a source location as returned by EXT:STREAM-SOURCE-LOCATION or EXT:CURRENT-SOURCE-LOCATION, and defaults to the latter." + ;; This function is basically like CST:RECONSTRUCT. It has this + ;; interface in case we ever go back to using something like CSTs. + ;; Imagine for example we've read a form and now want to wrap it in a + ;; lambda expression: `(lambda () ,form). If the SOURCE for FORM is a + ;; CST, passing this lambda expression and that CST would not work, + ;; because the compiler would refer to the CST rather than the form + ;; and choke on the non-lambda-expression it was given. + ;; SOURCE being a hash table, as it is, does not have this particular + ;; issue, but it's nice to be able to augment with a default. + (check-type source hash-table) + (let ((new-source (make-hash-table :test #'eq))) + ;; copy the old source map + (maphash (lambda (k v) (setf (gethash k new-source) v)) source) + ;; install defaults + (when default + (check-type default core:source-pos-info) + (labels ((default (subform) + (unless (gethash subform new-source) + (setf (gethash subform new-source) default) + ;; cycle checking is handled by the above UNLESS + (when (consp subform) + (default (car subform)) + (default (cdr subform)))))) + (default new-form))) + new-source)) diff --git a/src/lisp/kernel/cmp/exports.lisp b/src/lisp/kernel/cmp/exports.lisp index ebe3fce493..ece125d913 100644 --- a/src/lisp/kernel/cmp/exports.lisp +++ b/src/lisp/kernel/cmp/exports.lisp @@ -330,7 +330,6 @@ with-dbg-lexical-block dbg-variable-alloca dbg-variable-value - compile-file-source-pos-info c++-field-offset c++-field-index c++-struct-type diff --git a/src/lisp/kernel/lsp/ext-package.lisp b/src/lisp/kernel/lsp/ext-package.lisp index e0b3559979..ae04274f9d 100644 --- a/src/lisp/kernel/lsp/ext-package.lisp +++ b/src/lisp/kernel/lsp/ext-package.lisp @@ -130,6 +130,10 @@ setf-expander ;; C++ iterators do-c++-iterator map-c++-iterator + ;; source info tracking and use + source-location-lineno source-location-column + stream-source-location with-source-tracking + read-source augment-source eval-source compile-source ;; Misc printing-char-p)) ) ; eval-when diff --git a/src/lisp/kernel/lsp/source-location.lisp b/src/lisp/kernel/lsp/source-location.lisp index 6da7357bee..414197bfa6 100644 --- a/src/lisp/kernel/lsp/source-location.lisp +++ b/src/lisp/kernel/lsp/source-location.lisp @@ -40,12 +40,21 @@ ;;; This happens to be the first non-:TYPE defstruct during build. ;;; But FIXME: It's redundant to core:source-pos-info and should be vaporized. (defstruct source-location - pathname offset + %pathname offset ;; A symbol like DEFVAR, DEFUN, etc for display. (definer nil :type symbol) ;; Any other metadata, mostly for user display. E.g. specializers of a method. (description nil :type list)) +(defgeneric source-location-pathname (source-location)) +(defmethod source-location-pathname ((sl source-location)) + (source-location-%pathname sl)) +;; See FIXME above about source-pos-info. +(defmethod source-location-pathname ((spi core:source-pos-info)) + (core:file-scope-pathname + (core:file-scope + (core:source-pos-info-file-handle spi)))) + (defun source-locations-set-info (source-locations definer &optional description) (loop for sl in source-locations do (setf (source-location-definer sl) definer @@ -56,7 +65,7 @@ (multiple-value-bind (file pos) (compiled-function-file function) (if file - (list (make-source-location :pathname file :offset pos :definer 'defun)) + (list (make-source-location :%pathname file :offset pos :definer 'defun)) nil))) ;; FIXME: Move this source debug stuff to an interface @@ -65,7 +74,7 @@ (let ((csi (core:file-scope (core:source-pos-info-file-handle source-position-info)))) (make-source-location - :pathname (core:file-scope-pathname csi) + :%pathname (core:file-scope-pathname csi) :offset (core:source-pos-info-filepos source-position-info) :definer definer))) @@ -80,7 +89,7 @@ (when cppinfo ;; This is a list (filename offset) (make-source-location - :pathname (pathname (first cppinfo)) + :%pathname (pathname (first cppinfo)) :offset (second cppinfo) :definer 'defclass)))))) @@ -129,7 +138,7 @@ (multiple-value-bind (file pos) (compiled-function-file gf) (if file - (list* (make-source-location :pathname file :offset pos :definer 'defgeneric) + (list* (make-source-location :%pathname file :offset pos :definer 'defgeneric) method-sls) method-sls)))) @@ -153,7 +162,7 @@ Return the source-location for the name/kind pair" (mapcar (lambda (dir-pos) (let ((dir (first dir-pos)) (pos (second dir-pos))) - (make-source-location :pathname (merge-pathnames dir sys-dir) + (make-source-location :%pathname (merge-pathnames dir sys-dir) :offset pos ;; FIXME :definer 'defmethod))) diff --git a/src/lisp/regression-tests/extensions.lisp b/src/lisp/regression-tests/extensions.lisp index 8e7cb61b20..0215a23c88 100644 --- a/src/lisp/regression-tests/extensions.lisp +++ b/src/lisp/regression-tests/extensions.lisp @@ -38,3 +38,63 @@ (output (read-line stream))) (close stream) (string= output "hello world"))) + +(test source-tracking.1 + (with-input-from-string (s "hello") + (ext:with-source-tracking (s :pathname "test.lisp" + :lineno 7 :offset 13) + (read-char s) (read-char s) ; move column + (let ((source (ext:stream-source-location s))) + (values (ext:source-location-pathname source) + (ext:source-location-lineno source) + (ext:source-location-column source))))) + ;; line numbering starts on 1, apparently. + (#p"test.lisp" 8 2)) + +(test source-tracking.2 + (let* ((fun (with-input-from-string (s "(lambda (x) x)") + (ext:with-source-tracking (s :pathname "lambda.lisp") + (multiple-value-call #'ext:compile-source + (ext:read-source s))))) + (sources (ext:source-location fun t))) + (if (find #p"lambda.lisp" sources + :test #'equal :key #'ext:source-location-pathname) + t + sources)) + (t)) + +(test source-tracking.3 + (with-input-from-string (s "(let ((x . 4)) x)") + (ext:with-source-tracking (s :pathname "test.lisp" + :lineno 7 :offset 13) + (multiple-value-bind (form source) + (ext:read-source s) + (handler-case + (ext:eval-source form source) + (program-error (e) + (let ((origin (cmp:compiler-condition-origin e))) + (if origin + (values (ext:source-location-pathname origin) + (ext:source-location-lineno origin) + (if (<= 0 (ext:source-location-column origin) 17) ; length of the string + t + (ext:source-location-column origin))) + :no-origin))) + (condition (c) + (values :wrong-condition c)) + (:no-error (&rest v) + (declare (ignore v)) + :no-error))))) + (#p"test.lisp" 8 t)) + +(test-true source-tracking.4 + (with-input-from-string (s "(+ x y)") + (ext:with-source-tracking (s :pathname "augment.lisp") + (multiple-value-bind (form source) + (ext:read-source s) + (let* ((expr `(lambda (x y) ,form)) + (aug (ext:augment-source + expr source + (ext:stream-source-location s))) + (f (ext:compile-source expr aug))) + (ext:source-location f t))))))