X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=2befcac76631d968dd70764358b03ccd693cb0e7;hb=94ea2b2082deaa0331dfb66fa6af6ca12dd8dc83;hp=7ef58ec6f752893cd6283f6078de89cd7cb07b8f;hpb=7a896fb715ceac43581a9a3835418e615002f9ec;p=sbcl.git

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 7ef58ec..2befcac 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -34,10 +34,10 @@
 
 ;;; a magic number used to identify our core files
 (defconstant core-magic
-  (logior (ash (char-code #\S) 24)
-	  (ash (char-code #\B) 16)
-	  (ash (char-code #\C) 8)
-	  (char-code #\L)))
+  (logior (ash (sb!xc:char-code #\S) 24)
+	  (ash (sb!xc:char-code #\B) 16)
+	  (ash (sb!xc:char-code #\C) 8)
+	  (sb!xc:char-code #\L)))
 
 ;;; the current version of SBCL core files
 ;;;
@@ -156,7 +156,7 @@
   bigvec)
 
 ;;;; looking up bytes and multi-byte values in a BIGVEC (considering
-;;;; it as an image of machine memory)
+;;;; it as an image of machine memory on the cross-compilation target)
 
 ;;; BVREF-32 and friends. These are like SAP-REF-n, except that
 ;;; instead of a SAP we use a BIGVEC.
@@ -199,13 +199,21 @@
   (make-bvref-n 64))
 
 ;; lispobj-sized word, whatever that may be
+;; hopefully nobody ever wants a 128-bit SBCL...
+#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+(progn
 (defun bvref-word (bytes index)
-  #!+x86-64 (bvref-64 bytes index)
-  #!-x86-64 (bvref-32 bytes index))
+  (bvref-64 bytes index))
+(defun (setf bvref-word) (new-val bytes index)
+  (setf (bvref-64 bytes index) new-val)))
 
+#!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
+(progn
+(defun bvref-word (bytes index)
+  (bvref-32 bytes index))
 (defun (setf bvref-word) (new-val bytes index)
-  #!+x86-64 (setf (bvref-64 bytes index) new-val)
-  #!-x86-64 (setf (bvref-32 bytes index) new-val))
+  (setf (bvref-32 bytes index) new-val)))
+
 
 ;;;; representation of spaces in the core
 
@@ -273,7 +281,7 @@
   ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
   (gspace nil :type (or gspace null))
   ;; the offset in words from the start of GSPACE, or NIL if not set yet
-  (word-offset nil :type (or (unsigned-byte #.sb!vm:n-word-bits) null))
+  (word-offset nil :type (or sb!vm:word null))
   ;; the high and low halves of the descriptor
   ;;
   ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL
@@ -300,7 +308,11 @@
 			   (- unsigned #x40000000)
 			   unsigned))))
 	    ((or (= lowtag sb!vm:other-immediate-0-lowtag)
-		 (= lowtag sb!vm:other-immediate-1-lowtag))
+		 (= lowtag sb!vm:other-immediate-1-lowtag)
+                 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                 (= lowtag sb!vm:other-immediate-2-lowtag)
+                 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                 (= lowtag sb!vm:other-immediate-3-lowtag))
 	     (format stream
 		     "for other immediate: #X~X, type #b~8,'0B"
 		     (ash (descriptor-bits des) (- sb!vm:n-widetag-bits))
@@ -356,15 +368,24 @@
 (defun descriptor-fixnum (des)
   (let ((bits (descriptor-bits des)))
     (if (logbitp (1- sb!vm:n-word-bits) bits)
-      ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to
-      ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS),
-      ;; and although that doesn't make sense for me, or work for me,
-      ;; it's hard to see how it could have been wrong, since CMU CL
-      ;; genesis worked. It would be nice to understand how this came
-      ;; to be.. -- WHN 19990901
-      (logior (ash bits (- 1 sb!vm:n-lowtag-bits)) 
-	      (ash -1 (- sb!vm:n-word-bits (1- sb!vm:n-lowtag-bits))))
-      (ash bits  (- 1 sb!vm:n-lowtag-bits)))))
+        ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to
+        ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS),
+        ;; and although that doesn't make sense for me, or work for me,
+        ;; it's hard to see how it could have been wrong, since CMU CL
+        ;; genesis worked. It would be nice to understand how this came
+        ;; to be.. -- WHN 19990901
+        (logior (ash bits (- 1 sb!vm:n-lowtag-bits))
+                (ash -1 (1+ sb!vm:n-positive-fixnum-bits)))
+        (ash bits (- 1 sb!vm:n-lowtag-bits)))))
+
+(defun descriptor-word-sized-integer (des)
+  ;; Extract an (unsigned-byte 32), from either its fixnum or bignum
+  ;; representation.
+  (let ((lowtag (descriptor-lowtag des)))
+    (if (or (= lowtag sb!vm:even-fixnum-lowtag)
+	    (= lowtag sb!vm:odd-fixnum-lowtag))
+	(make-random-descriptor (descriptor-fixnum des))
+	(read-wordindexed des 1))))
 
 ;;; common idioms
 (defun descriptor-bytes (des)
@@ -432,7 +453,7 @@
 			   type)))
 
 (defun make-character-descriptor (data)
-  (make-other-immediate-descriptor data sb!vm:base-char-widetag))
+  (make-other-immediate-descriptor data sb!vm:character-widetag))
 
 (defun descriptor-beyond (des offset type)
   (let* ((low (logior (+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask)
@@ -596,9 +617,10 @@
 
 ;;;; copying simple objects into the cold core
 
-(defun string-to-core (string &optional (gspace *dynamic*))
+(defun base-string-to-core (string &optional (gspace *dynamic*))
   #!+sb-doc
-  "Copy string into the cold core and return a descriptor to it."
+  "Copy STRING (which must only contain STANDARD-CHARs) into the cold
+core and return a descriptor to it."
   ;; (Remember that the system convention for storage of strings leaves an
   ;; extra null byte at the end to aid in call-out to C.)
   (let* ((length (length string))
@@ -614,14 +636,7 @@
 		       (make-fixnum-descriptor length))
     (dotimes (i length)
       (setf (bvref bytes (+ offset i))
-	    ;; KLUDGE: There's no guarantee that the character
-	    ;; encoding here will be the same as the character
-	    ;; encoding on the target machine, so using CHAR-CODE as
-	    ;; we do, or a bitwise copy as CMU CL code did, is sleazy.
-	    ;; (To make this more portable, perhaps we could use
-	    ;; indices into the sequence which is used to test whether
-	    ;; a character is a STANDARD-CHAR?) -- WHN 19990817
-	    (char-code (aref string i))))
+	    (sb!xc:char-code (aref string i))))
     (setf (bvref bytes (+ offset length))
 	  0) ; null string-termination character for C
     des))
@@ -657,9 +672,38 @@
     (write-wordindexed des 2 second)
     des))
 
+(defun write-double-float-bits (address index x)
+  (let ((hi (double-float-high-bits x))
+	(lo (double-float-low-bits x)))
+    (ecase sb!vm::n-word-bits
+      (32
+       (let ((high-bits (make-random-descriptor hi))
+	     (low-bits (make-random-descriptor lo)))
+	 (ecase sb!c:*backend-byte-order*
+	   (:little-endian
+	    (write-wordindexed address index low-bits)
+	    (write-wordindexed address (1+ index) high-bits))
+	   (:big-endian
+	    (write-wordindexed address index high-bits)
+	    (write-wordindexed address (1+ index) low-bits)))))
+      (64
+       (let ((bits (make-random-descriptor
+		    (ecase sb!c:*backend-byte-order*
+		      (:little-endian (logior lo (ash hi 32)))
+		      ;; Just guessing.
+		      #+nil (:big-endian (logior (logand hi #xffffffff)
+						 (ash lo 32)))))))
+	 (write-wordindexed address index bits))))
+    address))
+
 (defun float-to-core (x)
   (etypecase x
     (single-float
+     ;; 64-bit platforms have immediate single-floats.
+     #!+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
+     (make-random-descriptor (logior (ash (single-float-bits x) 32)
+				     sb!vm::single-float-widetag))
+     #!-#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
      (let ((des (allocate-unboxed-object *dynamic*
 					 sb!vm:n-word-bits
 					 (1- sb!vm:single-float-size)
@@ -672,17 +716,8 @@
      (let ((des (allocate-unboxed-object *dynamic*
 					 sb!vm:n-word-bits
 					 (1- sb!vm:double-float-size)
-					 sb!vm:double-float-widetag))
-	   (high-bits (make-random-descriptor (double-float-high-bits x)))
-	   (low-bits (make-random-descriptor (double-float-low-bits x))))
-       (ecase sb!c:*backend-byte-order*
-	 (:little-endian
-	  (write-wordindexed des sb!vm:double-float-value-slot low-bits)
-	  (write-wordindexed des (1+ sb!vm:double-float-value-slot) high-bits))
-	 (:big-endian
-	  (write-wordindexed des sb!vm:double-float-value-slot high-bits)
-	  (write-wordindexed des (1+ sb!vm:double-float-value-slot) low-bits)))
-       des))))
+					 sb!vm:double-float-widetag)))
+       (write-double-float-bits des sb!vm:double-float-value-slot x)))))
 
 (defun complex-single-float-to-core (num)
   (declare (type (complex single-float) num))
@@ -700,39 +735,10 @@
   (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
 				      (1- sb!vm:complex-double-float-size)
 				      sb!vm:complex-double-float-widetag)))
-    (let* ((real (realpart num))
-	   (high-bits (make-random-descriptor (double-float-high-bits real)))
-	   (low-bits (make-random-descriptor (double-float-low-bits real))))
-      (ecase sb!c:*backend-byte-order*
-	(:little-endian
-	 (write-wordindexed des sb!vm:complex-double-float-real-slot low-bits)
-	 (write-wordindexed des
-			    (1+ sb!vm:complex-double-float-real-slot)
-			    high-bits))
-	(:big-endian
-	 (write-wordindexed des sb!vm:complex-double-float-real-slot high-bits)
-	 (write-wordindexed des
-			    (1+ sb!vm:complex-double-float-real-slot)
-			    low-bits))))
-    (let* ((imag (imagpart num))
-	   (high-bits (make-random-descriptor (double-float-high-bits imag)))
-	   (low-bits (make-random-descriptor (double-float-low-bits imag))))
-      (ecase sb!c:*backend-byte-order*
-	(:little-endian
-	 (write-wordindexed des
-			    sb!vm:complex-double-float-imag-slot
-			    low-bits)
-	 (write-wordindexed des
-			    (1+ sb!vm:complex-double-float-imag-slot)
-			    high-bits))
-	(:big-endian
-	 (write-wordindexed des
-			    sb!vm:complex-double-float-imag-slot
-			    high-bits)
-	 (write-wordindexed des
-			    (1+ sb!vm:complex-double-float-imag-slot)
-			    low-bits))))
-    des))
+    (write-double-float-bits des sb!vm:complex-double-float-real-slot
+			     (realpart num))
+    (write-double-float-bits des sb!vm:complex-double-float-imag-slot
+			     (imagpart num))))
 
 ;;; Copy the given number to the core.
 (defun number-to-core (number)
@@ -803,7 +809,7 @@
 		       (make-fixnum-descriptor 0))
     (write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*)
     (write-wordindexed symbol sb!vm:symbol-name-slot
-		       (string-to-core name *dynamic*))
+		       (base-string-to-core name *dynamic*))
     (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
     symbol))
 
