X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=eaf4ab8461033b0eb7d4f08e6397767302988a5a;hb=7646aefa188758e2892fea2ad02be4f29b3938f2;hp=4e1255a9a51e98e3682a599ac7d16ff6d6b070a5;hpb=53a7501acfbb615bae72b43e3e9a95b9965592ce;p=sbcl.git

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 4e1255a..eaf4ab8 100644
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -293,13 +293,15 @@
      stream)
     (dump-byte +fasl-header-string-stop-char-code+ res)
 
-    ;; Finish the header by outputting fasl file implementation and
-    ;; version in machine-readable form.
-    (let ((implementation +backend-fasl-file-implementation+))
-      (dump-unsigned-32 (length (symbol-name implementation)) res)
-      (dotimes (i (length (symbol-name implementation)))
-	(dump-byte (char-code (aref (symbol-name implementation) i)) res)))
-    (dump-unsigned-32 +fasl-file-version+ res)
+    ;; Finish the header by outputting fasl file implementation,
+    ;; version, and key *FEATURES*.
+    (flet ((dump-counted-string (string)
+	     (dump-unsigned-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-unsigned-32 +fasl-file-version+ res)      
+      (dump-counted-string *features-affecting-fasl-format*))
 
     res))
 
@@ -796,9 +798,12 @@
 	       ;; (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 8) ; easy cases
+	       (cond ((>= size 7) ; easy cases
 		      (multiple-value-bind (floor rem) (floor size 8)
-			(aver (zerop rem))
+			(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*
@@ -819,6 +824,9 @@
 		 (dump-byte size file))
 	       (dump-raw-bytes vec bytes file)))
       (etypecase vec
+	#-sb-xc-host
+	((simple-array nil (*))
+	 (dump-unsigned-vector 0 0))
 	;; KLUDGE: What exactly does the (ASH .. -3) stuff do? -- WHN 19990902
 	(simple-bit-vector
 	 (dump-unsigned-vector 1 (ash (+ (the index len) 7) -3)))
@@ -835,16 +843,27 @@
 	#-sb-xc-host
 	((simple-array (unsigned-byte 4) (*))
 	 (dump-unsigned-vector 4 (ash (+ (the index (ash len 2)) 7) -3)))
+	#-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)))
 	((simple-array (signed-byte 8) (*))
 	 (dump-signed-vector 8 len))
 	((simple-array (signed-byte 16) (*))
 	 (dump-signed-vector 16 (* 2 len)))
+	((simple-array (unsigned-byte 29) (*))
+	 (dump-signed-vector 29 (* 4 len)))
 	((simple-array (signed-byte 30) (*))
 	 (dump-signed-vector 30 (* 4 len)))
 	((simple-array (signed-byte 32) (*))
@@ -948,27 +967,18 @@
 ;;;  - code object references: don't need a name.
 (defun dump-fixups (fixups fasl-output)
   (declare (list fixups) (type fasl-output fasl-output))
-  (dolist (info fixups)
-    ;; FIXME: Packing data with LIST in NOTE-FIXUP and unpacking them
-    ;; with FIRST, SECOND, and THIRD here is hard to follow and
-    ;; maintain. Perhaps we could define a FIXUP-INFO structure to use
-    ;; instead, and rename *FIXUPS* to *FIXUP-INFO-LIST*?
-    (let* ((kind (first info))
-	   (fixup (second info))
+  (dolist (note fixups)
+    (let* ((kind (fixup-note-kind note))
+	   (fixup (fixup-note-fixup note))
+	   (position (fixup-note-position note))
 	   (name (fixup-name fixup))
-	   (flavor (fixup-flavor fixup))
-	   (offset (third info)))
-      ;; FIXME: This OFFSET is not what's called OFFSET in the FIXUP
-      ;; structure, it's what's called POSN in NOTE-FIXUP. (As far as
-      ;; I can tell, FIXUP-OFFSET is not actually an offset, it's an
-      ;; internal label used instead of NAME for :CODE-OBJECT fixups.
-      ;; Notice that in the :CODE-OBJECT case, NAME is ignored.)
+	   (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)
       ;; Depending on the flavor, we may have various kinds of
-      ;; noise before the offset.
+      ;; noise before the position.
       (ecase flavor
 	(:assembly-routine
 	 (aver (symbolp name))
@@ -988,8 +998,8 @@
 	(:code-object
 	 (aver (null name))
 	 (dump-fop 'fop-code-object-fixup fasl-output)))
-      ;; No matter what the flavor, we'll always dump the offset.
-      (dump-unsigned-32 offset fasl-output)))
+      ;; No matter what the flavor, we'll always dump the position
+      (dump-unsigned-32 position fasl-output)))
   (values))
 
 ;;; Dump out the constant pool and code-vector for component, push the
@@ -1257,8 +1267,8 @@
 (defun dump-layout (obj file)
   (when (layout-invalid obj)
     (compiler-error "attempt to dump reference to obsolete class: ~S"
-		    (layout-class obj)))
-  (let ((name (sb!xc:class-name (layout-class obj))))
+		    (layout-classoid obj)))
+  (let ((name (classoid-name (layout-classoid obj))))
     (unless name
       (compiler-error "dumping anonymous layout: ~S" obj))
     (dump-fop 'fop-normal-load file)