Preserve COMPILE-FILE's argument & *D-P-D* through to fasls.

This consists of (a) splitting one slot into two, albeit in 3 different structures; and (b) having the old source namestring accessors obey a new variable. * FILE-INFO's old UNTRUENAME is now PATHNAME-1 and PATHNAME-2. The first is the original argument (with the type filled in), and the second is *D-P-D* if merging contributes anything to PATHNAME-1. * DEBUG-SOURCE and SOURCE-LOCATION now have corresponding NAMESTRING-1 and NAMESTRING-2 slots, with equivalent purpose except when we're supposed to be storing *SOURCE-NAMESTRING*. * The new variable SB-EXT:*SOURCE-FILE-DEFAULTING* influences what namestring introspection functions return. If it's NIL, they return NAMESTRING-1. If it's :DEFAULT, they return the (equivalent of) merging NAMESTRING-1 with NAMESTRING-2. N.B., this removes the recently added SB-C::*MERGE-PATHNAMES*, since now it's not a question what information to store at compile time, but whether to return merged or unmerged results at inquiry time.
2026-09-10 07:26:40 -04:00 · 2021-05-20 11:08:40 -04:00 · 2021-05-20 11:08:40 -04:00 · ed585f7386
parent d7d3f820b4
commit ed585f7386
8 changed files with 165 additions and 84 deletions
--- a/make-target-2.sh
+++ b/make-target-2.sh
@ -63,9 +63,8 @@ echo //doing warm init - load and dump phase
 (progn ${devel})
 (sb-fasl::!warm-load "make-target-2-load.lisp")
 (setf (extern-alien "gc_coalesce_string_literals" char) 2)
-;;; Use the historical (bad) convention for *compile-file-pathname*
-(setf sb-c::*merge-pathnames* t)
-;;; and for storing pathname namestrings in fasls too.
+;;; Use the historical (bad) convention for storing pathname
+;;; namestrings in fasls.
 (setq sb-c::*name-context-file-path-selector* 'truename)
 (let ((sb-ext:*invoke-debugger-hook* (prog1 sb-ext:*invoke-debugger-hook* (sb-ext:enable-debugger))))
 (sb-ext:save-lisp-and-die "output/sbcl.core"))
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@ -940,6 +940,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
               "PRINT-SYMBOL-WITH-PREFIX"
               "*PRINT-VECTOR-LENGTH*"
               "DECIMAL-WITH-GROUPED-DIGITS-WIDTH"
+               "*SOURCE-FILE-DEFAULTING*"
               ;;"OBJECT-SIZE"

               ;; stepping interface
--- a/src/code/debug-info.lisp
+++ b/src/code/debug-info.lisp
@ -384,12 +384,42 @@
                          (:copier nil))
  ;; When the DEBUG-SOURCE describes a file, the file's namestring.
  ;; Otherwise, NIL.
-  (namestring nil :type (or null string))
+  (namestring-1 nil :type (or null string))
+  ;; When NAMESTRING-1 is relative, the namestring of the pathname
+  ;; relative to which NAMESTRING-1 named a file at COMPILE-FILE
+  ;; time.
+  (namestring-2 nil :type (or null string))
  ;; the universal time that the source was written, or NIL if
  ;; unavailable
  (created nil :type (or unsigned-byte null))
  ;; Additional information from (WITH-COMPILATION-UNIT (:SOURCE-PLIST ...))
  (plist *source-plist* :read-only t))
