X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=5ca2b23abc48981ec97cbb11fc894efb244a53a0;hb=d306e2d23b38487488eb93881dad836e439e0c77;hp=a296451d2683561355cb09692fcace8e66107757;hpb=a0c5831b3a74118cf41a848300200a1acdb48dcf;p=sbcl.git

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index a296451..5ca2b23 100644
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -91,10 +91,6 @@
 ;;; dumping uses the table.
 (defvar *circularities-detected*)
 
-;;; used to inhibit table access when dumping forms to be read by the
-;;; cold loader
-(defvar *cold-load-dump* nil)
-
 ;;; used to turn off the structure validation during dumping of source
 ;;; info
 (defvar *dump-only-valid-structures* t)
@@ -194,161 +190,145 @@
     (incf (fasl-output-table-free fasl-output))))
 
 ;;; If X is in File's EQUAL-TABLE, then push the object and return T,
-;;; otherwise NIL. If *COLD-LOAD-DUMP* is true, then do nothing and
-;;; return NIL.
+;;; otherwise NIL.
 (defun equal-check-table (x fasl-output)
   (declare (type fasl-output fasl-output))
-  (unless *cold-load-dump*
-    (let ((handle (gethash x (fasl-output-equal-table fasl-output))))
-      (cond
-        (handle (dump-push handle fasl-output) t)
-        (t nil)))))
+  (let ((handle (gethash x (fasl-output-equal-table fasl-output))))
+    (cond
+     (handle (dump-push handle fasl-output) t)
+     (t nil))))
 (defun string-check-table (x fasl-output)
   (declare (type fasl-output fasl-output)
            (type string x))
-  (unless *cold-load-dump*
-    (let ((handle (cdr (assoc
-                        (array-element-type x)
-                        (gethash x (fasl-output-equal-table fasl-output))))))
-      (cond
-        (handle (dump-push handle fasl-output) t)
-        (t nil)))))
+  (let ((handle (cdr (assoc
+                      #+sb-xc-host 'base-char ; for repeatable xc fasls
+                      #-sb-xc-host (array-element-type x)
+                      (gethash x (fasl-output-equal-table fasl-output))))))
+    (cond
+     (handle (dump-push handle fasl-output) t)
+     (t nil))))
 
 ;;; These functions are called after dumping an object to save the
 ;;; object in the table. The object (also passed in as X) must already
-;;; be on the top of the FOP stack. If *COLD-LOAD-DUMP* is true, then
-;;; we don't do anything.
+;;; be on the top of the FOP stack.
 (defun eq-save-object (x fasl-output)
   (declare (type fasl-output fasl-output))
-  (unless *cold-load-dump*
-    (let ((handle (dump-pop fasl-output)))
-      (setf (gethash x (fasl-output-eq-table fasl-output)) handle)
-      (dump-push handle fasl-output)))
+  (let ((handle (dump-pop fasl-output)))
+    (setf (gethash x (fasl-output-eq-table fasl-output)) handle)
+    (dump-push handle fasl-output))
   (values))
 (defun equal-save-object (x fasl-output)
   (declare (type fasl-output fasl-output))
-  (unless *cold-load-dump*
-    (let ((handle (dump-pop fasl-output)))
-      (setf (gethash x (fasl-output-equal-table fasl-output)) handle)
-      (setf (gethash x (fasl-output-eq-table fasl-output)) handle)
-      (dump-push handle fasl-output)))
+  (let ((handle (dump-pop fasl-output)))
+    (setf (gethash x (fasl-output-equal-table fasl-output)) handle)
+    (setf (gethash x (fasl-output-eq-table fasl-output)) handle)
+    (dump-push handle fasl-output))
   (values))
 (defun string-save-object (x fasl-output)
   (declare (type fasl-output fasl-output)
            (type string x))
-  (unless *cold-load-dump*
-    (let ((handle (dump-pop fasl-output)))
-      (push (cons (array-element-type x) handle)
-            (gethash x (fasl-output-equal-table fasl-output)))
-      (setf (gethash x (fasl-output-eq-table fasl-output)) handle)
-      (dump-push handle fasl-output)))
+  (let ((handle (dump-pop fasl-output)))
+    (push (cons #+sb-xc-host 'base-char ; repeatable xc fasls
+                #-sb-xc-host (array-element-type x)
+                handle)
+          (gethash x (fasl-output-equal-table fasl-output)))
+    (setf (gethash x (fasl-output-eq-table fasl-output)) handle)
+    (dump-push handle fasl-output))
   (values))
