X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=cf973826400b92d3283a7988fa0a8bc2d752dd4a;hb=d7e55b414d180341d79e0eddc957e1aa52551c38;hp=45352389ab6a95477b4878bb1c40cf2ede620bf6;hpb=cdc0994481502b7cce9c0a62b48d4cf28965d612;p=sbcl.git

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 4535238..cf97382 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,158 +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 (sb!xc:lisp-implementation-version))
-      (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)
@@ -363,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
@@ -559,37 +542,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
 
@@ -606,21 +607,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))))
 
@@ -640,9 +636,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)))))
@@ -667,8 +660,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)))
@@ -961,15 +953,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
@@ -1012,9 +1010,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)))
 
@@ -1046,19 +1043,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))
@@ -1194,10 +1185,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)
@@ -1215,7 +1203,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-xref 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)))
@@ -1307,14 +1295,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))
 
@@ -1357,10 +1350,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)