@@ -847,7 +853,7 @@
 ;;; FIXME: This information should probably be pulled out of the
 ;;; cross-compiler's tables at genesis time instead of inserted by
 ;;; hand here as a bare numeric constant.
-(defconstant target-layout-length 16)
+(defconstant target-layout-length 17)
 
 ;;; Return a list of names created from the cold layout INHERITS data
 ;;; in X.
@@ -865,9 +871,10 @@
 		   (descriptor-bits des)))))
       (res))))
 
-(declaim (ftype (function (symbol descriptor descriptor descriptor) descriptor)
+(declaim (ftype (function (symbol descriptor descriptor descriptor descriptor)
+			  descriptor)
 		make-cold-layout))
-(defun make-cold-layout (name length inherits depthoid)
+(defun make-cold-layout (name length inherits depthoid nuntagged)
   (let ((result (allocate-boxed-object *dynamic*
 				       ;; KLUDGE: Why 1+? -- WHN 19990901
 				       (1+ target-layout-length)
@@ -947,14 +954,16 @@
       (write-wordindexed result (+ base 3) depthoid)
       (write-wordindexed result (+ base 4) length)
       (write-wordindexed result (+ base 5) *nil-descriptor*) ; info
-      (write-wordindexed result (+ base 6) *nil-descriptor*)) ; pure
+      (write-wordindexed result (+ base 6) *nil-descriptor*) ; pure
+      (write-wordindexed result (+ base 7) nuntagged))
 
     (setf (gethash name *cold-layouts*)
 	  (list result
 		name
 		(descriptor-fixnum length)
 		(listify-cold-inherits inherits)
-		(descriptor-fixnum depthoid)))
+		(descriptor-fixnum depthoid)
+		(descriptor-fixnum nuntagged)))
     (setf (gethash (descriptor-bits result) *cold-layout-names*) name)
 
     result))
@@ -971,7 +980,9 @@
 			  (number-to-core target-layout-length)
 			  (vector-in-core)
 			  ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT..
-			  (number-to-core 4)))
+			  (number-to-core 4)
+			  ;; no raw slots in LAYOUT:
+			  (number-to-core 0)))
   (write-wordindexed *layout-layout*
 		     sb!vm:instance-slots-offset
 		     *layout-layout*)