-;;; Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is
-;;; true. This is called on objects that we are about to dump might
-;;; have a circular path through them.
+;;; Record X in File's CIRCULARITY-TABLE. This is called on objects
+;;; that we are about to dump might have a circular path through them.
 ;;;
 ;;; The object must not currently be in this table, since the dumper
 ;;; should never be recursively called on a circular reference.
 ;;; Instead, the dumping function must detect the circularity and
 ;;; arrange for the dumped object to be patched.
 (defun note-potential-circularity (x fasl-output)
-  (unless *cold-load-dump*
-    (let ((circ (fasl-output-circularity-table fasl-output)))
-      (aver (not (gethash x circ)))
-      (setf (gethash x circ) x)))
-  (values))
-
-;;; Dump FORM to a fasl file so that it evaluated at load time in normal
-;;; load and at cold-load time in cold load. This is used to dump package
-;;; frobbing forms.
-(defun fasl-dump-cold-load-form (form fasl-output)
-  (declare (type fasl-output fasl-output))
-  (dump-fop 'fop-normal-load fasl-output)
-  (let ((*cold-load-dump* t))
-    (dump-object form fasl-output))
-  (dump-fop 'fop-eval-for-effect fasl-output)
-  (dump-fop 'fop-maybe-cold-load fasl-output)
+  (let ((circ (fasl-output-circularity-table fasl-output)))
+    (aver (not (gethash x circ)))
+    (setf (gethash x circ) x))
   (values))
 
 ;;;; opening and closing fasl files
 
-;;; A utility function to write strings to (unsigned-byte 8) streams.
-;;; We restrict this to ASCII (with the averrance) because of
-;;; ambiguity of higher bytes: Unicode, some ISO-8859-x, or what? This
-;;; could be revisited in the event of doing funky things with stream
-;;; encodings -- CSR, 2002-04-25
-(defun fasl-write-string (string stream)
-  (loop for char across string
-        do (let ((code (char-code char)))
-             (aver (<= 0 code 127))
-             (write-byte code stream))))
-
 ;;; Open a fasl file, write its header, and return a FASL-OUTPUT
 ;;; object for dumping to it. Some human-readable information about
 ;;; the source code is given by the string WHERE.
 (defun open-fasl-output (name where)
   (declare (type pathname name))
-  (let* ((stream (open name
-                       :direction :output
-                       :if-exists :supersede
-                       :element-type 'sb!assem:assembly-unit))
-         (res (make-fasl-output :stream stream)))
-
-    ;; Begin the header with the constant machine-readable (and
-    ;; semi-human-readable) string which is used to identify fasl files.
-    (fasl-write-string *fasl-header-string-start-string* stream)
-
-    ;; The constant string which begins the header is followed by
-    ;; arbitrary human-readable text, terminated by a special
-    ;; character code.
-    (fasl-write-string
-     (with-standard-io-syntax
-       (let ((*print-readably* nil)
-             (*print-pretty* nil))
-         (format nil
-                 "~%  ~
-                  compiled from ~S~%  ~
-                  at ~A~%  ~
-                  on ~A~%  ~
-                  using ~A version ~A~%"
-         where
-                 (format-universal-time nil (get-universal-time))
-                 (machine-instance)
-                 (sb!xc:lisp-implementation-type)
-                 (sb!xc:lisp-implementation-version))))
-     stream)
-    (dump-byte +fasl-header-string-stop-char-code+ res)
-
-    ;; Finish the header by outputting fasl file implementation,
-    ;; version, and key *FEATURES*.
-    (flet ((dump-counted-string (string)
-             ;; The count is dumped as a 32-bit unsigned-byte even on 64-bit
-             ;; platforms. This ensures that a x86-64 SBCL can gracefully
-             ;; detect an error when trying to read a x86 fasl, instead
-             ;; of choking on a ridiculously long counted string.
-             ;;  -- JES, 2005-12-30
-             (dump-unsigned-byte-32 (length string) res)
-             (dotimes (i (length string))
-               (dump-byte (char-code (aref string i)) res))))
-      (dump-counted-string (symbol-name +backend-fasl-file-implementation+))
-      (dump-word +fasl-file-version+ res)
-      (dump-counted-string *features-affecting-fasl-format*))
-
-    res))
+  (flet ((fasl-write-string (string stream)
+           ;; SB-EXT:STRING-TO-OCTETS is not available while cross-compiling
+           #+sb-xc-host
+           (loop for char across string
+                 do (let ((code (char-code char)))
+                      (unless (<= 0 code 127)
+                        (setf char #\?))
+                      (write-byte code stream)))
+           ;; UTF-8 is safe to use, because +FASL-HEADER-STRING-STOP-CHAR-CODE+
+           ;; may not appear in UTF-8 encoded bytes
+           #-sb-xc-host
+           (write-sequence (string-to-octets string :external-format :utf-8)
+                           stream)))
+    (let* ((stream (open name
+                         :direction :output
+                         :if-exists :supersede
+                         :element-type 'sb!assem:assembly-unit))
+           (res (make-fasl-output :stream stream)))
+      ;; Before the actual FASL header, write a shebang line using the current
+      ;; runtime path, so our fasls can be executed directly from the shell.
+      (when *runtime-pathname*
+        (fasl-write-string
+         (format nil "#!~A --script~%"
+                 (native-namestring *runtime-pathname* :as-file t))
+         stream))
+      ;; Begin the header with the constant machine-readable (and
+      ;; semi-human-readable) string which is used to identify fasl files.
+      (fasl-write-string *fasl-header-string-start-string* stream)
+      ;; The constant string which begins the header is followed by
+      ;; arbitrary human-readable text, terminated by
+      ;; +FASL-HEADER-STRING-STOP-CHAR-CODE+.
+      (fasl-write-string
+       (with-standard-io-syntax
+         (let ((*print-readably* nil)
+               (*print-pretty* nil))
+           (format nil
+                   "~%  ~
+                    compiled from ~S~%  ~
+                    using ~A version ~A~%"
+                   where
+                   (sb!xc:lisp-implementation-type)
+                   (sb!xc:lisp-implementation-version))))
+       stream)
+      (dump-byte +fasl-header-string-stop-char-code+ res)
+      ;; Finish the header by outputting fasl file implementation,
+      ;; version, and key *FEATURES*.
+      (flet ((dump-counted-string (string)
+               ;; The count is dumped as a 32-bit unsigned-byte even on 64-bit
+               ;; platforms. This ensures that a x86-64 SBCL can gracefully
+               ;; detect an error when trying to read a x86 fasl, instead
+               ;; of choking on a ridiculously long counted string.
+               ;;  -- JES, 2005-12-30
+               (dump-unsigned-byte-32 (length string) res)
+               (dotimes (i (length string))
+                 (dump-byte (char-code (aref string i)) res))))
+        (dump-counted-string (symbol-name +backend-fasl-file-implementation+))
+        (dump-word +fasl-file-version+ res)
+        (dump-counted-string (sb!xc:lisp-implementation-version))
+        (dump-counted-string *features-affecting-fasl-format*))
+      res)))
 
 ;;; Close the specified FASL-OUTPUT, aborting the write if ABORT-P.
 (defun close-fasl-output (fasl-output abort-p)
   (declare (type fasl-output fasl-output))
 
-  ;; sanity checks
-  (aver (zerop (hash-table-count (fasl-output-patch-table fasl-output))))
-
-  ;; End the group.
-  (dump-fop 'fop-verify-empty-stack fasl-output)
-  (dump-fop 'fop-verify-table-size fasl-output)
-  (dump-word (fasl-output-table-free fasl-output)
-                    fasl-output)
-  (dump-fop 'fop-end-group fasl-output)
+  (unless abort-p
+    ;; sanity checks
+    (aver (zerop (hash-table-count (fasl-output-patch-table fasl-output))))
+    ;; End the group.
+    (dump-fop 'fop-verify-empty-stack fasl-output)
+    (dump-fop 'fop-verify-table-size fasl-output)
+    (dump-word (fasl-output-table-free fasl-output)
+               fasl-output)
+    (dump-fop 'fop-end-group fasl-output))
 
   ;; That's all, folks.
   (close (fasl-output-stream fasl-output) :abort abort-p)
@@ -366,7 +346,7 @@
 ;;; When we go to dump the object, we enter it in the CIRCULARITY-TABLE.
 (defun dump-non-immediate-object (x file)
   (let ((index (gethash x (fasl-output-eq-table file))))
-    (cond ((and index (not *cold-load-dump*))
+    (cond (index
            (dump-push index file))
           (t
            (typecase x
@@ -409,6 +389,14 @@
                   (float (dump-float x file))
                   (integer (dump-integer x file)))
                 (equal-save-object x file)))
+             #!+sb-simd-pack
+             (simd-pack
+              (unless (equal-check-table x file)
+                (dump-fop 'fop-simd-pack file)
+                (dump-integer-as-n-bytes (%simd-pack-tag  x) 8 file)
+                (dump-integer-as-n-bytes (%simd-pack-low  x) 8 file)
+                (dump-integer-as-n-bytes (%simd-pack-high x) 8 file))
+              (equal-save-object x file))
              (t
               ;; This probably never happens, since bad things tend to
               ;; be detected during IR1 conversion.
@@ -562,37 +550,55 @@
      (dump-fop 'fop-long-float file)
      (dump-long-float x file))))
 
+(defun dump-complex-single-float (re im file)
+  (declare (single-float re im))
+  (dump-fop 'fop-complex-single-float file)
+  (dump-integer-as-n-bytes (single-float-bits re) 4 file)
+  (dump-integer-as-n-bytes (single-float-bits im) 4 file))
+
+(defun dump-complex-double-float (re im file)
+  (declare (double-float re im))
+  (dump-fop 'fop-complex-double-float file)
+  (dump-integer-as-n-bytes (double-float-low-bits re) 4 file)
+  (dump-integer-as-n-bytes (double-float-high-bits re) 4 file)
+  (dump-integer-as-n-bytes (double-float-low-bits im) 4 file)
+  (dump-integer-as-n-bytes (double-float-high-bits im) 4 file))
+
+(defun dump-complex-rational (re im file)
+  (sub-dump-object re file)
+  (sub-dump-object im file)
+  (dump-fop 'fop-complex file))
+
+#+sb-xc-host
+(defun dump-complex (x file)
+  (let ((re (realpart x))
+        (im (imagpart x)))
+    (cond ((and (typep re 'single-float)
+                (typep im 'single-float))
+           (dump-complex-single-float re im file))
+          ((and (typep re 'double-float)
+                (typep im 'double-float))
+           (dump-complex-double-float re im file))
+          ((and (typep re 'rational)
+                (typep im 'rational))
+           (dump-complex-rational re im file))
+          (t
+           (bug "Complex number too complex: ~S" x)))))
+
+#-sb-xc-host
 (defun dump-complex (x file)
   (typecase x
-    #-sb-xc-host
     ((complex single-float)
-     (dump-fop 'fop-complex-single-float file)
-     (dump-integer-as-n-bytes (single-float-bits (realpart x)) 4 file)
-     (dump-integer-as-n-bytes (single-float-bits (imagpart x)) 4 file))
-    #-sb-xc-host
+     (dump-complex-single-float (realpart x) (imagpart x) file))
     ((complex double-float)
-     (dump-fop 'fop-complex-double-float file)
-     (let ((re (realpart x)))
-       (declare (double-float re))
-       (dump-integer-as-n-bytes (double-float-low-bits re) 4 file)
-       (dump-integer-as-n-bytes (double-float-high-bits re) 4 file))
-     (let ((im (imagpart x)))
-       (declare (double-float im))
-       (dump-integer-as-n-bytes (double-float-low-bits im) 4 file)
-       (dump-integer-as-n-bytes (double-float-high-bits im) 4 file)))
+     (dump-complex-double-float (realpart x) (imagpart x) file))
     #!+long-float
     ((complex long-float)
-     ;; (There's no easy way to mix #!+LONG-FLOAT and #-SB-XC-HOST
-     ;; conditionalization at read time, so we do this SB-XC-HOST
-     ;; conditional at runtime instead.)
-     #+sb-xc-host (error "can't dump COMPLEX-LONG-FLOAT in cross-compiler")
      (dump-fop 'fop-complex-long-float file)
      (dump-long-float (realpart x) file)
      (dump-long-float (imagpart x) file))
     (t
-     (sub-dump-object (realpart x) file)
-     (sub-dump-object (imagpart x) file)
-     (dump-fop 'fop-complex file))))
+     (dump-complex-rational (realpart x) (imagpart x) file))))
 
 ;;;; symbol dumping
 
@@ -609,21 +615,16 @@
   (declare (inline assoc))
   (cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq)))
         (t
-         (unless *cold-load-dump*
-           (dump-fop 'fop-normal-load file))
-         #+sb-xc-host
-         (dump-simple-base-string
-          (coerce (package-name pkg) 'simple-base-string)
-          file)
-         #-sb-xc-host
-         (#!+sb-unicode dump-simple-character-string
-          #!-sb-unicode dump-simple-base-string
-          (coerce (package-name pkg) '(simple-array character (*)))
-          file)
-         (dump-fop 'fop-package file)
-         (unless *cold-load-dump*
-           (dump-fop 'fop-maybe-cold-load file))
-         (let ((entry (dump-pop file)))
+         (let ((s (package-name pkg)))
+           (dump-fop* (length s) fop-small-named-package-save fop-named-package-save file)
+           #+sb-xc-host
+           (dump-base-chars-of-string (coerce s 'simple-base-string) file)
+           #-sb-xc-host
+           (#!+sb-unicode dump-characters-of-string
+            #!-sb-unicode dump-base-chars-of-string
+            (coerce s '(simple-array character (*))) file))
+         (let ((entry (fasl-output-table-free file)))
+           (incf (fasl-output-table-free file))
            (push (cons pkg entry) (fasl-output-packages file))
            entry))))
 
@@ -643,9 +644,6 @@
 ;;;
 ;;; Otherwise, we recursively call the dumper to dump the current
 ;;; element.
-;;;
-;;; Marking of the conses is inhibited when *COLD-LOAD-DUMP* is true.
-;;; This inhibits all circularity detection.
 (defun dump-list (list file)
   (aver (and list
              (not (gethash list (fasl-output-circularity-table file)))))
@@ -670,8 +668,7 @@
         (terminate-undotted-list n file)
         (return)))
 
-    (unless *cold-load-dump*
-      (setf (gethash l circ) list))
+    (setf (gethash l circ) list)
 
     (let* ((obj (car l))
            (ref (gethash obj circ)))
@@ -771,28 +768,8 @@
       (simple-vector
        (dump-simple-vector simple-version file)
        (eq-save-object x file))
-      ((simple-array single-float (*))
-       (dump-single-float-vector simple-version file)
-       (eq-save-object x file))
-      ((simple-array double-float (*))
-       (dump-double-float-vector simple-version file)
-       (eq-save-object x file))
-      #!+long-float
-      ((simple-array long-float (*))
-       (dump-long-float-vector simple-version file)
-       (eq-save-object x file))
-      ((simple-array (complex single-float) (*))
-       (dump-complex-single-float-vector simple-version file)
-       (eq-save-object x file))
-      ((simple-array (complex double-float) (*))
-       (dump-complex-double-float-vector simple-version file)
-       (eq-save-object x file))
-      #!+long-float
-      ((simple-array (complex long-float) (*))
-       (dump-complex-long-float-vector simple-version file)
-       (eq-save-object x file))
       (t
-       (dump-i-vector simple-version file)
+       (dump-specialized-vector simple-version file)
        (eq-save-object x file)))))
 
 ;;; Dump a SIMPLE-VECTOR, handling any circularities.
@@ -819,120 +796,51 @@
 
 ;;; In the grand scheme of things I don't pretend to understand any
 ;;; more how this works, or indeed whether.  But to write out specialized
-;;; vectors in the same format as fop-int-vector expects to read them
+;;; vectors in the same format as fop-spec-vector expects to read them
 ;;; we need to be target-endian.  dump-integer-as-n-bytes always writes
 ;;; little-endian (which is correct for all other integers) so for a bigendian
 ;;; target we need to swap octets -- CSR, after DB
-
-(defun octet-swap (word bits)
-  "BITS must be a multiple of 8"
-  (do ((input word (ash input -8))
-       (output 0 (logior (ash output 8) (logand input #xff)))
-       (bits bits (- bits 8)))
-      ((<= bits 0) output)))
-
-(defun dump-i-vector (vec file &key data-only)
-  (declare (type (simple-array * (*)) vec))
-  (let ((len (length vec)))
-    (labels ((dump-unsigned-vector (size bytes)
-               (unless data-only
-                 (dump-fop 'fop-int-vector file)
-                 (dump-word len file)
-                 (dump-byte size file))
-               ;; The case which is easy to handle in a portable way is when
-               ;; the element size is a multiple of the output byte size, and
-               ;; happily that's the only case we need to be portable. (The
-               ;; cross-compiler has to output debug information (including
-               ;; (SIMPLE-ARRAY (UNSIGNED-BYTE 8) *).) The other cases are only
-               ;; needed in the target SBCL, so we let them be handled with
-               ;; unportable bit bashing.
-               (cond ((>= size 7) ; easy cases
-                      (multiple-value-bind (floor rem) (floor size 8)
-                        (aver (or (zerop rem) (= rem 7)))
-                        (when (= rem 7)
-                          (setq size (1+ size))
-                          (setq floor (1+ floor)))
-                        (dovector (i vec)
-                          (dump-integer-as-n-bytes
-                           (ecase sb!c:*backend-byte-order*
-                             (:little-endian i)
-                             (:big-endian (octet-swap i size)))
-                           floor file))))
-                     (t ; harder cases, not supported in cross-compiler
-                      (dump-raw-bytes vec bytes file))))
-             (dump-signed-vector (size bytes)
-               ;; Note: Dumping specialized signed vectors isn't
-               ;; supported in the cross-compiler. (All cases here end
-               ;; up trying to call DUMP-RAW-BYTES, which isn't
-               ;; provided in the cross-compilation host, only on the
-               ;; target machine.)
-               (unless data-only
-                 (dump-fop 'fop-signed-int-vector file)
-                 (dump-word len file)
-                 (dump-byte size file))
-               (dump-raw-bytes vec bytes file)))
-      (etypecase vec
-        #-sb-xc-host
-        ((simple-array nil (*))
-         (dump-unsigned-vector 0 0))
-        (simple-bit-vector
-         (dump-unsigned-vector 1 (ceiling len 8))) ; bits to bytes
-        ;; KLUDGE: This isn't the best way of expressing that the host
-        ;; may not have specializations for (unsigned-byte 2) and
-        ;; (unsigned-byte 4), which means that these types are
-        ;; type-equivalent to (simple-array (unsigned-byte 8) (*));
-        ;; the workaround is to remove them from the etypecase, since
-        ;; they can't be dumped from the cross-compiler anyway. --
-        ;; CSR, 2002-05-07
-        #-sb-xc-host
-        ((simple-array (unsigned-byte 2) (*))
-         (dump-unsigned-vector 2 (ceiling (ash len 1) 8))) ; bits to bytes
-        #-sb-xc-host
-        ((simple-array (unsigned-byte 4) (*))
-         (dump-unsigned-vector 4 (ceiling (ash len 2) 8))) ; bits to bytes
-        #-sb-xc-host
-        ((simple-array (unsigned-byte 7) (*))
-         (dump-unsigned-vector 7 len))
-        ((simple-array (unsigned-byte 8) (*))
-         (dump-unsigned-vector 8 len))
-        #-sb-xc-host
-        ((simple-array (unsigned-byte 15) (*))
-         (dump-unsigned-vector 15 (* 2 len)))
-        ((simple-array (unsigned-byte 16) (*))
-         (dump-unsigned-vector 16 (* 2 len)))
-        #-sb-xc-host
-        ((simple-array (unsigned-byte 31) (*))
-         (dump-unsigned-vector 31 (* 4 len)))
-        ((simple-array (unsigned-byte 32) (*))
-         (dump-unsigned-vector 32 (* 4 len)))
-        #-sb-xc-host
-        #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-        ((simple-array (unsigned-byte 63) (*))
-         (dump-unsigned-vector 63 (* 8 len)))
-        #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-        ((simple-array (unsigned-byte 64) (*))
-         (dump-unsigned-vector 64 (* 8 len)))
-        ((simple-array (signed-byte 8) (*))
-         (dump-signed-vector 8 len))
-        ((simple-array (signed-byte 16) (*))
-         (dump-signed-vector 16 (* 2 len)))
-        #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
-        ((simple-array (unsigned-byte 29) (*))
-         (dump-signed-vector 29 (* 4 len)))
-        #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
-        ((simple-array (signed-byte 30) (*))
-         (dump-signed-vector 30 (* 4 len)))
-        ((simple-array (signed-byte 32) (*))
-         (dump-signed-vector 32 (* 4 len)))
-        #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-        ((simple-array (unsigned-byte 60) (*))
-         (dump-signed-vector 60 (* 8 len)))
-        #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-        ((simple-array (signed-byte 61) (*))
-         (dump-signed-vector 61 (* 8 len)))
-        #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-        ((simple-array (signed-byte 64) (*))
-         (dump-signed-vector 64 (* 8 len)))))))
+#+sb-xc-host
+(defun dump-specialized-vector (vector file &key data-only)
+  (labels ((octet-swap (word bits)
+             "BITS must be a multiple of 8"
+             (do ((input word (ash input -8))
+                  (output 0 (logior (ash output 8) (logand input #xff)))
+                  (bits bits (- bits 8)))
+                 ((<= bits 0) output)))
+           (dump-unsigned-vector (widetag bytes bits)
+             (unless data-only
+               (dump-fop 'fop-spec-vector file)
+               (dump-word (length vector) file)
+               (dump-byte widetag file))
+             (dovector (i vector)
+               (dump-integer-as-n-bytes
+                (ecase sb!c:*backend-byte-order*
+                  (:little-endian i)
+                  (:big-endian (octet-swap i bits)))
+                bytes file))))
+    (etypecase vector
+      ((simple-array (unsigned-byte 8) (*))
+       (dump-unsigned-vector sb!vm:simple-array-unsigned-byte-8-widetag 1 8))
+      ((simple-array (unsigned-byte 16) (*))
+       (dump-unsigned-vector sb!vm:simple-array-unsigned-byte-16-widetag 2 16))
+      ((simple-array (unsigned-byte 32) (*))
+       (dump-unsigned-vector sb!vm:simple-array-unsigned-byte-32-widetag 4 32)))))
+
+#-sb-xc-host
+(defun dump-specialized-vector (vector file &key data-only)
+  (declare (type (simple-array * (*)) vector))
+  (let* ((length (length vector))
+         (widetag (widetag-of vector))
+         (bits-per-length (aref **saetp-bits-per-length** widetag)))
+    (aver (< bits-per-length 255))
+    (unless data-only
+      (dump-fop 'fop-spec-vector file)
+      (dump-word length file)
+      (dump-byte widetag file))
+    (dump-raw-bytes vector
+                    (ceiling (* length bits-per-length) sb!vm:n-byte-bits)
+                    file)))
 
 ;;; Dump characters and string-ish things.
 
@@ -964,15 +872,21 @@
   (values))
 
 ;;; If we get here, it is assumed that the symbol isn't in the table,
-;;; but we are responsible for putting it there when appropriate. To
-;;; avoid too much special-casing, we always push the symbol in the
-;;; table, but don't record that we have done so if *COLD-LOAD-DUMP*
-;;; is true.
+;;; but we are responsible for putting it there when appropriate.
 (defun dump-symbol (s file)
   (declare (type fasl-output file))
   (let* ((pname (symbol-name s))
          (pname-length (length pname))
          (pkg (symbol-package s)))
+    ;; see comment in genesis: we need this here for repeatable fasls
+    #+sb-xc-host
+    (multiple-value-bind (cl-symbol cl-status)
+        (find-symbol (symbol-name s) sb!int:*cl-package*)
+      (when (and (eq s cl-symbol)
+                 (eq cl-status :external))
+        ;; special case, to work around possible xc host "design
+        ;; choice" weirdness in COMMON-LISP package
+        (setq pkg sb!int:*cl-package*)))
 
     (cond ((null pkg)
            (dump-fop* pname-length
@@ -1015,9 +929,8 @@
                   #!-sb-unicode dump-base-chars-of-string
                   pname file)
 
-    (unless *cold-load-dump*
-      (setf (gethash s (fasl-output-eq-table file))
-            (fasl-output-table-free file)))
+    (setf (gethash s (fasl-output-eq-table file))
+          (fasl-output-table-free file))
 
     (incf (fasl-output-table-free file)))
 
@@ -1049,19 +962,13 @@
            (position (fixup-note-position note))
            (name (fixup-name fixup))
            (flavor (fixup-flavor fixup)))
-      (dump-fop 'fop-normal-load fasl-output)
-      (let ((*cold-load-dump* t))
-        (dump-object kind fasl-output))
-      (dump-fop 'fop-maybe-cold-load fasl-output)
+      (dump-object kind fasl-output)
       ;; Depending on the flavor, we may have various kinds of
       ;; noise before the position.
       (ecase flavor
         (:assembly-routine
          (aver (symbolp name))
-         (dump-fop 'fop-normal-load fasl-output)
-         (let ((*cold-load-dump* t))
-           (dump-object name fasl-output))
-         (dump-fop 'fop-maybe-cold-load fasl-output)
+         (dump-object name fasl-output)
          (dump-fop 'fop-assembler-fixup fasl-output))
         ((:foreign :foreign-dataref)
          (aver (stringp name))
@@ -1151,7 +1058,10 @@
                 (dump-push (cdr entry) fasl-output))
                (:fdefinition
                 (dump-object (cdr entry) fasl-output)
-                (dump-fop 'fop-fdefinition fasl-output))))
+                (dump-fop 'fop-fdefinition fasl-output))
+               (:known-fun
+                (dump-object (cdr entry) fasl-output)
+                (dump-fop 'fop-known-fun fasl-output))))
             (null
              (dump-fop 'fop-misc-trap fasl-output)))))
 
@@ -1176,7 +1086,7 @@
       ;; These two dumps are only ones which contribute to our
       ;; TOTAL-LENGTH value.
       (dump-segment code-segment code-length fasl-output)
-      (dump-i-vector packed-trace-table fasl-output :data-only t)
+      (dump-specialized-vector packed-trace-table fasl-output :data-only t)
 
       ;; DUMP-FIXUPS does its own internal DUMP-FOPs: the bytes it
       ;; dumps aren't included in the TOTAL-LENGTH passed to our
@@ -1197,10 +1107,7 @@
   (dump-word length file)
   (write-segment-contents code-segment (fasl-output-stream file))
   (dolist (routine routines)
-    (dump-fop 'fop-normal-load file)
-    (let ((*cold-load-dump* t))
-      (dump-object (car routine) file))
-    (dump-fop 'fop-maybe-cold-load file)
+    (dump-object (car routine) file)
     (dump-fop 'fop-assembler-routine file)
     (dump-word (label-position (cdr routine)) file))
   (dump-fixups fixups file)
@@ -1218,6 +1125,7 @@
     (dump-object name file)
     (dump-object (sb!c::entry-info-arguments entry) file)
     (dump-object (sb!c::entry-info-type entry) file)
+    (dump-object (sb!c::entry-info-info entry) file)
     (dump-fop 'fop-fun-entry file)
     (dump-word (label-position (sb!c::entry-info-offset entry)) file)
     (dump-pop file)))
@@ -1309,14 +1217,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))
 
@@ -1359,10 +1272,7 @@
   (let ((name (classoid-name (layout-classoid obj))))
     (unless name
       (compiler-error "dumping anonymous layout: ~S" obj))
-    (dump-fop 'fop-normal-load file)
-    (let ((*cold-load-dump* t))
-      (dump-object name file))
-    (dump-fop 'fop-maybe-cold-load file))
+    (dump-object name file))
   (sub-dump-object (layout-inherits obj) file)
   (sub-dump-object (layout-depthoid obj) file)
   (sub-dump-object (layout-length obj) file)