+
+(declaim (type (or (member nil :default) pathname)))
+(defvar *source-file-defaulting* :default
+  "Influences how introspection routines return namestrings for source
+files originally compiled using relative pathname designators. One of
+NIL (return the relative namestring), :DEFAULT (return the namestring
+of the defaulted pathname at compile-time).")
+
+(defun maybe-reconstitute-namestring (namestring-1 namestring-2
+                                      &optional (mode *source-file-defaulting*))
+  (cond ((null mode)
+         namestring-1)
+        ((eql :default mode)
+         ;; If NAMESTRING-2 is NIL, there's a chance
+         ;; NAMESTRING-1's syntax will be ambiguous in the dynamic
+         ;; environment where someone is calling this. (This is
+         ;; probably why we used to only dump absolute names.) Nothing
+         ;; much we can do about that, though.
+         (concatenate 'string (or namestring-2 "") namestring-1))))
+
+;; This used to be an accessor, but now it obeys
+;; *SOURCE-FILE-DEFAULTING*.
+(defun debug-source-namestring (debug-source)
+  (maybe-reconstitute-namestring
+   (debug-source-namestring-1 debug-source)
+   (debug-source-namestring-2 debug-source)))

 ;;;; DEBUG-INFO structures

@ -446,11 +476,13 @@
  (truename nil :type (or pathname null (eql :lisp)))
  ;; the external format that we'll call OPEN with, if NAME is a file.
  (external-format nil  :read-only t)
-  ;; the defaulted, but not necessarily absolute file name (i.e. prior
-  ;; to TRUENAME call.) Null if not a file. This is used to set
-  ;; *COMPILE-FILE-PATHNAME*, and if absolute (a harmful constraint to be sure),
-  ;; is dumped in the debug-info.
-  (pathname nil :type (or pathname null) :read-only t)
+  ;; the defaulted, but not necessarily absolute file name. Null if not a file.
+  (pathname-1 nil :type (or pathname null) :read-only t)
+  ;; the *DEFAULT-PATHNAME-DEFAULTS* used to open the file in
+  ;; COMPILE-FILE, or NIL if merging that with PATHNAME doesn't make a
+  ;; difference. Gets stored in the fasl so that users can optionally
+  ;; reconstruct the compile-time pathname later.
+  (pathname-2 nil :type (or pathname null) :read-only t)
  ;; the file's write date (if relevant)
  (write-date nil :type (or unsigned-byte null)  :read-only t)
  ;; parallel vectors containing the forms read out of the file and
--- a/src/code/source-location.lisp
+++ b/src/code/source-location.lisp
@ -11,22 +11,37 @@

 (in-package "SB-C")

+;;; Some uses of source locations want absolute filenames that were
+;;; (implicitly) involved at compile- or load-time, some want relative
+;;; filenames, and some want absolute filenames derived from runtime
+;;; state. In order to keep the DEFINITION-SOURCE-LOCATION structure
+;;; small, we separate out the filename pieces to its own record.
+(def!struct (definition-source-location-filenames
+                (:constructor %make-definition-source-location-filenames
+                    (namestring-1 namestring-2)))
+  ;; Namestring (often not always relative) of the source file that the
+  ;; definition was compiled from.  This is null if the definition was
+  ;; not compiled from a file.
+  (namestring-1 nil :type (or string null) :read-only t)
+  ;; Either null or the namestring relative to which NAMESTRING-1 named
+  ;; a file at compile-file-time.
+  (namestring-2 nil :type (or string null) :read-only t))
+(!set-load-form-method definition-source-location-filenames  (:xc :target))
+
 ;;; A DEFINITION-SOURCE-LOCATION contains two packed fixnums in the INDICES slot,
 ;;; and unless there is a non-nil plist, does not store the plist.
 ;;; Packed representation is: header + layout, namestring, indices, (padding)
 (def!struct (definition-source-location
             (:constructor %make-basic-definition-source-location
-                           (namestring indices))
+                           (filenames indices))
             (:copier nil))
-  ;; Namestring of the source file that the definition was compiled from.
-  ;; This is null if the definition was not compiled from a file.
-  (namestring nil :type (or string null) :read-only t)
+  (filenames nil :type (or null definition-source-location-filenames) :read-only t)
  (indices 0 :type integer :read-only t))
 (!set-load-form-method definition-source-location  (:xc :target))
 (def!struct (definition-source-location+plist
             (:include definition-source-location)
             (:constructor %make-full-definition-source-location
-                           (namestring indices plist))
+                           (filenames indices plist))
             (:copier nil))
  (plist nil :read-only t))

@ -48,7 +63,15 @@
               'definition-source-location+plist)
    (definition-source-location+plist-plist source-loc)))

-(defun %make-definition-source-location (namestring tlf-num subform-num)
+;; This used to be an accessor, but now it obeys
+;; *SOURCE-NAMESTRING-DEFAULTING*.
+(defun definition-source-location-namestring (source-loc)
+  (let* ((filenames (definition-source-location-filenames source-loc))
+         (namestring-1 (definition-source-location-filenames-namestring-1 filenames))
+         (namestring-2 (definition-source-location-filenames-namestring-2 filenames)))
+    (maybe-reconstitute-namestring namestring-1 namestring-2)))
+
+(defun %make-definition-source-location (namestring-1 namestring-2 tlf-num subform-num)
  (declare (type (or null (integer -1 *)) tlf-num)
           (type (or null unsigned-byte) subform-num))
  (let* ((plist *source-plist*)
@ -65,44 +88,58 @@
                      0)))
         (source-info (and (boundp '*source-info*) *source-info*))
         (last (and source-info
-                    (source-info-last-defn-source-loc source-info))))
+                    (source-info-last-defn-source-loc source-info)))
+         (last-filenames (if last (definition-source-location-filenames last)))
+         (filenames (if (and last
+                             (equal (definition-source-location-filenames-namestring-1
+                                     last-filenames)
+                                    namestring-1)
+                             (equal (definition-source-location-filenames-namestring-2
+                                      last-filenames)
+                                    namestring-2))
+                        last-filenames
+                        (%make-definition-source-location-filenames
+                         namestring-1 namestring-2))))
    (if (and last
             (eql (definition-source-location-indices last) indices)
-             (string= (definition-source-location-namestring last) namestring)
+             (eql last-filenames filenames)
             (equal (definition-source-location-plist last) plist))
        last
        (let ((new (if plist
-                       (%make-full-definition-source-location namestring indices plist)
-                       (%make-basic-definition-source-location namestring indices))))
+                       (%make-full-definition-source-location filenames indices plist)
+                       (%make-basic-definition-source-location filenames indices))))
          (when source-info
            (setf (source-info-last-defn-source-loc source-info) new))
          new))))

 (defun make-definition-source-location ()
-  (let* ((source-info (and (boundp '*source-info*) *source-info*))
-         (namestring
-          (or *source-namestring*
-              (when source-info
-                (make-file-info-namestring
-                 cl:*compile-file-pathname*
-                 (get-toplevelish-file-info source-info)))))
+  (let ((source-info (and (boundp '*source-info*) *source-info*))
         tlf-number
         form-number)
-    (acond ((boundp '*current-path*)
-            (setf tlf-number (source-path-tlf-number *current-path*)
-                  form-number (source-path-form-number *current-path*)))
-           ((and source-info (source-info-file-info source-info))
-            (setf tlf-number (1- (fill-pointer (file-info-forms it))))))
-    (%make-definition-source-location namestring tlf-number form-number)))
+    (multiple-value-bind (namestring-1 namestring-2)
+        (or *source-namestring*
+            (when source-info
+              (make-file-info-namestrings
+               cl:*compile-file-pathname*
+               (get-toplevelish-file-info source-info))))
+      (acond ((boundp '*current-path*)
+              (setf tlf-number (source-path-tlf-number *current-path*)
+                    form-number (source-path-form-number *current-path*)))
+             ((and source-info (source-info-file-info source-info))
+              (setf tlf-number (1- (fill-pointer (file-info-forms it))))))
+      (%make-definition-source-location namestring-1 namestring-2 tlf-number form-number))))

-(defun make-file-info-namestring (name file-info)
-  (let* ((pathname (file-info-pathname file-info))
-         (dir (and pathname (pathname-directory pathname))))
-    (if (and dir (eq (first dir) :absolute))
-        (namestring pathname)
-        (if name
-            (namestring name)
-            nil))))
+(defun make-file-info-namestrings (name file-info)
+  (let* ((pathname-1 (file-info-pathname-1 file-info))
+         (dir (and pathname-1 (pathname-directory pathname-1)))
+         (pathname-2 (file-info-pathname-2 file-info)))
+    (cond ((and dir (eq (first dir) :absolute))
+           (values (namestring pathname-1) nil))
+          ((and pathname-1 pathname-2)
+           (values (namestring pathname-1) (namestring pathname-2)))
+          (t (if name
+                 (namestring name)
+                 nil)))))

 (in-package "SB-IMPL")

--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@ -346,23 +346,25 @@
 (defun debug-source-for-info (info &key function)
  (declare (type source-info info))
  (let ((file-info (get-toplevelish-file-info info)))
-    (multiple-value-call
-        (if function 'sb-di::make-core-debug-source 'make-debug-source)
-     :namestring (or *source-namestring*
-                     (make-file-info-namestring
-                      (let ((pathname
-                             (case *name-context-file-path-selector*
-                               (pathname (file-info-pathname file-info))
-                               (truename (file-info-truename file-info)))))
-                        (if (pathnamep pathname) pathname))
-                      file-info))
-     :created (file-info-write-date file-info)
-     (if function
-         (values :form (let ((direct-file-info (source-info-file-info info)))
-                         (when (eq :lisp (file-info-truename direct-file-info))
-                           (elt (file-info-forms direct-file-info) 0)))
-                 :function function)
-         (values)))))
+    (multiple-value-bind (namestring-1 namestring-2)
+        (make-file-info-namestrings
+         (let ((pathname
+                (case *name-context-file-path-selector*
+                  (pathname (file-info-pathname-1 file-info))
+                  (truename (file-info-truename file-info)))))
+           (if (pathnamep pathname) pathname))
+         file-info)
+        (multiple-value-call
+            (if function 'sb-di::make-core-debug-source 'make-debug-source)
+          :namestring-1 (or *source-namestring* namestring-1)
+          :namestring-2 (unless *source-namestring* namestring-2)
+          :created (file-info-write-date file-info)
+          (if function
+              (values :form (let ((direct-file-info (source-info-file-info info)))
+                              (when (eq :lisp (file-info-truename direct-file-info))
+                                (elt (file-info-forms direct-file-info) 0)))
+                      :function function)
+              (values))))))

 (defun smallest-element-type (integer negative)
  (let ((bits (max (+ (integer-length integer)
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@ -836,25 +836,23 @@ necessary, since type inference may take arbitrarily long to converge.")
  (terpri)
  (values))

-;;; Leave this as NIL if you want modern, rational, correct, behavior,
-;;; or switch it to T for legacy (CLHS-specified) bullshit a la
-;;;  "During a call to compile-file, *compile-file-pathname* is bound to the pathname
-;;;   denoted by the first argument to compile-file, merged against the defaults"
-;;; The normal build sets it to T in make-target-2, despite that I think most people would
-;;; prefer the nonstandard behavior. The standard behavior makes stored pathnames all wrong
-;;; when files are physically moved. (Same problem as SBCL_HOME embedded into C pretty much)
-(defglobal *merge-pathnames* t)
-
 ;;; Given a pathname, return a SOURCE-INFO structure.
-(defun make-file-source-info (file external-format &optional form-tracking-p)
+(defun make-file-source-info (pathname external-format &optional form-tracking-p)
  (make-source-info
-   :file-info (make-file-info :pathname ; becomes *C-F-PATHNAME*
-                              (if *merge-pathnames* (merge-pathnames file) file)
-                              :external-format external-format
-                              :subforms
-                              (if form-tracking-p
-                                  (make-array 100 :fill-pointer 0 :adjustable t))
-                              :write-date (file-write-date file))))
+   :file-info (make-file-info
+               :pathname-1 pathname
+               ;; FIXME: this shouldn't have to be initialized here,
+               ;; but delaying it till GET-SOURCE-STREAM somehow
+               ;; prevents it from showing up in DEBUG-SOURCEs later.
+               :pathname-2 (unless (equal (merge-pathnames pathname) pathname)
+                             *default-pathname-defaults*)
+               :external-format external-format
+               :subforms (if form-tracking-p
+                             (make-array 100 :fill-pointer 0 :adjustable t))
+               ;; FIXME: this shouldn't have to be initialized here,
+               ;; but delaying it till GET-SOURCE-STREAM somehow
+               ;; prevents it from showing up in DEBUG-SOURCEs later.
+               :write-date (file-write-date pathname))))

 ;; LOAD-AS-SOURCE uses this.
 (defun make-file-stream-source-info (file-stream)
@ -862,7 +860,7 @@ necessary, since type inference may take arbitrarily long to converge.")
   :file-info (make-file-info :truename (truename file-stream)
                              ;; This T-L-P has been around since at least 2011.
                              ;; It's unclear why an LPN isn't good enough.
-                              :pathname (translate-logical-pathname file-stream)
+                              :pathname-1 (translate-logical-pathname file-stream)
                              :external-format (stream-external-format file-stream)
                              :write-date (file-write-date file-stream))))

@ -903,7 +901,7 @@ necessary, since type inference may take arbitrarily long to converge.")
  (declare (type source-info info))
  (or (source-info-stream info)
      (let* ((file-info (source-info-file-info info))
-             (pathname (file-info-pathname file-info))
+             (pathname (file-info-pathname-1 file-info))
             (external-format (file-info-external-format file-info)))
        (let ((stream
               (open pathname
@ -912,12 +910,17 @@ necessary, since type inference may take arbitrarily long to converge.")
                     ;; SBCL stream classes aren't available in the host
                     #-sb-xc-host :class
                     #-sb-xc-host 'form-tracking-stream)))
-          ;; If you don't want merged pathnames embedded in your build artifacts,
-          ;; then you surely don't want them in *COMPILE-FILE-PATHNAME* either.
-          ;; [And can't we just bind this to PATHNAME is all cases? If anything,
-          ;; it seems to me that asking the stream for its name is expressly backwards]
-          (setf *compile-file-pathname* (if *merge-pathnames* (pathname stream) pathname)
+          ;; OPEN is required to merge PATHNAME, and the FILE-STREAM
+          ;; is required to return that merge from #'PATHNAME. So we
+          ;; can get the merged pathname we used to open the file from
+          ;; the stream itself.
+          (setf *compile-file-pathname* (pathname stream)
                *compile-file-truename* (truename stream)
+                ;; FIXME: it ought to be possible to defer setting the
+                ;; PATHNAME-2 and WRITE-DATE slots to here (i.e.,
+                ;; delaying some work/computation till we know we've
+                ;; got an open file), but doing so somehow leaves the
+                ;; corresponding slots NIL in DEBUG-SOURCEs later.
                (file-info-truename file-info) *compile-file-truename*)
          (when (file-info-subforms file-info)
            (setf (form-tracking-stream-observer stream)
@ -1835,6 +1838,9 @@ necessary, since type inference may take arbitrarily long to converge.")
       (values t t t)))))

 ;;; Return a pathname for the named file. The file must exist.
+;; FIXME: is this anything other than a merge-pathnames wrapped in a
+;; minor time-of-check/time-of-use bug?  OPEN will surely tell us if
+;; the file doesn't exist.
 (defun verify-source-file (pathname-designator)
  (let* ((pathname (pathname pathname-designator))
         (default-host (make-pathname :host (pathname-host pathname))))
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@ -2828,7 +2828,8 @@ bootstrapping.
                            (debug-source (sb-c::debug-info-source debug-info))
                            (debug-fun (debug-info-debug-function function debug-info)))
                       (sb-c::%make-definition-source-location
-                        (sb-c::debug-source-namestring debug-source)
+                        (sb-c::debug-source-namestring-1 debug-source)
+                        (sb-c::debug-source-namestring-2 debug-source)
                        (sb-c::compiled-debug-info-tlf-number debug-info)
                        (sb-c::compiled-debug-fun-form-number debug-fun))))
                   (debug-info-debug-function (function debug-info)
--- a/tools-for-build/editcore.lisp
+++ b/tools-for-build/editcore.lisp
@ -1069,9 +1069,12 @@
              (let* ((source
                      (sb-c::compiled-debug-info-source
                       (truly-the sb-c::compiled-debug-info
-                                  (translate (%code-debug-info code) spaces))))
+                        (translate (%code-debug-info code) spaces))))
+                     ;; FIXME: we used to have just one namestring in
+                     ;; the debug-source, now we've got two, and this
+                     ;; ignores one of them.
                     (namestring
-                      (debug-source-namestring
+                      (sb-c::debug-source-namestring-1
                       (truly-the sb-c::debug-source (translate source spaces)))))
                (setq namestring (if (eq namestring (core-nil-object core))
                                     "sbcl.core"