X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=89b6be2ecc28066f796e50dba78062955fb4ccf8;hb=f143939b1dbaf38ebd4f92c851fbc4ecddf37af1;hp=28eb128cad9c260fcc42b88b957613eaf5ff19f4;hpb=c3887143fdc6da9b63d18ce5cde2a0c037ea3a24;p=sbcl.git

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 28eb128..89b6be2 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -30,7 +30,7 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
-(in-package "SB!IMPL")
+(in-package "SB!FASL")
 
 ;;; a magic number used to identify our core files
 (defconstant core-magic
@@ -62,6 +62,9 @@
 
 ;;;; representation of spaces in the core
 
+;;; If there is more than one dynamic space in memory (i.e., if a
+;;; copying GC is in use), then only the active dynamic space gets
+;;; dumped to core.
 (defvar *dynamic*)
 (defconstant dynamic-space-id 1)
 
@@ -79,7 +82,8 @@
 
 ;;; a GENESIS-time representation of a memory space (e.g. read-only space,
 ;;; dynamic space, or static space)
-(defstruct (gspace (:constructor %make-gspace))
+(defstruct (gspace (:constructor %make-gspace)
+		   (:copier nil))
   ;; name and identifier for this GSPACE
   (name (required-argument) :type symbol :read-only t)
   (identifier (required-argument) :type fixnum :read-only t)
@@ -129,19 +133,22 @@
 
 (defstruct (descriptor
 	    (:constructor make-descriptor
-			  (high low &optional gspace word-offset)))
+			  (high low &optional gspace word-offset))
+	    (:copier nil))
   ;; 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:word-bits) null))
-  ;; the high and low halves of the descriptor KLUDGE: Judging from
-  ;; the comments in genesis.lisp of the CMU CL old-rt compiler, this
-  ;; split dates back from a very early version of genesis where
-  ;; 32-bit integers were represented as conses of two 16-bit
-  ;; integers. In any system with nice (UNSIGNED-BYTE 32) structure
-  ;; slots, like CMU CL >= 17 or any version of SBCL, there seems to
-  ;; be no reason to persist in this. -- WHN 19990917
-  high low)
+  ;; the high and low halves of the descriptor
+  ;;
+  ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL
+  ;; old-rt compiler, this split dates back from a very early version
+  ;; of genesis where 32-bit integers were represented as conses of
+  ;; two 16-bit integers. In any system with nice (UNSIGNED-BYTE 32)
+  ;; structure slots, like CMU CL >= 17 or any version of SBCL, there
+  ;; seems to be no reason to persist in this. -- WHN 19990917
+  high
+  low)
 (def!method print-object ((des descriptor) stream)
   (let ((lowtag (descriptor-lowtag des)))
     (print-unreadable-object (des stream :type t)
@@ -174,11 +181,11 @@
 			   (gspace-name gspace)
 			   "unknown"))))))))
 