@@ -985,22 +996,26 @@
 	  (make-cold-layout 't
 			    (number-to-core 0)
 			    (vector-in-core)
+			    (number-to-core 0)
 			    (number-to-core 0)))
 	 (i-layout
 	  (make-cold-layout 'instance
 			    (number-to-core 0)
 			    (vector-in-core t-layout)
-			    (number-to-core 1)))
+			    (number-to-core 1)
+			    (number-to-core 0)))
 	 (so-layout
 	  (make-cold-layout 'structure-object
 			    (number-to-core 1)
 			    (vector-in-core t-layout i-layout)
-			    (number-to-core 2)))
+			    (number-to-core 2)
+			    (number-to-core 0)))
 	 (bso-layout
 	  (make-cold-layout 'structure!object
 			    (number-to-core 1)
 			    (vector-in-core t-layout i-layout so-layout)
-			    (number-to-core 3)))
+			    (number-to-core 3)
+			    (number-to-core 0)))
 	 (layout-inherits (vector-in-core t-layout
 					  i-layout
 					  so-layout
@@ -1189,7 +1204,7 @@
 		       ;; because that's the way CMU CL did it; I'm
 		       ;; not sure whether there's an underlying
 		       ;; reason. -- WHN 1990826
-		       (string-to-core "NIL" *dynamic*))
+		       (base-string-to-core "NIL" *dynamic*))
     (write-wordindexed des
 		       (+ 1 sb!vm:symbol-package-slot)
 		       result)
@@ -1257,9 +1272,11 @@
     (frob sub-gc)
     (frob internal-error)
     (frob sb!kernel::control-stack-exhausted-error)
+    (frob sb!kernel::undefined-alien-variable-error)
+    (frob sb!kernel::undefined-alien-function-error)
+    (frob sb!kernel::memory-fault-error)
     (frob sb!di::handle-breakpoint)
-    (frob sb!di::handle-fun-end-breakpoint)
-    (frob sb!thread::handle-thread-exit))
+    (frob sb!di::handle-fun-end-breakpoint))
 
   (cold-set 'sb!vm::*current-catch-block*          (make-fixnum-descriptor 0))
   (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))
@@ -1274,7 +1291,7 @@
       (let* ((cold-package (car cold-package-symbols-entry))
 	     (symbols (cdr cold-package-symbols-entry))
 	     (shadows (package-shadowing-symbols cold-package))
-	     (documentation (string-to-core (documentation cold-package t)))
+	     (documentation (base-string-to-core (documentation cold-package t)))
 	     (internal *nil-descriptor*)
 	     (external *nil-descriptor*)
 	     (imported-internal *nil-descriptor*)
@@ -1354,7 +1371,7 @@
 	 (res *nil-descriptor*))
     (dolist (u (package-use-list pkg))
       (when (assoc u *cold-package-symbols*)
-	(cold-push (string-to-core (package-name u)) use)))
+	(cold-push (base-string-to-core (package-name u)) use)))
     (let* ((pkg-name (package-name pkg))
 	   ;; Make the package nickname lists for the standard packages
 	   ;; be the minimum specified by ANSI, regardless of what value
@@ -1375,7 +1392,7 @@
 				 (t
 				  (package-nicknames pkg)))))
       (dolist (warm-nickname warm-nicknames)
-	(cold-push (string-to-core warm-nickname) cold-nicknames)))
+	(cold-push (base-string-to-core warm-nickname) cold-nicknames)))
 
     (cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
 					 0.8))
@@ -1392,7 +1409,7 @@
     (cold-push use res)
     (cold-push (cold-intern :use) res)
 
-    (cold-push (string-to-core (package-name pkg)) res)
+    (cold-push (base-string-to-core (package-name pkg)) res)
     res))
 
 ;;;; functions and fdefinition objects
