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

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 491716a..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,83 +190,62 @@
     (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
-                        #+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)))))
+  (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 #+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)))
+  (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
@@ -298,6 +273,13 @@
                          :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)
@@ -311,14 +293,8 @@
            (format nil
                    "~%  ~
                     compiled from ~S~%  ~
-                    at ~A~%  ~
-                    on ~A~%  ~
                     using ~A version ~A~%"
                    where
-                   #+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)
@@ -370,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
@@ -413,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.
@@ -631,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))))
 
@@ -665,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)))))
@@ -692,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)))
@@ -793,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.
@@ -841,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
+#+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)))))
 
-(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)
+  (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.
 
@@ -986,10 +872,7 @@
   (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))
@@ -1046,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)))
 
@@ -1080,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))
@@ -1182,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)))))
 
@@ -1207,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
@@ -1228,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)
@@ -1396,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)