Source tracking interface

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

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<HashTable_sp>(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<T_O>();
   Label_sp begin = Label_O::make(), end = Label_O::make();
   gc::Nilable<String_sp> 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<T_O>());
+  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<Symbol_sp>(form))
     compile_symbol(gc::As_unsafe<Symbol_sp>(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)

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.

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))

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

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))))

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))

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

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

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)))

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))))))