@@ -1456,6 +1473,7 @@
 
 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
   (declare (type descriptor cold-name))
+  (/show0 "/cold-fdefinition-object")
   (let ((warm-name (warm-fun-name cold-name)))
     (or (gethash warm-name *cold-fdefn-objects*)
 	(let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace* *dynamic*)
@@ -1473,7 +1491,7 @@
 			       sb!vm:fdefn-raw-addr-slot
 			       (make-random-descriptor
 				(cold-foreign-symbol-address-as-integer
-				 (sb!vm:extern-alien-name "undefined_tramp")))))
+				 "undefined_tramp"))))
 	  fdefn))))
 
 ;;; Handle the at-cold-init-time, fset-for-static-linkage operation
@@ -1487,6 +1505,7 @@
 		       sb!vm:fdefn-raw-addr-slot
 		       (ecase type
 			 (#.sb!vm:simple-fun-header-widetag
+			  (/show0 "static-fset (simple-fun)")
 			  #!+sparc
 			  defn
 			  #!-sparc
@@ -1496,9 +1515,10 @@
 			      (ash sb!vm:simple-fun-code-offset
 				   sb!vm:word-shift))))
 			 (#.sb!vm:closure-header-widetag
+			  (/show0 "/static-fset (closure)")
 			  (make-random-descriptor
 			   (cold-foreign-symbol-address-as-integer
-			    (sb!vm:extern-alien-name "closure_tramp"))))))
+			    "closure_tramp")))))
     fdefn))
 
 (defun initialize-static-fns ()
@@ -1512,8 +1532,8 @@
 	     (desired (sb!vm:static-fun-offset sym)))
 	(unless (= offset desired)
 	  ;; FIXME: should be fatal
-	  (warn "Offset from FDEFN ~S to ~S is ~W, not ~W."
-		sym nil offset desired))))))
+	  (error "Offset from FDEFN ~S to ~S is ~W, not ~W."
+		 sym nil offset desired))))))
 
 (defun list-all-fdefn-objects ()
   (let ((result *nil-descriptor*))
@@ -1529,55 +1549,55 @@
 (defvar *cold-foreign-symbol-table*)
 (declaim (type hash-table *cold-foreign-symbol-table*))
 
-;;; Read the sbcl.nm file to find the addresses for foreign-symbols in
-;;; the C runtime.  
+;; Read the sbcl.nm file to find the addresses for foreign-symbols in
+;; the C runtime.
 (defun load-cold-foreign-symbol-table (filename)
+  (/show "load-cold-foreign-symbol-table" filename)
   (with-open-file (file filename)
-    (loop
-      (let ((line (read-line file nil nil)))
-	(unless line
-	  (return))
-	;; UNIX symbol tables might have tabs in them, and tabs are
-	;; not in Common Lisp STANDARD-CHAR, so there seems to be no
-	;; nice portable way to deal with them within Lisp, alas.
-	;; Fortunately, it's easy to use UNIX command line tools like
-	;; sed to remove the problem, so it's not too painful for us
-	;; to push responsibility for converting tabs to spaces out to
-	;; the caller.
-	;;
-	;; Other non-STANDARD-CHARs are problematic for the same reason.
-	;; Make sure that there aren't any..
-	(let ((ch (find-if (lambda (char)
-			     (not (typep char 'standard-char)))
-			  line)))
-	  (when ch
-	    (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
-		   ch
-		   line)))
-	(setf line (string-trim '(#\space) line))
-	(let ((p1 (position #\space line :from-end nil))
-	      (p2 (position #\space line :from-end t)))
-	  (if (not (and p1 p2 (< p1 p2)))
-	      ;; KLUDGE: It's too messy to try to understand all
-	      ;; possible output from nm, so we just punt the lines we
-	      ;; don't recognize. We realize that there's some chance
-	      ;; that might get us in trouble someday, so we warn
-	      ;; about it.
-	      (warn "ignoring unrecognized line ~S in ~A" line filename)
-	      (multiple-value-bind (value name)
-		  (if (string= "0x" line :end2 2)
-		      (values (parse-integer line :start 2 :end p1 :radix 16)
-			      (subseq line (1+ p2)))
-		      (values (parse-integer line :end p1 :radix 16)
-			      (subseq line (1+ p2))))
-		(multiple-value-bind (old-value found)
-		    (gethash name *cold-foreign-symbol-table*)
-		  (when (and found
-			     (not (= old-value value)))
-		    (warn "redefining ~S from #X~X to #X~X"
-			  name old-value value)))
-		(setf (gethash name *cold-foreign-symbol-table*) value))))))
-    (values)))
+    (loop for line = (read-line file nil nil)
+	  while line do	  
+	  ;; UNIX symbol tables might have tabs in them, and tabs are
+	  ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
+	  ;; nice portable way to deal with them within Lisp, alas.
+	  ;; Fortunately, it's easy to use UNIX command line tools like
+	  ;; sed to remove the problem, so it's not too painful for us
+	  ;; to push responsibility for converting tabs to spaces out to
+	  ;; the caller.
+	  ;;
+	  ;; Other non-STANDARD-CHARs are problematic for the same reason.
+	  ;; Make sure that there aren't any..
+	  (let ((ch (find-if (lambda (char)
+			       (not (typep char 'standard-char)))
+			     line)))
+	    (when ch
+	      (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
+		     ch
+		     line)))
+	  (setf line (string-trim '(#\space) line))
+	  (let ((p1 (position #\space line :from-end nil))
+		(p2 (position #\space line :from-end t)))
+	    (if (not (and p1 p2 (< p1 p2)))
+		;; KLUDGE: It's too messy to try to understand all
+		;; possible output from nm, so we just punt the lines we
+		;; don't recognize. We realize that there's some chance
+		;; that might get us in trouble someday, so we warn
+		;; about it.
+		(warn "ignoring unrecognized line ~S in ~A" line filename)
+		(multiple-value-bind (value name)
+		    (if (string= "0x" line :end2 2)
+			(values (parse-integer line :start 2 :end p1 :radix 16)
+				(subseq line (1+ p2)))
+			(values (parse-integer line :end p1 :radix 16)
+				(subseq line (1+ p2))))
+		  (multiple-value-bind (old-value found)
+		      (gethash name *cold-foreign-symbol-table*)
+		    (when (and found
+			       (not (= old-value value)))
+		      (warn "redefining ~S from #X~X to #X~X"
+			    name old-value value)))
+		  (/show "adding to *cold-foreign-symbol-table*:" name value)
+		  (setf (gethash name *cold-foreign-symbol-table*) value))))))
+  (values))	;; PROGN
 
 (defun cold-foreign-symbol-address-as-integer (name)
   (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*)
@@ -1825,7 +1845,7 @@
 	      (note-load-time-code-fixup code-object
 					 after-header
 					 value
-					 kind)))))) ))
+					 kind))))))))
   (values))
 
 (defun resolve-assembler-fixups ()
@@ -1839,20 +1859,21 @@
 ;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to
 ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
 ;;; target-load.lisp refers to.
-(defun linkage-info-to-core ()
+(defun foreign-symbols-to-core ()
   (let ((result *nil-descriptor*))
     (maphash (lambda (symbol value)
-	       (cold-push (cold-cons (string-to-core symbol)
+	       (cold-push (cold-cons (base-string-to-core symbol)
 				     (number-to-core value))
 			  result))
 	     *cold-foreign-symbol-table*)
-    (cold-set (cold-intern '*!initial-foreign-symbols*) result))
+    (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result))
   (let ((result *nil-descriptor*))
     (dolist (rtn *cold-assembler-routines*)
       (cold-push (cold-cons (cold-intern (car rtn))
 			    (number-to-core (cdr rtn)))
 		 result))
     (cold-set (cold-intern '*!initial-assembler-routines*) result)))
+
 
 ;;;; general machinery for cold-loading FASL files
 
@@ -1892,9 +1913,9 @@
   (aver (member pushp '(nil t)))
   (aver (member stackp '(nil t)))
   `(progn
-    (macrolet ((clone-arg () '(read-arg 4)))
+    (macrolet ((clone-arg () '(read-word-arg)))
       (define-cold-fop (,name :pushp ,pushp :stackp ,stackp) ,@forms))
-    (macrolet ((clone-arg () '(read-arg 1)))
+    (macrolet ((clone-arg () '(read-byte-arg)))
       (define-cold-fop (,small-name :pushp ,pushp :stackp ,stackp) ,@forms))))
 
 ;;; Cause a fop to be undefined in cold load.
@@ -1921,7 +1942,7 @@
 (define-cold-fop (fop-misc-trap) *unbound-marker*)
 
 (define-cold-fop (fop-short-character)
-  (make-character-descriptor (read-arg 1)))
+  (make-character-descriptor (read-byte-arg)))
 
 (define-cold-fop (fop-empty-list) *nil-descriptor*)
 (define-cold-fop (fop-truth) (cold-intern t))
@@ -1940,19 +1961,28 @@
   (let* ((size (clone-arg))
 	 (result (allocate-boxed-object *dynamic*
 					(1+ size)
-					sb!vm:instance-pointer-lowtag)))
+					sb!vm:instance-pointer-lowtag))
+	 (layout (pop-stack))
+	 (nuntagged
+	  (descriptor-fixnum
+	   (read-wordindexed layout (+ sb!vm:instance-slots-offset 16))))
+	 (ntagged (- size nuntagged)))
     (write-memory result (make-other-immediate-descriptor
 			  size sb!vm:instance-header-widetag))
-    (do ((index (1- size) (1- index)))
-	((minusp index))
+    (write-wordindexed result sb!vm:instance-slots-offset layout)
+    (do ((index 1 (1+ index)))
+	((eql index size))
       (declare (fixnum index))
       (write-wordindexed result
 			 (+ index sb!vm:instance-slots-offset)
-			 (pop-stack)))
+			 (if (>= index ntagged)
+			     (descriptor-word-sized-integer (pop-stack))
+			     (pop-stack))))
     result))
 
 (define-cold-fop (fop-layout)
-  (let* ((length-des (pop-stack))
+  (let* ((nuntagged-des (pop-stack))
+	 (length-des (pop-stack))
 	 (depthoid-des (pop-stack))
 	 (cold-inherits (pop-stack))
 	 (name (pop-stack))
@@ -1970,39 +2000,48 @@
 	   old-name
 	   old-length
 	   old-inherits-list
-	   old-depthoid)
+	   old-depthoid
+	   old-nuntagged)
 	  old
 	(declare (type descriptor old-layout-descriptor))
-	(declare (type index old-length))
+	(declare (type index old-length old-nuntagged))
 	(declare (type fixnum old-depthoid))
 	(declare (type list old-inherits-list))
 	(aver (eq name old-name))
 	(let ((length (descriptor-fixnum length-des))
 	      (inherits-list (listify-cold-inherits cold-inherits))
-	      (depthoid (descriptor-fixnum depthoid-des)))
+	      (depthoid (descriptor-fixnum depthoid-des))
+	      (nuntagged (descriptor-fixnum nuntagged-des)))
 	  (unless (= length old-length)
 	    (error "cold loading a reference to class ~S when the compile~%~
-		   time length was ~S and current length is ~S"
+                    time length was ~S and current length is ~S"
 		   name
 		   length
 		   old-length))
 	  (unless (equal inherits-list old-inherits-list)
 	    (error "cold loading a reference to class ~S when the compile~%~
-		   time inherits were ~S~%~
-		   and current inherits are ~S"
+                    time inherits were ~S~%~
+                    and current inherits are ~S"
 		   name
 		   inherits-list
 		   old-inherits-list))
 	  (unless (= depthoid old-depthoid)
 	    (error "cold loading a reference to class ~S when the compile~%~
-		   time inheritance depthoid was ~S and current inheritance~%~
-		   depthoid is ~S"
+                    time inheritance depthoid was ~S and current inheritance~%~
+                    depthoid is ~S"
 		   name
 		   depthoid
-		   old-depthoid)))
+		   old-depthoid))
+	  (unless (= nuntagged old-nuntagged)
+	    (error "cold loading a reference to class ~S when the compile~%~
+                    time number of untagged slots was ~S and is currently ~S"
+		   name
+		   nuntagged
+		   old-nuntagged)))
 	old-layout-descriptor)
       ;; Make a new definition from scratch.
-      (make-cold-layout name length-des cold-inherits depthoid-des))))
+      (make-cold-layout name length-des cold-inherits depthoid-des
+			nuntagged-des))))
 
 ;;;; cold fops for loading symbols
 
@@ -2019,9 +2058,9 @@
 		  (push-fop-table
 		   (cold-load-symbol (read-arg ,pname-len)
 				     (svref *current-fop-table* index)))))))
-  (frob fop-symbol-in-package-save 4 4)
-  (frob fop-small-symbol-in-package-save 1 4)
-  (frob fop-symbol-in-byte-package-save 4 1)
+  (frob fop-symbol-in-package-save #.sb!vm:n-word-bytes #.sb!vm:n-word-bytes)
+  (frob fop-small-symbol-in-package-save 1 #.sb!vm:n-word-bytes)
+  (frob fop-symbol-in-byte-package-save #.sb!vm:n-word-bytes 1)
   (frob fop-small-symbol-in-byte-package-save 1 1))
 
 (clone-cold-fop (fop-lisp-symbol-save)
@@ -2051,9 +2090,9 @@
      (declare (fixnum index))))
 
 (define-cold-fop (fop-list)
-  (cold-stack-list (read-arg 1) *nil-descriptor*))
+  (cold-stack-list (read-byte-arg) *nil-descriptor*))
 (define-cold-fop (fop-list*)
-  (cold-stack-list (read-arg 1) (pop-stack)))
+  (cold-stack-list (read-byte-arg) (pop-stack)))
 (define-cold-fop (fop-list-1)
   (cold-stack-list 1 *nil-descriptor*))
 (define-cold-fop (fop-list-2)
@@ -2089,12 +2128,17 @@
 
 ;;;; cold fops for loading vectors
 
-(clone-cold-fop (fop-string)
-		(fop-small-string)
+(clone-cold-fop (fop-base-string)
+		(fop-small-base-string)
   (let* ((len (clone-arg))
 	 (string (make-string len)))
     (read-string-as-bytes *fasl-input-stream* string)
-    (string-to-core string)))
+    (base-string-to-core string)))
+
+#!+sb-unicode
+(clone-cold-fop (fop-character-string)
+		(fop-small-character-string)
+  (bug "CHARACTER-STRING dumped by cross-compiler."))
 
 (clone-cold-fop (fop-vector)
 		(fop-small-vector)
@@ -2112,8 +2156,8 @@
     result))
 
 (define-cold-fop (fop-int-vector)
-  (let* ((len (read-arg 4))
-	 (sizebits (read-arg 1))
+  (let* ((len (read-word-arg))
+	 (sizebits (read-byte-arg))
 	 (type (case sizebits
 		 (0 sb!vm:simple-array-nil-widetag)
 		 (1 sb!vm:simple-bit-vector-widetag)
@@ -2128,6 +2172,11 @@
 		 (31 (prog1 sb!vm:simple-array-unsigned-byte-31-widetag
 		       (setf sizebits 32)))
 		 (32 sb!vm:simple-array-unsigned-byte-32-widetag)
+                 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                 (63 (prog1 sb!vm:simple-array-unsigned-byte-63-widetag
+                       (setf sizebits 64)))
+                 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
+                 (64 sb!vm:simple-array-unsigned-byte-64-widetag)
 		 (t (error "losing element size: ~W" sizebits))))
 	 (result (allocate-vector-object *dynamic* sizebits len type))
 	 (start (+ (descriptor-byte-offset result)
@@ -2142,7 +2191,7 @@
     result))
 
 (define-cold-fop (fop-single-float-vector)
-  (let* ((len (read-arg 4))
+  (let* ((len (read-word-arg))
 	 (result (allocate-vector-object
 		  *dynamic*
 		  sb!vm:n-word-bits
@@ -2150,7 +2199,7 @@
 		  sb!vm:simple-array-single-float-widetag))
 	 (start (+ (descriptor-byte-offset result)
 		   (ash sb!vm:vector-data-offset sb!vm:word-shift)))
-	 (end (+ start (* len sb!vm:n-word-bytes))))
+	 (end (+ start (* len 4))))
     (read-bigvec-as-sequence-or-die (descriptor-bytes result)
 				    *fasl-input-stream*
 				    :start start
@@ -2164,7 +2213,7 @@
 #!+long-float (not-cold-fop fop-complex-long-float-vector)
 
 (define-cold-fop (fop-array)
-  (let* ((rank (read-arg 4))
+  (let* ((rank (read-word-arg))
 	 (data-vector (pop-stack))
 	 (result (allocate-boxed-object *dynamic*
 					(+ sb!vm:array-dimensions-offset rank)
@@ -2196,6 +2245,7 @@
 			 sb!vm:array-elements-slot
 			 (make-fixnum-descriptor total-elements)))
     result))
+
 
 ;;;; cold fops for loading numbers
 
@@ -2235,7 +2285,7 @@
 (defvar *load-time-value-counter*)
 
 (define-cold-fop (fop-funcall)
-  (unless (= (read-arg 1) 0)
+  (unless (= (read-byte-arg) 0)
     (error "You can't FOP-FUNCALL arbitrary stuff in cold load."))
   (let ((counter *load-time-value-counter*))
     (cold-push (cold-cons
@@ -2257,7 +2307,7 @@
 				    sb!vm:simple-vector-widetag)))
 
 (define-cold-fop (fop-funcall-for-effect :pushp nil)
-  (if (= (read-arg 1) 0)
+  (if (= (read-byte-arg) 0)
       (cold-push (pop-stack)
 		 *current-reversed-cold-toplevels*)
       (error "You can't FOP-FUNCALL arbitrary stuff in cold load.")))
@@ -2265,18 +2315,18 @@
 ;;;; cold fops for fixing up circularities
 
 (define-cold-fop (fop-rplaca :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4)))
+  (let ((obj (svref *current-fop-table* (read-word-arg)))
+	(idx (read-word-arg)))
     (write-memory (cold-nthcdr idx obj) (pop-stack))))
 
 (define-cold-fop (fop-rplacd :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4)))
+  (let ((obj (svref *current-fop-table* (read-word-arg)))
+	(idx (read-word-arg)))
     (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack))))
 
 (define-cold-fop (fop-svset :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4)))
+  (let ((obj (svref *current-fop-table* (read-word-arg)))
+	(idx (read-word-arg)))
     (write-wordindexed obj
 		   (+ idx
 		      (ecase (descriptor-lowtag obj)
@@ -2285,14 +2335,14 @@
 		   (pop-stack))))
 
 (define-cold-fop (fop-structset :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-arg 4)))
-	(idx (read-arg 4)))
+  (let ((obj (svref *current-fop-table* (read-word-arg)))
+	(idx (read-word-arg)))
     (write-wordindexed obj (1+ idx) (pop-stack))))
 
 ;;; In the original CMUCL code, this actually explicitly declared PUSHP
 ;;; to be T, even though that's what it defaults to in DEFINE-COLD-FOP.
 (define-cold-fop (fop-nthcdr)
-  (cold-nthcdr (read-arg 4) (pop-stack)))
+  (cold-nthcdr (read-word-arg) (pop-stack)))
 
 (defun cold-nthcdr (index obj)
   (dotimes (i index)
@@ -2385,9 +2435,9 @@
 		     (bvref-32 (descriptor-bytes des) i)))))
        des)))
 
-(define-cold-code-fop fop-code (read-arg 4) (read-arg 4))
+(define-cold-code-fop fop-code (read-word-arg) (read-word-arg))
 
-(define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2))
+(define-cold-code-fop fop-small-code (read-byte-arg) (read-halfword-arg))
 
 (clone-cold-fop (fop-alter-code :pushp nil)
 		(fop-byte-alter-code)
@@ -2401,7 +2451,7 @@
 	 (arglist (pop-stack))
 	 (name (pop-stack))
 	 (code-object (pop-stack))
-	 (offset (calc-offset code-object (read-arg 4)))
+	 (offset (calc-offset code-object (read-word-arg)))
 	 (fn (descriptor-beyond code-object
 				offset
 				sb!vm:fun-pointer-lowtag))
@@ -2433,12 +2483,12 @@
 		       ;; itself.) Ask on the mailing list whether
 		       ;; this is documented somewhere, and if not,
 		       ;; try to reverse engineer some documentation.
-		       #!-x86
+		       #!-(or x86 x86-64)
 		       ;; a pointer back to the function object, as
 		       ;; described in CMU CL
 		       ;; src/docs/internals/object.tex
 		       fn
-		       #!+x86
+		       #!+(or x86 x86-64)
 		       ;; KLUDGE: a pointer to the actual code of the
 		       ;; object, as described nowhere that I can find
 		       ;; -- WHN 19990907
@@ -2459,16 +2509,28 @@
 (define-cold-fop (fop-foreign-fixup)
   (let* ((kind (pop-stack))
 	 (code-object (pop-stack))
-	 (len (read-arg 1))
+	 (len (read-byte-arg))
 	 (sym (make-string len)))
     (read-string-as-bytes *fasl-input-stream* sym)
-    (let ((offset (read-arg 4))
+    (let ((offset (read-word-arg))
 	  (value (cold-foreign-symbol-address-as-integer sym)))
       (do-cold-fixup code-object offset value kind))
-    code-object))
+   code-object))
+
+#!+linkage-table
+(define-cold-fop (fop-foreign-dataref-fixup)
+  (let* ((kind (pop-stack))
+	 (code-object (pop-stack))
+	 (len (read-byte-arg))
+	 (sym (make-string len)))
+    (read-string-as-bytes *fasl-input-stream* sym)
+    (maphash (lambda (k v)
+               (format *error-output* "~&~S = #X~8X~%" k v))
+             *cold-foreign-symbol-table*)
+    (error "shared foreign symbol in cold load: ~S (~S)" sym kind)))
 
 (define-cold-fop (fop-assembler-code)
-  (let* ((length (read-arg 4))
+  (let* ((length (read-word-arg))
 	 (header-n-words
 	  ;; Note: we round the number of constants up to ensure that
 	  ;; the code vector will be properly aligned.
@@ -2501,7 +2563,7 @@
 (define-cold-fop (fop-assembler-routine)
   (let* ((routine (pop-stack))
 	 (des (pop-stack))
-	 (offset (calc-offset des (read-arg 4))))
+	 (offset (calc-offset des (read-word-arg))))
     (record-cold-assembler-routine
      routine
      (+ (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) offset))
@@ -2511,14 +2573,14 @@
   (let* ((routine (pop-stack))
 	 (kind (pop-stack))
 	 (code-object (pop-stack))
-	 (offset (read-arg 4)))
+	 (offset (read-word-arg)))
     (record-cold-assembler-fixup routine code-object offset kind)
     code-object))
 
 (define-cold-fop (fop-code-object-fixup)
   (let* ((kind (pop-stack))
 	 (code-object (pop-stack))
-	 (offset (read-arg 4))
+	 (offset (read-word-arg))
 	 (value (descriptor-bits code-object)))
     (do-cold-fixup code-object offset value kind)
     code-object))
@@ -2533,6 +2595,7 @@
   (format t "/*~%")
   (dolist (line
 	   '("This is a machine-generated file. Please do not edit it by hand."
+             "(As of sbcl-0.8.14, it came from WRITE-CONFIG-H in genesis.lisp.)"
 	     ""
 	     "This file contains low-level information about the"
 	     "internals of a particular version and configuration"
@@ -2620,9 +2683,25 @@
               (maybe-record-with-munged-name "-TRAP" "trap_" 3)
               (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
               (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
-              (maybe-record-with-translated-name '("-START" "-END") 6)
+              (maybe-record-with-translated-name '("-START" "-END" "-SIZE") 6)
               (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7)
               (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8))))))
+    ;; KLUDGE: these constants are sort of important, but there's no
+    ;; pleasing way to inform the code above about them.  So we fake
+    ;; it for now.  nikodemus on #lisp (2004-08-09) suggested simply
+    ;; exporting every numeric constant from SB!VM; that would work,
+    ;; but the C runtime would have to be altered to use Lisp-like names
+    ;; rather than the munged names currently exported.  --njf, 2004-08-09
+    (dolist (c '(sb!vm:n-word-bits sb!vm:n-word-bytes
+                 sb!vm:n-lowtag-bits sb!vm:lowtag-mask
+                 sb!vm:n-widetag-bits sb!vm:widetag-mask
+                 sb!vm:n-fixnum-tag-bits sb!vm:fixnum-tag-mask))
+      (push (list (substitute #\_ #\- (symbol-name c))
+                  -1                    ; invent a new priority
+                  (symbol-value c)
+                  nil)
+            constants))
+
     (setf constants
 	  (sort constants
 		(lambda (const1 const2)
@@ -2733,6 +2812,23 @@
       (terpri)))
     (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
 
+(defun write-structure-object (dd)
+  (flet ((cstring (designator)
+	   (substitute #\_ #\- (string-downcase (string designator)))))
+    (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
+    (format t "struct ~A {~%" (cstring (dd-name dd)))
+    (format t "    lispobj header;~%")
+    (format t "    lispobj layout;~%")
+    (dolist (slot (dd-slots dd))
+      (when (eq t (dsd-raw-type slot))
+	(format t "    lispobj ~A;~%" (cstring (dsd-name slot)))))
+    (unless (oddp (+ (dd-length dd) (dd-raw-length dd)))
+      (format t "    long raw_slot_padding;~%"))
+    (dotimes (n (dd-raw-length dd))
+      (format t "    long raw~D;~%" (- (dd-raw-length dd) n 1)))
+    (format t "};~2%")
+    (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")))
+
 (defun write-static-symbols ()
   (dolist (symbol (cons nil sb!vm:*static-symbols*))
     ;; FIXME: It would be nice to use longer names than NIL and
@@ -2938,7 +3034,7 @@ initially undefined function references:~2%")
 	  ;; (We write each character as a word in order to avoid
 	  ;; having to think about word alignment issues in the
 	  ;; sbcl-0.7.8 version of coreparse.c.)
-	  (write-word (char-code char))))
+	  (write-word (sb!xc:char-code char))))
 
       ;; Write the New Directory entry header.
       (write-word new-directory-core-entry-type-code)
@@ -2999,10 +3095,6 @@ initially undefined function references:~2%")
 		      map-file-name
 		      c-header-dir-name)
 
-  (when (and core-file-name
-	     (not symbol-table-file-name))
-    (error "can't output a core file without symbol table file input"))
-
   (format t
 	  "~&beginning GENESIS, ~A~%"
 	  (if core-file-name
@@ -3012,11 +3104,13 @@ initially undefined function references:~2%")
 	    ;; create a core.
 	    (format nil "creating core ~S" core-file-name)
 	    (format nil "creating headers in ~S" c-header-dir-name)))
-  (let* ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
+  
+  (let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
 
-    ;; Read symbol table, if any.
-    (when symbol-table-file-name
-      (load-cold-foreign-symbol-table symbol-table-file-name))
+    (when core-file-name
+      (if symbol-table-file-name
+	  (load-cold-foreign-symbol-table symbol-table-file-name)
+	  (error "can't output a core file without symbol table file input")))
 
     ;; Now that we've successfully read our only input file (by
     ;; loading the symbol table, if any), it's a good time to ensure
@@ -3057,7 +3151,7 @@ initially undefined function references:~2%")
 			      sb!vm:unbound-marker-widetag))
 	   *cold-assembler-fixups*
 	   *cold-assembler-routines*
-	   #!+x86 *load-time-code-fixups*)
+	   #!+(or x86 x86-64) *load-time-code-fixups*)
 
       ;; Prepare for cold load.
       (initialize-non-nil-symbols)
@@ -3125,8 +3219,8 @@ initially undefined function references:~2%")
 
       ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
       (resolve-assembler-fixups)
-      #!+x86 (output-load-time-code-fixups)
-      (linkage-info-to-core)
+      #!+(or x86 x86-64) (output-load-time-code-fixups)
+      (foreign-symbols-to-core)
       (finish-symbols)
       (/show "back from FINISH-SYMBOLS")
       (finalize-load-time-value-noise)
@@ -3188,6 +3282,11 @@ initially undefined function references:~2%")
 		    (format t "~&#include \"~A.h\"~%"
 			    (string-downcase 
 			     (string (sb!vm:primitive-object-name obj)))))))
+	(dolist (class '(hash-table layout))
+	  (out-to
+	   (string-downcase (string class))
+	   (write-structure-object
+	    (sb!kernel:layout-info (sb!kernel:find-layout class)))))
 	(out-to "static-symbols" (write-static-symbols))
 	
       (when core-file-name