1.0.27.31: repeatable fasl header and debug-source

The fasl header is easy to deal with; writing "at cross-compile time"
instead of something depending on the host is easy.  The debug-source is
harder; we set the structure slots to 0 in the cross-compiler, and
arrange for cold-init to patch sensible values in (by inventing a new
FOP to note the debug-source's arrival).

made up of 5 commits, whose individual messages follow:

deal with trivial volatile contents of fasl files

Don't try to preserve, even in the header, information about which
implementation or machine was used for the compilation.

Similarly, don't emit the timestamps in the debug-source into the fasls.

comments: delete a FIXME and explain a bare `2'

consistent source pathname for output/stuff-groveled-from-headers.lisp

At the moment it's the only compiled file not in src/; code defensively
around that fact.

fix a longstanding KLUDGE

Find the index of the source slot by introspection rather than using a
baffling literal `2'.  Unfortunately, in doing so we run into bug #117.

patch in the source created/compiled information in cold-init

We can't do it before without making our fasls or cold-sbcl.core
dependent on filesystem timestamps or current time.  The way we do it is
perhaps overcomplicated, compared with simply assuming that the file
timestamps are right, but has the advantage that it's demonstrably
correct: we implement a new FOP specifically for noting our
DEBUG-SOURCE, dumped only during cross-compilation, and in genesis we
interpret that FOP to build a list of debug-sources, which we can frob
in cold-init.

Everything should now be restored to its previous functionality.

diff --git a/build-order.lisp-expr b/build-order.lisp-expr
index a164c6f..70e040b 100644 (file)
--- a/build-order.lisp-expr
+++ b/build-order.lisp-expr
@@ -497,6 +497,7 @@
 
  ("src/compiler/trace-table") ; needs EMIT-LABEL macro from compiler/assem.lisp
 
+ ("src/code/debug-info")
  ;; Compiling this requires fop definitions from code/fop.lisp and
  ;; trace table definitions from compiler/trace-table.lisp.
  ("src/compiler/dump")
@@ -531,8 +532,6 @@
  ("src/compiler/tn")
  ("src/compiler/life")
 
- ("src/code/debug-info")
-
  ("src/compiler/debug-dump")
  ("src/compiler/generic/utils")
  ("src/compiler/fopcompile")

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 45cde20..50175f8 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1408,6 +1408,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "HANDLE-CIRCULARITY" "HOST" "IGNORE-IT" "ILL-BIN"
                "ILL-BOUT" "ILL-IN" "ILL-OUT" "INDEX-OR-MINUS-1"
                "INDEX-TOO-LARGE-ERROR" "*!INITIAL-ASSEMBLER-ROUTINES*"
+               "*!INITIAL-DEBUG-SOURCES*"
                "*!INITIAL-FDEFN-OBJECTS*" "*!INITIAL-FOREIGN-SYMBOLS*"
                "*!INITIAL-LAYOUTS*" "*!INITIAL-SYMBOLS*"
                "INTEGER-DECODE-DOUBLE-FLOAT"
@@ -1799,6 +1800,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "!EARLY-TYPE-COLD-INIT" "!LATE-TYPE-COLD-INIT"
                "!FIXUP-TYPE-COLD-INIT" "!TARGET-TYPE-COLD-INIT"
                "!RANDOM-COLD-INIT" "!READER-COLD-INIT"
+               "!PATHNAME-COLD-INIT" "!DEBUG-INFO-COLD-INIT"
                "!TYPECHECKFUNS-COLD-INIT" "!LOADER-COLD-INIT"
                "!EXHAUST-COLD-INIT" "!PACKAGE-COLD-INIT"
                "!POLICY-COLD-INIT-OR-RESANIFY"

diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index b9b1994..370681d 100644 (file)
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -223,6 +223,8 @@
   (show-and-call !late-proclaim-cold-init)
 
   (show-and-call os-cold-init-or-reinit)
+  (show-and-call !pathname-cold-init)
+  (show-and-call !debug-info-cold-init)
 
   (show-and-call stream-cold-init-or-reset)
   (show-and-call !loader-cold-init)

diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp
index 2e02456..bc09934 100644 (file)
--- a/src/code/debug-info.lisp
+++ b/src/code/debug-info.lisp
@@ -278,13 +278,15 @@
   (name (missing-arg) :type t)
   ;; A list of DEBUG-SOURCE structures describing where the code for this
   ;; component came from, in the order that they were read.
-  ;;
-  ;; KLUDGE: comment from CMU CL:
-  ;;   *** NOTE: the offset of this slot is wired into the fasl dumper
-  ;;   *** so that it can backpatch the source info when compilation
-  ;;   *** is complete.
   (source nil))
 
