X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=6bfc35c6b9bbc9da3fd0bb93aa6ceaaf4096c351;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=83229a0588e44245ff318656074aa83364a38caa;hpb=771b864c8f32af7734bc0550aeaf1539fc4df194;p=sbcl.git

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 83229a0..6bfc35c 100644
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -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.
@@ -260,9 +277,7 @@
 
 ;;; 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. If BYTE-P is true,
-;;; this file will contain no native code, and is thus largely
-;;; implementation independent.
+;;; the source code is given by the string WHERE. 
 (defun open-fasl-output (name where)
   (declare (type pathname name))
   (let* ((stream (open name
@@ -370,11 +385,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)
@@ -498,13 +510,11 @@
 
 ;;;; number dumping
 
-;;; Dump a ratio.
 (defun dump-ratio (x file)
   (sub-dump-object (numerator x) file)
   (sub-dump-object (denominator x) file)
   (dump-fop 'fop-ratio file))
 
-;;; Dump an integer.
 (defun dump-integer (n file)
   (typecase n
     ((signed-byte 8)
@@ -586,7 +596,15 @@
 	(t
 	 (unless *cold-load-dump*
 	   (dump-fop 'fop-normal-load file))
-	 (dump-simple-string (package-name pkg) 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))
@@ -664,7 +682,7 @@
     (6 (dump-fop 'fop-list*-6 file))
     (7 (dump-fop 'fop-list*-7 file))
     (8 (dump-fop 'fop-list*-8 file))
-    (T (do ((nn n (- nn 255)))
+    (t (do ((nn n (- nn 255)))
 	   ((< nn 256)
 	    (dump-fop 'fop-list* file)
 	    (dump-byte nn file))
@@ -686,7 +704,7 @@
     (6 (dump-fop 'fop-list-6 file))
     (7 (dump-fop 'fop-list-7 file))
     (8 (dump-fop 'fop-list-8 file))
-    (T (cond ((< n 256)
+    (t (cond ((< n 256)
 	      (dump-fop 'fop-list file)
 	      (dump-byte n file))
 	     (t (dump-fop 'fop-list file)
@@ -717,10 +735,24 @@
 					(*)))
 			    x)))
     (typecase simple-version
+      #+sb-xc-host
+      (simple-string
+       (unless (string-check-table x file)
+         (dump-simple-base-string simple-version file)
+         (string-save-object x file)))
+      #-sb-xc-host
       (simple-base-string
-       (unless (equal-check-table x file)
-	 (dump-simple-string simple-version file)
-	 (equal-save-object x file)))
+       (unless (string-check-table x file)
+	 (dump-simple-base-string simple-version file)
+	 (string-save-object x file)))
+      #-sb-xc-host
+      ((simple-array character (*))
+       #!+sb-unicode
+       (unless (string-check-table x file)
+	 (dump-simple-character-string simple-version file)
+	 (string-save-object x file))
+       #!-sb-unicode
+       (bug "how did we get here?"))
       (simple-vector
        (dump-simple-vector simple-version file)
        (eq-save-object x file))
@@ -860,10 +892,10 @@
 	 (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) (*))
+        ((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) (*))
+        ((simple-array (unsigned-byte 64) (*))
          (dump-unsigned-vector 64 (* 8 len)))
 	((simple-array (signed-byte 8) (*))
 	 (dump-signed-vector 8 len))
@@ -889,23 +921,31 @@
 
 ;;; Dump characters and string-ish things.
 
-(defun dump-character (ch file)
+(defun dump-character (char file)
+  (let ((code (sb!xc:char-code char)))
+    (cond
+      ((< code 256)
   (dump-fop 'fop-short-character file)
-  (dump-byte (char-code ch) file))
+       (dump-byte code file))
+      (t
+       (dump-fop 'fop-character file)
+       (dump-word code file)))))
 
-;;; a helper function shared by DUMP-SIMPLE-STRING and DUMP-SYMBOL
-(defun dump-characters-of-string (s fasl-output)
-  (declare (type string s) (type fasl-output fasl-output))
+(defun dump-base-chars-of-string (s fasl-output)
+  (declare #+sb-xc-host (type simple-string s)
+           #-sb-xc-host (type simple-base-string s)
+           (type fasl-output fasl-output))
   (dovector (c s)
-    (dump-byte (char-code c) fasl-output))
+    (dump-byte (sb!xc:char-code c) fasl-output))
   (values))
 
+
 ;;; Dump a SIMPLE-BASE-STRING.
-;;; FIXME: should be called DUMP-SIMPLE-BASE-STRING then
-(defun dump-simple-string (s file)
-  (declare (type simple-base-string s))
-  (dump-fop* (length s) fop-small-string fop-string file)
-  (dump-characters-of-string s file)
+(defun dump-simple-base-string (s file)
+  #+sb-xc-host (declare (type simple-string s))
+  #-sb-xc-host (declare (type simple-base-string s))
+  (dump-fop* (length s) fop-small-base-string fop-base-string file)
+  (dump-base-chars-of-string s file)
   (values))
 
 ;;; If we get here, it is assumed that the symbol isn't in the table,
@@ -955,7 +995,10 @@
 		      file)
 	   (dump-word pname-length file)))
 
-    (dump-characters-of-string pname file)
+    #+sb-xc-host (dump-base-chars-of-string pname file)
+    #-sb-xc-host (#!+sb-unicode dump-characters-of-string
+                  #!-sb-unicode dump-base-chars-of-string
+                  pname file)
 
     (unless *cold-load-dump*
       (setf (gethash s (fasl-output-eq-table file))
@@ -1272,14 +1315,20 @@
       (error "attempt to dump invalid structure:~%  ~S~%How did this happen?"
 	     struct)))
   (note-potential-circularity struct file)
-  (do ((index 0 (1+ index))
-       (length (%instance-length struct))
-       (circ (fasl-output-circularity-table file)))
-      ((= index length)
+  (aver (%instance-ref struct 0))
+  (do* ((length (%instance-length struct))
+	(ntagged (- length (layout-n-untagged-slots (%instance-ref struct 0))))
+	(circ (fasl-output-circularity-table file))
+	;; last slot first on the stack, so that the layout is on top:
+	(index (1- length) (1- index)))
+      ((minusp index)
        (dump-fop* length fop-small-struct fop-struct file))
-    (let* ((obj (%instance-ref struct index))
+    (let* ((obj (if (>= index ntagged)
+		    (%raw-instance-ref/word struct (- length index 1))
+		    (%instance-ref struct index)))
 	   (ref (gethash obj circ)))
       (cond (ref
+	     (aver (not (zerop index)))
 	     (push (make-circularity :type :struct-set
 				     :object struct
 				     :index index
@@ -1304,4 +1353,5 @@
   (sub-dump-object (layout-inherits obj) file)
   (sub-dump-object (layout-depthoid obj) file)
   (sub-dump-object (layout-length obj) file)
+  (sub-dump-object (layout-n-untagged-slots obj) file)
   (dump-fop 'fop-layout file))