-(defun allocate-descriptor (gspace length lowtag)
-  #!+sb-doc
-  "Return a descriptor for a block of LENGTH bytes out of GSPACE. The free
-  word index is boosted as necessary, and if additional memory is needed, we
-  grow the GSPACE. The descriptor returned is a pointer of type LOWTAG."
+;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The
+;;; free word index is boosted as necessary, and if additional memory
+;;; is needed, we grow the GSPACE. The descriptor returned is a
+;;; pointer of type LOWTAG.
+(defun allocate-cold-descriptor (gspace length lowtag)
   (let* ((bytes (round-up length (ash 1 sb!vm:lowtag-bits)))
 	 (old-free-word-index (gspace-free-word-index gspace))
 	 (new-free-word-index (+ old-free-word-index
@@ -244,7 +251,7 @@
     (let ((lowtag (descriptor-lowtag des))
 	  (high (descriptor-high des))
 	  (low (descriptor-low des)))
-      (if (or (eql lowtag sb!vm:function-pointer-type)
+      (if (or (eql lowtag sb!vm:fun-pointer-type)
 	      (eql lowtag sb!vm:instance-pointer-type)
 	      (eql lowtag sb!vm:list-pointer-type)
 	      (eql lowtag sb!vm:other-pointer-type))
@@ -342,7 +349,7 @@
 ;;; comparing the byte order of *BACKEND* to the byte order of
 ;;; *NATIVE-BACKEND*, a concept which doesn't exist in SBCL. Instead,
 ;;; in SBCL byte order swapping would need to be explicitly requested
-;;; with a keyword argument to GENESIS.
+;;; with a &KEY argument to GENESIS.
 ;;;
 ;;; I'm not sure whether this is a problem or not, and I don't have a
 ;;; machine with different byte order to test to find out for sure.
@@ -373,8 +380,8 @@
 
 (defun maybe-byte-swap (word)
   (declare (type (unsigned-byte 32) word))
-  (assert (= sb!vm:word-bits 32))
-  (assert (= sb!vm:byte-bits 8))
+  (aver (= sb!vm:word-bits 32))
+  (aver (= sb!vm:byte-bits 8))
   (if (not *genesis-byte-order-swap-p*)
       word
       (logior (ash (ldb (byte 8 0) word) 24)
@@ -384,37 +391,48 @@
 
 (defun maybe-byte-swap-short (short)
   (declare (type (unsigned-byte 16) short))
-  (assert (= sb!vm:word-bits 32))
-  (assert (= sb!vm:byte-bits 8))
+  (aver (= sb!vm:word-bits 32))
+  (aver (= sb!vm:byte-bits 8))
   (if (not *genesis-byte-order-swap-p*)
       short
       (logior (ash (ldb (byte 8 0) short) 8)
 	      (ldb (byte 8 8) short))))
 
-;;; like SAP-REF-32, except that instead of a SAP we use a byte vector
-(defun byte-vector-ref-32 (byte-vector byte-index)
-  (assert (= sb!vm:word-bits 32))
-  (assert (= sb!vm:byte-bits 8))
+;;; BYTE-VECTOR-REF-32 and friends.  These are like SAP-REF-n, except
+;;; that instead of a SAP we use a byte vector
+(macrolet ((make-byte-vector-ref-n
+            (n)
+            (let* ((name (intern (format nil "BYTE-VECTOR-REF-~A" n)))
+                   (number-octets (/ n 8))
+                   (ash-list
+                    (loop for i from 0 to (1- number-octets)
+                          collect `(ash (aref byte-vector (+ byte-index ,i))
+                                        ,(* i 8))))
+                   (setf-list
+                    (loop for i from 0 to (1- number-octets)
+                          append
+                          `((aref byte-vector (+ byte-index ,i))
+                            (ldb (byte 8 ,(* i 8)) new-value)))))
+              `(progn
+                 (defun ,name (byte-vector byte-index)
+  (aver (= sb!vm:word-bits 32))
+  (aver (= sb!vm:byte-bits 8))
   (ecase sb!c:*backend-byte-order*
     (:little-endian
-     (logior (ash (aref byte-vector (+ byte-index 0)) 0)
-	     (ash (aref byte-vector (+ byte-index 1)) 8)
-	     (ash (aref byte-vector (+ byte-index 2)) 16)
-	     (ash (aref byte-vector (+ byte-index 3)) 24)))
+                      (logior ,@ash-list))
     (:big-endian
      (error "stub: no big-endian ports of SBCL (yet?)"))))
-(defun (setf byte-vector-ref-32) (new-value byte-vector byte-index)
-  (assert (= sb!vm:word-bits 32))
-  (assert (= sb!vm:byte-bits 8))
+                 (defun (setf ,name) (new-value byte-vector byte-index)
+  (aver (= sb!vm:word-bits 32))
+  (aver (= sb!vm:byte-bits 8))
   (ecase sb!c:*backend-byte-order*
     (:little-endian
-     (setf (aref byte-vector (+ byte-index 0)) (ldb (byte 8 0) new-value)
-	   (aref byte-vector (+ byte-index 1)) (ldb (byte 8 8) new-value)
-	   (aref byte-vector (+ byte-index 2)) (ldb (byte 8 16) new-value)
-	   (aref byte-vector (+ byte-index 3)) (ldb (byte 8 24) new-value)))
+                      (setf ,@setf-list))
     (:big-endian
-     (error "stub: no big-endian ports of SBCL (yet?)")))
-  new-value)
+                      (error "stub: no big-endian ports of SBCL (yet?)"))))))))
+  (make-byte-vector-ref-n 8)
+  (make-byte-vector-ref-n 16)
+  (make-byte-vector-ref-n 32))
 
 (declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed))
 (defun read-wordindexed (address index)
@@ -496,16 +514,16 @@
   #!+sb-doc
   "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
   pointing to them."
-  (allocate-descriptor gspace (ash length sb!vm:word-shift) lowtag))
+  (allocate-cold-descriptor gspace (ash length sb!vm:word-shift) lowtag))
 (defun allocate-unboxed-object (gspace element-bits length type)
   #!+sb-doc
   "Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and
   return an ``other-pointer'' descriptor to them. Initialize the header word
   with the resultant length and TYPE."
   (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
-	 (des (allocate-descriptor gspace
-				   (+ bytes sb!vm:word-bytes)
-				   sb!vm:other-pointer-type)))
+	 (des (allocate-cold-descriptor gspace
+					(+ bytes sb!vm:word-bytes)
+					sb!vm:other-pointer-type)))
     (write-memory des
 		  (make-other-immediate-descriptor (ash bytes
 							(- sb!vm:word-shift))
@@ -519,8 +537,9 @@
   ;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using
   ;; #'/ instead of #'CEILING, which seems wrong.
   (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
-	 (des (allocate-descriptor gspace (+ bytes (* 2 sb!vm:word-bytes))
-					  sb!vm:other-pointer-type)))
+	 (des (allocate-cold-descriptor gspace
+					(+ bytes (* 2 sb!vm:word-bytes))
+					sb!vm:other-pointer-type)))
     (write-memory des (make-other-immediate-descriptor 0 type))
     (write-wordindexed des
 		       sb!vm:vector-length-slot
@@ -724,7 +743,7 @@
 
 ;;;; symbol magic
 
-;;; FIXME: This should be a keyword argument of ALLOCATE-SYMBOL.
+;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL.
 (defvar *cold-symbol-allocation-gspace* nil)
 
 ;;; Allocate (and initialize) a symbol.
@@ -1007,8 +1026,8 @@
 	;;   (CAR COLD-INTERN-INFO) = descriptor of symbol
 	;;   (CDR COLD-INTERN-INFO) = list of packages, other than symbol's
 	;;			    own package, referring to symbol
-	;; (*COLD-PACKAGE-SYMBOLS* and *COLD-SYMBOLS* store basically the same
-	;; information, but with the mapping running the opposite way.)
+	;; (*COLD-PACKAGE-SYMBOLS* and *COLD-SYMBOLS* store basically the
+	;; same information, but with the mapping running the opposite way.)
 	(cold-intern-info (get symbol 'cold-intern-info)))
     (unless cold-intern-info
       (cond ((eq (symbol-package symbol) package)
@@ -1120,18 +1139,16 @@
   ;; the function values for these things?? I.e. why do we need this
   ;; section at all? Is it because all the FDEFINITION stuff gets in
   ;; the way of reading function values and is too hairy to rely on at
-  ;; cold boot? FIXME: 5/6 of these are in *STATIC-SYMBOLS* in
-  ;; parms.lisp, but %HANDLE-FUNCTION-END-BREAKPOINT is not. Why?
+  ;; cold boot? FIXME: Most of these are in *STATIC-SYMBOLS* in
+  ;; parms.lisp, but %HANDLE-FUN-END-BREAKPOINT is not. Why?
   ;; Explain.
   (macrolet ((frob (symbol)
 	       `(cold-set ',symbol
 			  (cold-fdefinition-object (cold-intern ',symbol)))))
-    (frob !cold-init)
-    (frob sb!impl::maybe-gc)
+    (frob maybe-gc)
     (frob internal-error)
     (frob sb!di::handle-breakpoint)
-    (frob sb!di::handle-function-end-breakpoint)
-    (frob sb!impl::fdefinition-object))
+    (frob sb!di::handle-fun-end-breakpoint))
 
   (cold-set '*current-catch-block*          (make-fixnum-descriptor 0))
   (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0))
@@ -1139,9 +1156,7 @@
 
   (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0))
 
-  ;; FIXME: *!INITIAL-LAYOUTS* should be exported from SB!KERNEL, or
-  ;; perhaps from SB-LD.
-  (cold-set 'sb!kernel::*!initial-layouts* (cold-list-all-layouts))
+  (cold-set '*!initial-layouts* (cold-list-all-layouts))
 
   (/show "dumping packages" (mapcar #'car *cold-package-symbols*))
   (let ((initial-symbols *nil-descriptor*))
@@ -1229,9 +1244,7 @@
       (cold-set 'sb!vm::*fp-constant-lg2* (number-to-core (log 2L0 10L0)))
       (cold-set 'sb!vm::*fp-constant-ln2*
 	    (number-to-core
-	     (log 2L0 2.718281828459045235360287471352662L0))))
-    #!+gencgc
-    (cold-set 'sb!vm::*SCAVENGE-READ-ONLY-GSPACE* *nil-descriptor*)))
+	     (log 2L0 2.718281828459045235360287471352662L0))))))
 
 ;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order
 ;;; to make a package that is similar to PKG.
@@ -1282,41 +1295,69 @@
     (cold-push (string-to-core (package-name pkg)) res)
     res))
 
-;;;; fdefinition objects
+;;;; functions and fdefinition objects
 
 ;;; a hash table mapping from fdefinition names to descriptors of cold
-;;; objects. Note: Since fdefinition names can be lists like '(SETF
-;;; FOO), and we want to have only one entry per name, this must be an
-;;; 'EQUAL hash table, not the default 'EQL.
+;;; objects
+;;;
+;;; Note: Since fdefinition names can be lists like '(SETF FOO), and
+;;; we want to have only one entry per name, this must be an 'EQUAL
+;;; hash table, not the default 'EQL.
 (defvar *cold-fdefn-objects*)
 
 (defvar *cold-fdefn-gspace* nil)
 
-;;; Given a cold representation of an FDEFN name, return a warm representation.
-;;;
-;;; Note: Despite the name, this actually has little to do with
-;;; FDEFNs, it's just a function for warming up values, and the only
-;;; values it knows how to warm up are symbols and lists. (The
-;;; connection to FDEFNs is that symbols and lists are the only
-;;; possible names for functions.)
-(declaim (ftype (function (descriptor) (or symbol list)) warm-fdefn-name))
-(defun warm-fdefn-name (des)
-  (ecase (descriptor-lowtag des)
-    (#.sb!vm:list-pointer-type ; FIXME: no #.
-     (if (= (descriptor-bits des) (descriptor-bits *nil-descriptor*))
-	 nil
-	 ;; FIXME: If we cold-intern this again, we might get a different
-	 ;; name. Check to make sure that any hash tables along the way
-	 ;; are 'EQUAL not 'EQL.
-	 (cons (warm-fdefn-name (read-wordindexed des sb!vm:cons-car-slot))
-	       (warm-fdefn-name (read-wordindexed des sb!vm:cons-cdr-slot)))))
-    (#.sb!vm:other-pointer-type ; FIXME: no #.
-     (or (gethash (descriptor-bits des) *cold-symbols*)
-	 (descriptor-bits des)))))
+;;; Given a cold representation of a symbol, return a warm
+;;; representation. 
+(defun warm-symbol (des)
+  ;; Note that COLD-INTERN is responsible for keeping the
+  ;; *COLD-SYMBOLS* table up to date, so if DES happens to refer to an
+  ;; uninterned symbol, the code below will fail. But as long as we
+  ;; don't need to look up uninterned symbols during bootstrapping,
+  ;; that's OK..
+  (multiple-value-bind (symbol found-p)
+      (gethash (descriptor-bits des) *cold-symbols*)
+    (declare (type symbol symbol))
+    (unless found-p
+      (error "no warm symbol"))
+    symbol))
+  
+;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values
+(defun cold-car (des)
+  (aver (= (descriptor-lowtag des) sb!vm:list-pointer-type))
+  (read-wordindexed des sb!vm:cons-car-slot))
+(defun cold-cdr (des)
+  (aver (= (descriptor-lowtag des) sb!vm:list-pointer-type))
+  (read-wordindexed des sb!vm:cons-cdr-slot))
+(defun cold-null (des)
+  (= (descriptor-bits des)
+     (descriptor-bits *nil-descriptor*)))
+  
+;;; Given a cold representation of a function name, return a warm
+;;; representation.
+(declaim (ftype (function (descriptor) (or symbol list)) warm-fun-name))
+(defun warm-fun-name (des)
+  (let ((result
+	 (ecase (descriptor-lowtag des)
+	   (#.sb!vm:list-pointer-type
+	    (aver (not (cold-null des))) ; function named NIL? please no..
+	    ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..).
+	    (let* ((car-des (cold-car des))
+		   (cdr-des (cold-cdr des))
+		   (cadr-des (cold-car cdr-des))
+		   (cddr-des (cold-cdr cdr-des)))
+	      (aver (cold-null cddr-des))
+	      (list (warm-symbol car-des)
+		    (warm-symbol cadr-des))))
+	   (#.sb!vm:other-pointer-type
+	    (warm-symbol des)))))
+    (unless (legal-function-name-p result)
+      (error "not a legal function name: ~S" result))
+    result))
 
 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
   (declare (type descriptor cold-name))
-  (let ((warm-name (warm-fdefn-name cold-name)))
+  (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*)
 					    (1- sb!vm:fdefn-size)
@@ -1327,34 +1368,37 @@
 			       (1- sb!vm:fdefn-size) sb!vm:fdefn-type))
 	  (write-wordindexed fdefn sb!vm:fdefn-name-slot cold-name)
 	  (unless leave-fn-raw
-	    (write-wordindexed fdefn sb!vm:fdefn-function-slot
+	    (write-wordindexed fdefn sb!vm:fdefn-fun-slot
 			       *nil-descriptor*)
 	    (write-wordindexed fdefn
 			       sb!vm:fdefn-raw-addr-slot
 			       (make-random-descriptor
-				(lookup-foreign-symbol "undefined_tramp"))))
+				(cold-foreign-symbol-address-as-integer
+				 "undefined_tramp"))))
 	  fdefn))))
 
-(defun cold-fset (cold-name defn)
+;;; Handle the at-cold-init-time, fset-for-static-linkage operation
+;;; requested by FOP-FSET.
+(defun static-fset (cold-name defn)
   (declare (type descriptor cold-name))
   (let ((fdefn (cold-fdefinition-object cold-name t))
 	(type (logand (descriptor-low (read-memory defn)) sb!vm:type-mask)))
-    (write-wordindexed fdefn sb!vm:fdefn-function-slot defn)
+    (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn)
     (write-wordindexed fdefn
 		       sb!vm:fdefn-raw-addr-slot
 		       (ecase type
-			 (#.sb!vm:function-header-type
+			 (#.sb!vm:simple-fun-header-type
 			  #!+sparc
 			  defn
 			  #!-sparc
 			  (make-random-descriptor
 			   (+ (logandc2 (descriptor-bits defn)
 					sb!vm:lowtag-mask)
-			      (ash sb!vm:function-code-offset
+			      (ash sb!vm:simple-fun-code-offset
 				   sb!vm:word-shift))))
 			 (#.sb!vm:closure-header-type
 			  (make-random-descriptor
-			   (lookup-foreign-symbol "closure_tramp")))))
+			   (cold-foreign-symbol-address-as-integer "closure_tramp")))))
     fdefn))
 
 (defun initialize-static-fns ()
@@ -1385,7 +1429,9 @@
 (defvar *cold-foreign-symbol-table*)
 (declaim (type hash-table *cold-foreign-symbol-table*))
 
-(defun load-foreign-symbol-table (filename)
+;;; Read the sbcl.nm file to find the addresses for foreign-symbols in
+;;; the C runtime.  
+(defun load-cold-foreign-symbol-table (filename)
   (with-open-file (file filename)
     (loop
       (let ((line (read-line file nil nil)))
@@ -1433,36 +1479,15 @@
 		(setf (gethash name *cold-foreign-symbol-table*) value))))))
     (values)))
 
-(defun lookup-foreign-symbol (name)
-  #!+x86
-  (let ((prefixes
-	 #!+linux #(;; FIXME: How many of these are actually
-		    ;; needed? The first four are taken from rather
-		    ;; disorganized CMU CL code, which could easily
-		    ;; have had redundant values in it..
-		    "_"
-		    "__"
-		    "__libc_"
-		    "ldso_stub__"
-		    ;; ..and the fifth seems to match most
-		    ;; actual symbols, at least in RedHat 6.2.
-		    "")
-	 #!+freebsd #("" "ldso_stub__")
-	 #!+openbsd #("_")))
-    (or (some (lambda (prefix)
-		(gethash (concatenate 'string prefix name)
-			 *cold-foreign-symbol-table*
-			 nil))
-	      prefixes)
-	*foreign-symbol-placeholder-value*
-	(progn
-	  (format *error-output* "~&The foreign symbol table is:~%")
-	  (maphash (lambda (k v)
-		     (format *error-output* "~&~S = #X~8X~%" k v))
-		   *cold-foreign-symbol-table*)
-	  (format *error-output* "~&The prefix table is: ~S~%" prefixes)
-	  (error "The foreign symbol ~S is undefined." name))))
-  #!-x86 (error "non-x86 unsupported in SBCL (but see old CMU CL code)"))
+(defun cold-foreign-symbol-address-as-integer (name)
+  (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*)
+      *foreign-symbol-placeholder-value*
+      (progn
+        (format *error-output* "~&The foreign symbol table is:~%")
+        (maphash (lambda (k v)
+                   (format *error-output* "~&~S = #X~8X~%" k v))
+                 *cold-foreign-symbol-table*)
+        (error "The foreign symbol ~S is undefined." name))))
 
 (defvar *cold-assembler-routines*)
 
@@ -1548,72 +1573,52 @@
 				offset-within-code-object))
 	 (gspace-byte-address (gspace-byte-address
 			       (descriptor-gspace code-object))))
-    (ecase sb!c:*backend-fasl-file-implementation*
-      ;; Classic CMU CL supported these, and I haven't gone out of my way
-      ;; to break them, but I have no way of testing them.. -- WHN 19990817
-      #|
-      (#.sb!c:pmax-fasl-file-implementation
-       (ecase kind
-	 (:jump
-	  (assert (zerop (ash value -28)))
-	  (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
-		(ash value -2)))
-	 (:lui
-	  (setf (sap-ref-16 sap 0)
-		(+ (ash value -16)
-		   (if (logbitp 15 value) 1 0))))
-	 (:addi
-	  (setf (sap-ref-16 sap 0)
-		(ldb (byte 16 0) value)))))
-      (#.sb!c:sparc-fasl-file-implementation
-       (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
+    (ecase +backend-fasl-file-implementation+
+      ;; See CMU CL source for other formerly-supported architectures
+      ;; (and note that you have to rewrite them to use VECTOR-REF
+      ;; unstead of SAP-REF).
+      (:alpha
 	 (ecase kind
-	   (:call
-	    (error "Can't deal with call fixups yet."))
-	   (:sethi
-	    (setf inst
-		  (dpb (ldb (byte 22 10) value)
-		       (byte 22 0)
-		       inst)))
-	   (:add
-	    (setf inst
-		  (dpb (ldb (byte 10 0) value)
-		       (byte 10 0)
-		       inst))))
-	 (setf (sap-ref-32 sap 0)
-	       (maybe-byte-swap inst))))
-      ((#.sb!c:rt-fasl-file-implementation
-	#.sb!c:rt-afpa-fasl-file-implementation)
-       (ecase kind
-	 (:cal
-	  (setf (sap-ref-16 sap 2)
-		(maybe-byte-swap-short
-		 (ldb (byte 16 0) value))))
-	 (:cau
-	  (let ((high (ldb (byte 16 16) value)))
-	    (setf (sap-ref-16 sap 2)
-		  (maybe-byte-swap-short
-		   (if (logbitp 15 value) (1+ high) high)))))
-	 (:ba
-	  (unless (zerop (ash value -24))
-	    (warn "#X~8,'0X out of range for branch-absolute." value))
-	  (let ((inst (maybe-byte-swap-short (sap-ref-16 sap 0))))
+         (:jmp-hint
+          (assert (zerop (ldb (byte 2 0) value)))
+          #+nil ;; was commented out in cmucl source too.  Don't know what
+          ;; it does   -dan 2001.05.03
 	    (setf (sap-ref-16 sap 0)
-		  (maybe-byte-swap-short
-		   (dpb (ldb (byte 8 16) value)
-			(byte 8 0)
-			inst))))
-	  (setf (sap-ref-16 sap 2)
-		(maybe-byte-swap-short (ldb (byte 16 0) value))))))
-      |#
+                (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2)))))
+	 (:bits-63-48
+	  (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+		 (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
+		 (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
+	    (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+                  (ldb (byte 8 48) value)
+                  (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+                  (ldb (byte 8 56) value))))
+	 (:bits-47-32
+	  (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+		 (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
+	    (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+                  (ldb (byte 8 32) value)
+                  (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+                  (ldb (byte 8 40) value))))
+	 (:ldah
+	  (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
+	    (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+                  (ldb (byte 8 16) value)
+                  (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+                  (ldb (byte 8 24) value))))
+	 (:lda
+	  (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+                (ldb (byte 8 0) value)
+                (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+                (ldb (byte 8 8) value)))))
       (:x86
        (let* ((un-fixed-up (byte-vector-ref-32 gspace-bytes
 					       gspace-byte-offset))
 	      (code-object-start-addr (logandc2 (descriptor-bits code-object)
 						sb!vm:lowtag-mask)))
-	 (assert (= code-object-start-addr
-		    (+ gspace-byte-address
-		       (descriptor-byte-offset code-object))))
+         (assert (= code-object-start-addr
+		  (+ gspace-byte-address
+		     (descriptor-byte-offset code-object))))
 	 (ecase kind
 	   (:absolute
 	    (let ((fixed-up (+ value un-fixed-up)))
@@ -1647,75 +1652,7 @@
 	      (note-load-time-code-fixup code-object
 					 after-header
 					 value
-					 kind))))))
-      ;; CMU CL supported these, and I haven't gone out of my way to break
-      ;; them, but I have no way of testing them.. -- WHN 19990817
-      #|
-      (#.sb!c:hppa-fasl-file-implementation
-       (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
-	 (setf (sap-ref-32 sap 0)
-	       (maybe-byte-swap
-		(ecase kind
-		  (:load
-		   (logior (ash (ldb (byte 11 0) value) 1)
-			   (logand inst #xffffc000)))
-		  (:load-short
-		   (let ((low-bits (ldb (byte 11 0) value)))
-		     (assert (<= 0 low-bits (1- (ash 1 4))))
-		     (logior (ash low-bits 17)
-			     (logand inst #xffe0ffff))))
-		  (:hi
-		   (logior (ash (ldb (byte 5 13) value) 16)
-			   (ash (ldb (byte 2 18) value) 14)
-			   (ash (ldb (byte 2 11) value) 12)
-			   (ash (ldb (byte 11 20) value) 1)
-			   (ldb (byte 1 31) value)
-			   (logand inst #xffe00000)))
-		  (:branch
-		   (let ((bits (ldb (byte 9 2) value)))
-		     (assert (zerop (ldb (byte 2 0) value)))
-		     (logior (ash bits 3)
-			     (logand inst #xffe0e002)))))))))
-      (#.sb!c:alpha-fasl-file-implementation
-       (ecase kind
-	 (:jmp-hint
-	  (assert (zerop (ldb (byte 2 0) value)))
-	  #+nil
-	  (setf (sap-ref-16 sap 0)
-		(logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2)))))
-	 (:bits-63-48
-	  (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
-		 (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
-		 (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
-	    (setf (sap-ref-8 sap 0) (ldb (byte 8 48) value))
-	    (setf (sap-ref-8 sap 1) (ldb (byte 8 56) value))))
-	 (:bits-47-32
-	  (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
-		 (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
-	    (setf (sap-ref-8 sap 0) (ldb (byte 8 32) value))
-	    (setf (sap-ref-8 sap 1) (ldb (byte 8 40) value))))
-	 (:ldah
-	  (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
-	    (setf (sap-ref-8 sap 0) (ldb (byte 8 16) value))
-	    (setf (sap-ref-8 sap 1) (ldb (byte 8 24) value))))
-	 (:lda
-	  (setf (sap-ref-8 sap 0) (ldb (byte 8 0) value))
-	  (setf (sap-ref-8 sap 1) (ldb (byte 8 8) value)))))
-      (#.sb!c:sgi-fasl-file-implementation
-       (ecase kind
-	 (:jump
-	  (assert (zerop (ash value -28)))
-	  (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
-		(ash value -2)))
-	 (:lui
-	  (setf (sap-ref-16 sap 2)
-		(+ (ash value -16)
-		   (if (logbitp 15 value) 1 0))))
-	 (:addi
-	  (setf (sap-ref-16 sap 2)
-		(ldb (byte 16 0) value)))))
-      |#
-      ))
+					 kind)))))) ))
   (values))
 
 (defun resolve-assembler-fixups ()
@@ -1725,12 +1662,16 @@
       (when value
 	(do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
 
+;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in
+;;; 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 ()
   (let ((result *nil-descriptor*))
-    (maphash #'(lambda (symbol value)
-		 (cold-push (cold-cons (string-to-core symbol)
-				       (number-to-core value))
-			    result))
+    (maphash (lambda (symbol value)
+	       (cold-push (cold-cons (string-to-core symbol)
+				     (number-to-core value))
+			  result))
 	     *cold-foreign-symbol-table*)
     (cold-set (cold-intern '*!initial-foreign-symbols*) result))
   (let ((result *nil-descriptor*))
@@ -1742,22 +1683,26 @@
 
 ;;;; general machinery for cold-loading FASL files
 
-(defvar *cold-fop-functions* (replace (make-array 256) *fop-functions*)
-  #!+sb-doc
-  "FOP functions for cold loading")
+;;; FOP functions for cold loading
+(defvar *cold-fop-functions*
+  ;; We start out with a copy of the ordinary *FOP-FUNCTIONS*. The
+  ;; ones which aren't appropriate for cold load will be destructively
+  ;; modified.
+  (copy-seq *fop-functions*))
 
 (defvar *normal-fop-functions*)
 
-;;; This is like DEFINE-FOP which defines fops for warm load, but unlike
-;;; DEFINE-FOP, this version
-;;;   (1) looks up the code for this name (created by a previous DEFINE-FOP)
-;;;       instead of creating a code, and
-;;;   (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector, instead
-;;;       of storing in the *FOP-FUNCTIONS* vector.
+;;; Cause a fop to have a special definition for cold load.
+;;; 
+;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version
+;;;   (1) looks up the code for this name (created by a previous
+;;        DEFINE-FOP) instead of creating a code, and
+;;;   (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector,
+;;;       instead of storing in the *FOP-FUNCTIONS* vector.
 (defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
-  (check-type pushp (member nil t :nope))
+  (aver (member pushp '(nil t :nope)))
   (let ((code (get name 'fop-code))
-	(fname (concat-pnames 'cold- name)))
+	(fname (symbolicate "COLD-" name)))
     (unless code
       (error "~S is not a defined FOP." name))
     `(progn
@@ -1768,7 +1713,7 @@
        (setf (svref *cold-fop-functions* ,code) #',fname))))
 
 (defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
-  (check-type pushp (member nil t :nope))
+  (aver (member pushp '(nil t :nope)))
   `(progn
     (macrolet ((clone-arg () '(read-arg 4)))
       (define-cold-fop (,name ,pushp) ,@forms))
@@ -1780,8 +1725,9 @@
   `(define-cold-fop (,name)
      (error "The fop ~S is not supported in cold load." ',name)))
 
-;;; COLD-LOAD loads stuff into the core image being built by calling FASLOAD
-;;; with the fop function table rebound to a table of cold loading functions.
+;;; COLD-LOAD loads stuff into the core image being built by calling
+;;; LOAD-AS-FASL with the fop function table rebound to a table of cold
+;;; loading functions.
 (defun cold-load (filename)
   #!+sb-doc
   "Load the file named by FILENAME into the cold load image being built."
@@ -1791,7 +1737,7 @@
 				 (string filename)
 				 (pathname (namestring filename)))))
     (with-open-file (s filename :element-type '(unsigned-byte 8))
-      (fasload s nil nil))))
+      (load-as-fasl s nil nil))))
 
 ;;;; miscellaneous cold fops
 
@@ -1856,7 +1802,7 @@
 	(declare (type index old-length))
 	(declare (type fixnum old-depthoid))
 	(declare (type list old-inherits-list))
-	(assert (eq name old-name))
+	(aver (eq name old-name))
 	(let ((length (descriptor-fixnum length-des))
 	      (inherits-list (listify-cold-inherits cold-inherits))
 	      (depthoid (descriptor-fixnum depthoid-des)))
@@ -1886,11 +1832,11 @@
 
 ;;;; cold fops for loading symbols
 
-;;; Load a symbol SIZE characters long from *FASL-FILE* and intern
-;;; that symbol in PACKAGE.
+;;; Load a symbol SIZE characters long from *FASL-INPUT-STREAM* and
+;;; intern that symbol in PACKAGE.
 (defun cold-load-symbol (size package)
   (let ((string (make-string size)))
-    (read-string-as-bytes *fasl-file* string)
+    (read-string-as-bytes *fasl-input-stream* string)
     (cold-intern (intern string package) package)))
 
 (macrolet ((frob (name pname-len package-len)
@@ -1916,9 +1862,9 @@
 		(fop-uninterned-small-symbol-save)
   (let* ((size (clone-arg))
 	 (name (make-string size)))
-    (read-string-as-bytes *fasl-file* name)
-    (let ((symbol (allocate-symbol name)))
-      (push-fop-table symbol))))
+    (read-string-as-bytes *fasl-input-stream* name)
+    (let ((symbol-des (allocate-symbol name)))
+      (push-fop-table symbol-des))))
 
 ;;;; cold fops for loading lists
 
@@ -1973,7 +1919,7 @@
 		(fop-small-string)
   (let* ((len (clone-arg))
 	 (string (make-string len)))
-    (read-string-as-bytes *fasl-file* string)
+    (read-string-as-bytes *fasl-input-stream* string)
     (string-to-core string)))
 
 (clone-cold-fop (fop-vector)
@@ -2009,7 +1955,7 @@
 		 (ceiling (* len sizebits)
 			  sb!vm:byte-bits))))
     (read-sequence-or-die (descriptor-bytes result)
-			  *fasl-file*
+			  *fasl-input-stream*
 			  :start start
 			  :end end)
     result))
@@ -2024,7 +1970,7 @@
 		   (ash sb!vm:vector-data-offset sb!vm:word-shift)))
 	 (end (+ start (* len sb!vm:word-bytes))))
     (read-sequence-or-die (descriptor-bytes result)
-			  *fasl-file*
+			  *fasl-input-stream*
 			  :start start
 			  :end end)
     result))
@@ -2092,9 +2038,9 @@
 
 #!+long-float
 (define-cold-fop (fop-long-float)
-  (ecase sb!c:*backend-fasl-file-implementation*
-    (:x86 ; 80 bit long-float format
-     (prepare-for-fast-read-byte *fasl-file*
+  (ecase +backend-fasl-file-implementation+
+    (:x86 ; (which has 80-bit long-float format)
+     (prepare-for-fast-read-byte *fasl-input-stream*
        (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
 					    (1- sb!vm:long-float-size)
 					    sb!vm:long-float-type))
@@ -2110,7 +2056,7 @@
     ;; SBCL.
     #+nil
     (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format
-     (prepare-for-fast-read-byte *fasl-file*
+     (prepare-for-fast-read-byte *fasl-input-stream*
        (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
 					    (1- sb!vm:long-float-size)
 					    sb!vm:long-float-type))
@@ -2127,9 +2073,9 @@
 
 #!+long-float
 (define-cold-fop (fop-complex-long-float)
-  (ecase sb!c:*backend-fasl-file-implementation*
-    (:x86 ; 80 bit long-float format
-     (prepare-for-fast-read-byte *fasl-file*
+  (ecase +backend-fasl-file-implementation+
+    (:x86 ; (which has 80-bit long-float format)
+     (prepare-for-fast-read-byte *fasl-input-stream*
        (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
 					    (1- sb!vm:complex-long-float-size)
 					    sb!vm:complex-long-float-type))
@@ -2162,7 +2108,7 @@
     ;; This was supported in CMU CL, but isn't currently supported in SBCL.
     #+nil
     (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format
-     (prepare-for-fast-read-byte *fasl-file*
+     (prepare-for-fast-read-byte *fasl-input-stream*
        (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
 					    (1- sb!vm:complex-long-float-size)
 					    sb!vm:complex-long-float-type))
@@ -2232,7 +2178,7 @@
     (make-descriptor 0 0 nil counter)))
 
 (defun finalize-load-time-value-noise ()
-  (cold-set (cold-intern 'sb!impl::*!load-time-values*)
+  (cold-set (cold-intern '*!load-time-values*)
 	    (allocate-vector-object *dynamic*
 				    sb!vm:word-bits
 				    *load-time-value-counter*
@@ -2281,10 +2227,22 @@
 
 ;;;; cold fops for loading code objects and functions
 
+;;; the names of things which have had COLD-FSET used on them already
+;;; (used to make sure that we don't try to statically link a name to
+;;; more than one definition)
+(defparameter *cold-fset-warm-names*
+  ;; This can't be an EQL hash table because names can be conses, e.g.
+  ;; (SETF CAR).
+  (make-hash-table :test 'equal))
+
 (define-cold-fop (fop-fset nil)
-  (let ((fn (pop-stack))
-	(name (pop-stack)))
-    (cold-fset name fn)))
+  (let* ((fn (pop-stack))
+	 (cold-name (pop-stack))
+	 (warm-name (warm-fun-name cold-name)))
+    (if (gethash warm-name *cold-fset-warm-names*)
+	(error "duplicate COLD-FSET for ~S" warm-name)
+	(setf (gethash warm-name *cold-fset-warm-names*) t))
+    (static-fset cold-name fn)))
 
 (define-cold-fop (fop-fdefinition)
   (cold-fdefinition-object (pop-stack)))
@@ -2292,8 +2250,6 @@
 (define-cold-fop (fop-sanctify-for-execution)
   (pop-stack))
 
-(not-cold-fop fop-make-byte-compiled-function)
-
 ;;; Setting this variable shows what code looks like before any
 ;;; fixups (or function headers) are applied.
 #!+sb-show (defvar *show-pre-fixup-code-p* nil)
@@ -2312,14 +2268,11 @@
 	     ;; Note: we round the number of constants up to ensure
 	     ;; that the code vector will be properly aligned.
 	     (round-up raw-header-n-words 2))
-	    (des (allocate-descriptor
-		  ;; In the X86 with CGC, code can't be relocated, so
-		  ;; we have to put it into static space. In all other
-		  ;; configurations, code can go into dynamic space.
-		  #!+(and x86 cgc) *static* ; KLUDGE: Why? -- WHN 19990907
-		  #!-(and x86 cgc) *dynamic*
-		  (+ (ash header-n-words sb!vm:word-shift) code-size)
-		  sb!vm:other-pointer-type)))
+	    (des (allocate-cold-descriptor *dynamic*
+					   (+ (ash header-n-words
+						   sb!vm:word-shift)
+					      code-size)
+					   sb!vm:other-pointer-type)))
        (write-memory des
 		     (make-other-immediate-descriptor header-n-words
 						      sb!vm:code-header-type))
@@ -2341,7 +2294,7 @@
 			(ash header-n-words sb!vm:word-shift)))
 	      (end (+ start code-size)))
 	 (read-sequence-or-die (descriptor-bytes des)
-			       *fasl-file*
+			       *fasl-input-stream*
 			       :start start
 			       :end end)
 	 #!+sb-show
@@ -2377,18 +2330,18 @@
 	 (offset (calc-offset code-object (read-arg 4)))
 	 (fn (descriptor-beyond code-object
 				offset
-				sb!vm:function-pointer-type))
+				sb!vm:fun-pointer-type))
 	 (next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
     (unless (zerop (logand offset sb!vm:lowtag-mask))
       ;; FIXME: This should probably become a fatal error.
       (warn "unaligned function entry: ~S at #X~X" name offset))
     (write-wordindexed code-object sb!vm:code-entry-points-slot fn)
     (write-memory fn
-		  (make-other-immediate-descriptor (ash offset
-							(- sb!vm:word-shift))
-						   sb!vm:function-header-type))
+		  (make-other-immediate-descriptor
+		   (ash offset (- sb!vm:word-shift))
+		   sb!vm:simple-fun-header-type))
     (write-wordindexed fn
-		       sb!vm:function-self-slot
+		       sb!vm:simple-fun-self-slot
 		       ;; KLUDGE: Wiring decisions like this in at
 		       ;; this level ("if it's an x86") instead of a
 		       ;; higher level of abstraction ("if it has such
@@ -2419,15 +2372,16 @@
 		       ;; -- WHN 19990907
 		       (make-random-descriptor
 			(+ (descriptor-bits fn)
-			   (- (ash sb!vm:function-code-offset sb!vm:word-shift)
+			   (- (ash sb!vm:simple-fun-code-offset
+				   sb!vm:word-shift)
 			      ;; FIXME: We should mask out the type
 			      ;; bits, not assume we know what they
 			      ;; are and subtract them out this way.
-			      sb!vm:function-pointer-type))))
-    (write-wordindexed fn sb!vm:function-next-slot next)
-    (write-wordindexed fn sb!vm:function-name-slot name)
-    (write-wordindexed fn sb!vm:function-arglist-slot arglist)
-    (write-wordindexed fn sb!vm:function-type-slot type)
+			      sb!vm:fun-pointer-type))))
+    (write-wordindexed fn sb!vm:simple-fun-next-slot next)
+    (write-wordindexed fn sb!vm:simple-fun-name-slot name)
+    (write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist)
+    (write-wordindexed fn sb!vm:simple-fun-type-slot type)
     fn))
 
 (define-cold-fop (fop-foreign-fixup)
@@ -2435,9 +2389,9 @@
 	 (code-object (pop-stack))
 	 (len (read-arg 1))
 	 (sym (make-string len)))
-    (read-string-as-bytes *fasl-file* sym)
+    (read-string-as-bytes *fasl-input-stream* sym)
     (let ((offset (read-arg 4))
-	  (value (lookup-foreign-symbol sym)))
+	  (value (cold-foreign-symbol-address-as-integer sym)))
       (do-cold-fixup code-object offset value kind))
     code-object))
 
@@ -2447,10 +2401,11 @@
 	  ;; Note: we round the number of constants up to ensure that
 	  ;; the code vector will be properly aligned.
 	  (round-up sb!vm:code-constants-offset 2))
-	 (des (allocate-descriptor *read-only*
-				   (+ (ash header-n-words sb!vm:word-shift)
-				      length)
-				   sb!vm:other-pointer-type)))
+	 (des (allocate-cold-descriptor *read-only*
+					(+ (ash header-n-words
+						sb!vm:word-shift)
+					   length)
+					sb!vm:other-pointer-type)))
     (write-memory des
 		  (make-other-immediate-descriptor header-n-words
 						   sb!vm:code-header-type))
@@ -2466,7 +2421,7 @@
 		     (ash header-n-words sb!vm:word-shift)))
 	   (end (+ start length)))
       (read-sequence-or-die (descriptor-bytes des)
-			    *fasl-file*
+			    *fasl-input-stream*
 			    :start start
 			    :end end))
     des))
@@ -2511,7 +2466,7 @@
   ;; writing beginning boilerplate
   (format t "/*~%")
   (dolist (line
-	   '("This is a machine-generated file. Do not edit it by hand."
+	   '("This is a machine-generated file. Please do not edit it by hand."
 	     ""
 	     "This file contains low-level information about the"
 	     "internals of a particular version and configuration"
@@ -2526,6 +2481,15 @@
   (format t "#ifndef _SBCL_H_~%#define _SBCL_H_~%")
   (terpri)
 
+  ;; propagating *SHEBANG-FEATURES* into C-level #define's
+  (dolist (shebang-feature-name (sort (mapcar #'symbol-name
+					      sb-cold:*shebang-features*)
+				      #'string<))
+    (format t
+	    "#define LISP_FEATURE_~A~%"
+	    (substitute #\_ #\- shebang-feature-name)))
+  (terpri)
+
   ;; writing miscellaneous constants
   (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
   (format t
@@ -2637,7 +2601,7 @@
 
   ;; writing codes/strings for internal errors
   (format t "#define ERRORS { \\~%")
-  ;; FIXME: Is this just DO-VECTOR?
+  ;; FIXME: Is this just DOVECTOR?
   (let ((internal-errors sb!c:*backend-internal-errors*))
     (dotimes (i (length internal-errors))
       (format t "    ~S, /*~D*/ \\~%" (cdr (aref internal-errors i)) i)))
@@ -2717,17 +2681,18 @@
 	  (undefs nil))
       (maphash #'(lambda (name fdefn)
 		   (let ((fun (read-wordindexed fdefn
-						sb!vm:fdefn-function-slot)))
+						sb!vm:fdefn-fun-slot)))
 		     (if (= (descriptor-bits fun)
 			    (descriptor-bits *nil-descriptor*))
 			 (push name undefs)
-			 (let ((addr (read-wordindexed fdefn
-						       sb!vm:fdefn-raw-addr-slot)))
+			 (let ((addr (read-wordindexed
+				      fdefn sb!vm:fdefn-raw-addr-slot)))
 			   (push (cons name (descriptor-bits addr))
 				 funs)))))
 	       *cold-fdefn-objects*)
       (format t "~%~|~%initially defined functions:~2%")
-      (dolist (info (sort funs #'< :key #'cdr))
+      (setf funs (sort funs #'< :key #'cdr))
+      (dolist (info funs)
 	(format t "0x~8,'0X: ~S   #X~8,'0X~%" (cdr info) (car info)
 		(- (cdr info) #x17)))
       (format t
@@ -2742,33 +2707,30 @@ cross-compiler knew their inline definition and used that everywhere
 that they were called before the out-of-line definition is installed,
 as is fairly common for structure accessors.)
 initially undefined function references:~2%")
-      (labels ((key (name)
-		 (etypecase name
-		   (symbol (symbol-name name))
-		   ;; FIXME: should use standard SETF-function parsing logic
-		   (list (key (second name))))))
-	(dolist (name (sort undefs #'string< :key #'key))
-	  (format t "~S" name)
-	  ;; FIXME: This ACCESSOR-FOR stuff should go away when the
-	  ;; code has stabilized. (It's only here to help me
-	  ;; categorize the flood of undefined functions caused by
-	  ;; completely rewriting the bootstrap process. Hopefully any
-	  ;; future maintainers will mostly have small numbers of
-	  ;; undefined functions..)
-	  (let ((accessor-for (info :function :accessor-for name)))
-	    (when accessor-for
-	      (format t " (accessor for ~S)" accessor-for)))
-	  (format t "~%")))))
-
-  (format t "~%~|~%layout names:~2%")
-  (collect ((stuff))
-    (maphash #'(lambda (name gorp)
-		 (declare (ignore name))
-		 (stuff (cons (descriptor-bits (car gorp))
-			      (cdr gorp))))
-	     *cold-layouts*)
-    (dolist (x (sort (stuff) #'< :key #'car))
-      (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x)))
+
+      (setf undefs (sort undefs #'string< :key #'function-name-block-name))
+      (dolist (name undefs)
+        (format t "~S" name)
+	;; FIXME: This ACCESSOR-FOR stuff should go away when the
+	;; code has stabilized. (It's only here to help me
+	;; categorize the flood of undefined functions caused by
+	;; completely rewriting the bootstrap process. Hopefully any
+	;; future maintainers will mostly have small numbers of
+	;; undefined functions..)
+	(let ((accessor-for (info :function :accessor-for name)))
+	  (when accessor-for
+	    (format t " (accessor for ~S)" accessor-for)))
+	(format t "~%")))
+
+    (format t "~%~|~%layout names:~2%")
+    (collect ((stuff))
+      (maphash #'(lambda (name gorp)
+                   (declare (ignore name))
+                   (stuff (cons (descriptor-bits (car gorp))
+                                (cdr gorp))))
+               *cold-layouts*)
+      (dolist (x (sort (stuff) #'< :key #'car))
+        (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x))))
 
   (values))
 
@@ -2841,11 +2803,7 @@ initially undefined function references:~2%")
     (write-long *data-page*)
     (multiple-value-bind (floor rem)
 	(floor (gspace-byte-address gspace) sb!c:*backend-page-size*)
-      ;; FIXME: Define an INSIST macro which does like ASSERT, but
-      ;; less expensively (ERROR, not CERROR), and which reports
-      ;; "internal error" on failure. Use it here and elsewhere in the
-      ;; system.
-      (assert (zerop rem))
+      (aver (zerop rem))
       (write-long floor))
     (write-long pages)
 
@@ -2893,7 +2851,7 @@ initially undefined function references:~2%")
       (let* ((cold-name (cold-intern '!cold-init))
 	     (cold-fdefn (cold-fdefinition-object cold-name))
 	     (initial-function (read-wordindexed cold-fdefn
-						 sb!vm:fdefn-function-slot)))
+						 sb!vm:fdefn-fun-slot)))
 	(format t
 		"~&/(DESCRIPTOR-BITS INITIAL-FUNCTION)=#X~X~%"
 		(descriptor-bits initial-function))
@@ -2967,7 +2925,7 @@ initially undefined function references:~2%")
 
     ;; Read symbol table, if any.
     (when symbol-table-file-name
-      (load-foreign-symbol-table symbol-table-file-name))
+      (load-cold-foreign-symbol-table symbol-table-file-name))
 
     ;; Now that we've successfully read our only input file (by
     ;; loading the symbol table, if any), it's a good time to ensure
@@ -3038,7 +2996,7 @@ initially undefined function references:~2%")
       ;; much. (And the old CMU CL code is still useful for making
       ;; sure that the appropriate keywords and internal symbols end
       ;; up interned in the target Lisp, which is good, e.g. in order
-      ;; to make keyword arguments work right and in order to make
+      ;; to make &KEY arguments work right and in order to make
       ;; BACKTRACEs into target Lisp system code be legible.)
       (dolist (exported-name
 	       (sb-cold:read-from-file "common-lisp-exports.lisp-expr"))
@@ -3084,11 +3042,17 @@ initially undefined function references:~2%")
 
       ;; Tell the target Lisp how much stuff we've allocated.
       (cold-set 'sb!vm:*read-only-space-free-pointer*
-		(allocate-descriptor *read-only* 0 sb!vm:even-fixnum-type))
+		(allocate-cold-descriptor *read-only*
+					  0
+					  sb!vm:even-fixnum-type))
       (cold-set 'sb!vm:*static-space-free-pointer*
-		(allocate-descriptor *static* 0 sb!vm:even-fixnum-type))
+		(allocate-cold-descriptor *static*
+					  0
+					  sb!vm:even-fixnum-type))
       (cold-set 'sb!vm:*initial-dynamic-space-free-pointer*
-		(allocate-descriptor *dynamic* 0 sb!vm:even-fixnum-type))
+		(allocate-cold-descriptor *dynamic*
+					  0
+					  sb!vm:even-fixnum-type))
       (/show "done setting free pointers")
 
       ;; Write results to files.