+(defconstant +debug-info-source-index+
+  (let* ((dd (find-defstruct-description 'debug-info))
+         (slots (dd-slots dd))
+         (source (locally (declare (notinline find)) ; bug 117 bogowarning
+                   (find 'source slots :key #'dsd-name))))
+    (dsd-index source)))
+
 (def!struct (compiled-debug-info
              (:include debug-info)
              #-sb-xc-host (:pure t))
@@ -301,3 +303,13 @@
   ;; works? Would this break if we used a more general memory map? --
   ;; WHN 20000120
   (fun-map (missing-arg) :type simple-vector :read-only t))
+
+(defvar *!initial-debug-sources*)
+
+(defun !debug-info-cold-init ()
+  (let ((now (get-universal-time)))
+    (dolist (debug-source *!initial-debug-sources*)
+      (let* ((namestring (debug-source-namestring debug-source))
+             (timestamp (file-write-date namestring)))
+        (setf (debug-source-created debug-source) timestamp
+              (debug-source-compiled debug-source) now)))))

diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 655b6e9..d9acdd5 100644 (file)
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -639,6 +639,17 @@ bug.~:@>")
         (name (pop-stack)))
     (setf (fdefinition name) fn)))
 
+(define-fop (fop-note-debug-source 174 :pushp nil)
+  (warn "~@<FOP-NOTE-DEBUG-SOURCE seen in ordinary load (not cold load) -- ~
+very strange!  If you didn't do something to cause this, please report it as ~
+a bug.~@:>")
+  ;; as with COLD-FSET above, we are going to be lenient with coming
+  ;; across this fop in a warm SBCL.
+  (let ((debug-source (pop-stack)))
+    (setf (sb!c::debug-source-compiled debug-source) (get-universal-time)
+          (sb!c::debug-source-created debug-source)
+          (file-write-date (sb!c::debug-source-namestring debug-source)))))
+
 ;;; Modify a slot in a CONSTANTS object.
 (define-cloned-fops (fop-alter-code 140 :pushp nil) (fop-byte-alter-code 141)
   (let ((value (pop-stack))

diff --git a/src/code/source-location.lisp b/src/code/source-location.lisp
index be5d1fd..7eb411b 100644 (file)
--- a/src/code/source-location.lisp
+++ b/src/code/source-location.lisp
@@ -36,11 +36,13 @@
     #+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)))
+      (cond
+        (src (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
+                     (subseq dir src) (pathname-name untruename)))
+        (t (aver (string-equal (car (last dir)) "output"))
+           (aver (string-equal (pathname-name untruename) "stuff-groveled-from-headers"))
+           (aver (string-equal (pathname-type untruename) "lisp"))
+           "SYS:OUTPUT;STUFF-GROVELED-FROM-HEADERS.LISP")))
     #-sb-xc-host
     (if (and dir (eq (first dir) :absolute))
         (namestring untruename)

diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 109f639..81da10f 100644 (file)
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -1704,3 +1704,24 @@ system's syntax for files."
       ;; might be cute to search in "SYS:TRANSLATIONS;<name>.LISP"
       (error "logical host ~S not found" host)))
 
+(defun !pathname-cold-init ()
+  (let* ((sys *default-pathname-defaults*)
+         (src
+          (merge-pathnames
+           (make-pathname :directory '(:relative "src" :wild-inferiors)
+                          :name :wild :type :wild)
+           sys))
+         (contrib
+          (merge-pathnames
+           (make-pathname :directory '(:relative "contrib" :wild-inferiors)
+                          :name :wild :type :wild)
+           sys))
+         (output
+          (merge-pathnames
+           (make-pathname :directory '(:relative "output" :wild-inferiors)
+                          :name :wild :type :wild)
+           sys)))
+    (setf (logical-pathname-translations "SYS")
+          `(("SYS:SRC;**;*.*.*" ,src)
+            ("SYS:CONTRIB;**;*.*.*" ,contrib)
+            ("SYS:OUTPUT;**;*.*.*" ,output)))))

diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp
index 6fd757b..37149cf 100644 (file)
--- a/src/cold/warm.lisp
+++ b/src/cold/warm.lisp
@@ -65,21 +65,6 @@
 \f
 ;;;; compiling and loading more of the system
 
-(let* ((sys *default-pathname-defaults*)
-       (src
-        (merge-pathnames
-         (make-pathname :directory '(:relative "src" :wild-inferiors)
-                        :name :wild :type :wild)
-         sys))
-       (contrib
-        (merge-pathnames
-         (make-pathname :directory '(:relative "contrib" :wild-inferiors)
-                        :name :wild :type :wild)
-         sys)))
-  (setf (logical-pathname-translations "SYS")
-        `(("SYS:SRC;**;*.*.*" ,src)
-          ("SYS:CONTRIB;**;*.*.*" ,contrib))))
-
 ;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
 ;;; COMPILE-PCL, at least some of which we should probably have too:
 ;;;

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 1b51237..2f1958d 100644 (file)
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -312,8 +312,10 @@
                     on ~A~%  ~
                     using ~A version ~A~%"
                    where
-                   (format-universal-time nil (get-universal-time))
-                   (machine-instance)
+                   #+sb-xc-host "cross-compile time"
+                   #-sb-xc-host (format-universal-time nil (get-universal-time))
+                   #+sb-xc-host "cross-compile host"
+                   #-sb-xc-host (machine-instance)
                    (sb!xc:lisp-implementation-type)
                    (sb!xc:lisp-implementation-version))))
        stream)
