0.8.16.16:

[sbcl.git] / src / compiler / dump.lisp

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index e498999..453daf4 100644 (file)
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -33,7 +33,7 @@
   ;; can get them from the table rather than dumping them again. The
   ;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is
   ;; used for everything else. We use a separate EQ table to avoid
-  ;; performance patholigies with objects for which EQUAL degnerates
+  ;; performance pathologies with objects for which EQUAL degenerates
   ;; to EQL. Everything entered in the EQUAL table is also entered in
   ;; the EQ table.
   (equal-table (make-hash-table :test 'equal) :type hash-table)
@@ -192,11 +192,19 @@
   (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)))))
+      (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)))))
 
 ;;; These functions are called after dumping an object to save the
 ;;; object in the table. The object (also passed in as X) must already
@@ -217,7 +225,16 @@
       (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)))
+  (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.
@@ -280,17 +297,19 @@
     ;; character code.
     (fasl-write-string
      (with-standard-io-syntax
-       (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)))
+       (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)
 
@@ -368,11 +387,8 @@
              (dump-structure x file)
              (eq-save-object x file))
             (array
-             ;; FIXME: The comment at the head of
-             ;; DUMP-NON-IMMEDIATE-OBJECT says it's for objects which
-             ;; we want to save, instead of repeatedly dumping them.
-             ;; But then we dump arrays here without doing anything
-             ;; like EQUAL-SAVE-OBJECT. What gives?
+              ;; DUMP-ARRAY (and its callees) are responsible for
+              ;; updating the EQ and EQUAL hash tables.
              (dump-array x file))
             (number
              (unless (equal-check-table x file)
@@ -391,7 +407,7 @@
 
 ;;; Dump an object of any type by dispatching to the correct
 ;;; type-specific dumping function. We pick off immediate objects,
-;;; symbols and and magic lists here. Other objects are handled by
+;;; symbols and magic lists here. Other objects are handled by
 ;;; DUMP-NON-IMMEDIATE-OBJECT.
 ;;;
 ;;; This is the function used for recursive calls to the fasl dumper.
@@ -827,7 +843,7 @@
        ((simple-array nil (*))
         (dump-unsigned-vector 0 0))
        (simple-bit-vector
-        (dump-unsigned-vector 1 (ceiling len 8)))
+        (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
@@ -837,10 +853,10 @@
        ;; CSR, 2002-05-07
        #-sb-xc-host
        ((simple-array (unsigned-byte 2) (*))
-        (dump-unsigned-vector 2 (ceiling len 8)))
+        (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 len 8)))
+        (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))
@@ -1003,9 +1019,14 @@
           (dump-object name fasl-output))
         (dump-fop 'fop-maybe-cold-load fasl-output)
         (dump-fop 'fop-assembler-fixup fasl-output))
-       (:foreign
+       ((:foreign :foreign-dataref)
         (aver (stringp name))
-        (dump-fop 'fop-foreign-fixup fasl-output)
+        (ecase flavor
+          (:foreign
+           (dump-fop 'fop-foreign-fixup fasl-output))
+          #!+linkage-table
+          (:foreign-dataref
+           (dump-fop 'fop-foreign-dataref-fixup fasl-output)))
         (let ((len (length name)))
           (aver (< len 256)) ; (limit imposed by fop definition)
           (dump-byte len fasl-output)