@@ -1309,14 +1311,19 @@
   (declare (type sb!c::source-info info))
   (let ((res (sb!c::debug-source-for-info info))
         (*dump-only-valid-structures* nil))
+    #+sb-xc-host (setf (sb!c::debug-source-created res) 0
+                       (sb!c::debug-source-compiled res) 0)
     (dump-object res fasl-output)
     (let ((res-handle (dump-pop fasl-output)))
       (dolist (info-handle (fasl-output-debug-info fasl-output))
         (dump-push res-handle fasl-output)
         (dump-fop 'fop-structset fasl-output)
         (dump-word info-handle fasl-output)
-        ;; FIXME: what is this bare `2'?  --njf, 2004-08-16
-        (dump-word 2 fasl-output))))
+        (dump-word sb!c::+debug-info-source-index+ fasl-output))
+      #+sb-xc-host
+      (progn
+        (dump-push res-handle fasl-output)
+        (dump-fop 'fop-note-debug-source fasl-output))))
   (setf (fasl-output-debug-info fasl-output) nil)
   (values))
 \f

diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp
index 05fe744..7549400 100644 (file)
--- a/src/compiler/early-c.lisp
+++ b/src/compiler/early-c.lisp
@@ -106,6 +106,7 @@
 (defvar *info-environment*)
 (defvar *lexenv*)
 (defvar *source-info*)
+(defvar *source-plist*)
 (defvar *trace-table*)
 (defvar *undefined-warnings*)
 (defvar *warnings-p*)

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 07e0fc3..ef67095 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -509,6 +509,10 @@
 ;;; purposes.
 (defvar *current-reversed-cold-toplevels*)
 
+;;; the head of a list of DEBUG-SOURCEs which need to be patched when
+;;; the cold core starts up
+(defvar *current-debug-sources*)
+
 ;;; the name of the object file currently being cold loaded (as a string, not a
 ;;; pathname), or NIL if we're not currently cold loading any object file
 (defvar *cold-load-filename* nil)
@@ -1357,6 +1361,7 @@ core and return a descriptor to it."
   (cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
 
   (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
+  (cold-set '*!initial-debug-sources* *current-debug-sources*)
 
   #!+(or x86 x86-64)
   (progn
@@ -2403,6 +2408,10 @@ core and return a descriptor to it."
         (setf (gethash warm-name *cold-fset-warm-names*) t))
     (static-fset cold-name fn)))
 
+(define-cold-fop (fop-note-debug-source :pushp nil)
+  (let ((debug-source (pop-stack)))
+    (cold-push debug-source *current-debug-sources*)))
+
 (define-cold-fop (fop-fdefinition)
   (cold-fdefinition-object (pop-stack)))
 
@@ -3218,6 +3227,7 @@ initially undefined function references:~2%")
                                      #!-gencgc sb!vm:dynamic-0-space-start))
            (*nil-descriptor* (make-nil-descriptor))
            (*current-reversed-cold-toplevels* *nil-descriptor*)
+           (*current-debug-sources* *nil-descriptor*)
            (*unbound-marker* (make-other-immediate-descriptor
                               0
                               sb!vm:unbound-marker-widetag))

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 7cb638b..dffb4d0 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -210,9 +210,6 @@
                do (entries `((eql ,n-supplied ,n)
                              (%funcall ,(force ep) ,@(subseq temps 0 n)))))
          `(lambda (,n-supplied ,@temps)
-            ;; FIXME: Make sure that INDEX type distinguishes between
-            ;; target and host. (Probably just make the SB!XC:DEFTYPE
-            ;; different from CL:DEFTYPE.)
             (declare (type index ,n-supplied))
             (cond
              ,@(if more (butlast (entries)) (entries))

diff --git a/version.lisp-expr b/version.lisp-expr
index 4b9229e..3dc114a 100644 (file)
--- 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".)
-"1.0.27.30"
+"1.0.27.31"