X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=228dad2fb6cada25fffbfd2191a9da486765f3ce;hb=6fb6e66f531dfb6140ec3e0cc8f84f6ecd1927ca;hp=241717de50eefacd23194e44cf91bdc3bc6d8275;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 241717d..228dad2 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)
 
@@ -136,19 +139,21 @@
   (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)
-      (cond ((or (= lowtag sb!vm:even-fixnum-type)
-		 (= lowtag sb!vm:odd-fixnum-type))
+      (cond ((or (= lowtag sb!vm:even-fixnum-lowtag)
+		 (= lowtag sb!vm:odd-fixnum-lowtag))
 	     (let ((unsigned (logior (ash (descriptor-high des)
 					  (1+ (- descriptor-low-bits
 						 sb!vm:lowtag-bits)))
@@ -159,8 +164,8 @@
 		       (if (> unsigned #x1FFFFFFF)
 			   (- unsigned #x40000000)
 			   unsigned))))
-	    ((or (= lowtag sb!vm:other-immediate-0-type)
-		 (= lowtag sb!vm:other-immediate-1-type))
+	    ((or (= lowtag sb!vm:other-immediate-0-lowtag)
+		 (= lowtag sb!vm:other-immediate-1-lowtag))
 	     (format stream
 		     "for other immediate: #X~X, type #b~8,'0B"
 		     (ash (descriptor-bits des) (- sb!vm:type-bits))
@@ -176,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
@@ -246,14 +251,14 @@
     (let ((lowtag (descriptor-lowtag des))
 	  (high (descriptor-high des))
 	  (low (descriptor-low des)))
-      (if (or (eql lowtag sb!vm:function-pointer-type)
-	      (eql lowtag sb!vm:instance-pointer-type)
-	      (eql lowtag sb!vm:list-pointer-type)
-	      (eql lowtag sb!vm:other-pointer-type))
+      (if (or (eql lowtag sb!vm:fun-pointer-lowtag)
+	      (eql lowtag sb!vm:instance-pointer-lowtag)
+	      (eql lowtag sb!vm:list-pointer-lowtag)
+	      (eql lowtag sb!vm:other-pointer-lowtag))
 	(dolist (gspace (list *dynamic* *static* *read-only*)
 			(error "couldn't find a GSPACE for ~S" des))
-	  ;; This code relies on the fact that GSPACEs are aligned such that
-	  ;; the descriptor-low-bits low bits are zero.
+	  ;; This code relies on the fact that GSPACEs are aligned
+	  ;; such that the descriptor-low-bits low bits are zero.
 	  (when (and (>= high (ash (gspace-word-address gspace)
 				   (- sb!vm:word-shift descriptor-low-bits)))
 		     (<= high (ash (+ (gspace-word-address gspace)
@@ -509,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-lowtag)))
     (write-memory des
 		  (make-other-immediate-descriptor (ash bytes
 							(- sb!vm:word-shift))
@@ -532,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-lowtag)))
     (write-memory des (make-other-immediate-descriptor 0 type))
     (write-wordindexed des
 		       sb!vm:vector-length-slot
@@ -719,7 +725,7 @@
 
 ;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
 (defun cold-cons (car cdr &optional (gspace *dynamic*))
-  (let ((dest (allocate-boxed-object gspace 2 sb!vm:list-pointer-type)))
+  (let ((dest (allocate-boxed-object gspace 2 sb!vm:list-pointer-lowtag)))
     (write-memory dest car)
     (write-wordindexed dest 1 cdr)
     dest))
@@ -824,7 +830,7 @@
   (let ((result (allocate-boxed-object *dynamic*
 				       ;; KLUDGE: Why 1+? -- WHN 19990901
 				       (1+ target-layout-length)
-				       sb!vm:instance-pointer-type)))
+				       sb!vm:instance-pointer-lowtag)))
     (write-memory result
 		  (make-other-immediate-descriptor target-layout-length
 						   sb!vm:instance-header-type))
@@ -1020,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)
@@ -1056,8 +1062,8 @@
 	 (result (make-descriptor (descriptor-high des)
 				  (+ (descriptor-low des)
 				     (* 2 sb!vm:word-bytes)
-				     (- sb!vm:list-pointer-type
-					sb!vm:other-pointer-type)))))
+				     (- sb!vm:list-pointer-lowtag
+					sb!vm:other-pointer-lowtag)))))
     (write-wordindexed des
 		       1
 		       (make-other-immediate-descriptor
@@ -1133,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))
@@ -1152,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*))
@@ -1242,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.
@@ -1295,79 +1295,110 @@
     (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-lowtag))
+  (read-wordindexed des sb!vm:cons-car-slot))
+(defun cold-cdr (des)
+  (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
+  (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-lowtag
+	    (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-lowtag
+	    (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)
-					    sb!vm:other-pointer-type)))
+					    sb!vm:other-pointer-lowtag)))
 
 	  (setf (gethash warm-name *cold-fdefn-objects*) fdefn)
 	  (write-memory fdefn (make-other-immediate-descriptor
 			       (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 ()
@@ -1375,7 +1406,7 @@
     (dolist (sym sb!vm:*static-functions*)
       (let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
 	     (offset (- (+ (- (descriptor-low fdefn)
-			      sb!vm:other-pointer-type)
+			      sb!vm:other-pointer-lowtag)
 			   (* sb!vm:fdefn-raw-addr-slot sb!vm:word-bytes))
 			(descriptor-low *nil-descriptor*)))
 	     (desired (sb!vm:static-function-offset sym)))
@@ -1398,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)))
@@ -1446,40 +1479,15 @@
 		(setf (gethash name *cold-foreign-symbol-table*) value))))))
     (values)))
 
-;;; FIXME: the relation between #'lookup-foreign-symbol and
-;;; #'lookup-maybe-prefix-foreign-symbol seems more than slightly
-;;; illdefined
-
-(defun lookup-foreign-symbol (name)
-  #!+(or alpha 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))))
-  #!-(or x86 alpha) (error "non-x86/alpha 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*)
 
@@ -1565,10 +1573,10 @@
 				offset-within-code-object))
 	 (gspace-byte-address (gspace-byte-address
 			       (descriptor-gspace code-object))))
-    (ecase sb!c:*backend-fasl-file-implementation*
-      ;; See CMUCL source for other formerly-supported architectures
-      ;; (and note that you have to rewrite them to use vector-ref unstead
-      ;; of sap-ref)
+    (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
          (:jmp-hint
@@ -1654,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*))
@@ -1671,9 +1683,12 @@
 
 ;;;; 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*)
 
@@ -1750,7 +1765,7 @@
   (let* ((size (clone-arg))
 	 (result (allocate-boxed-object *dynamic*
 					(1+ size)
-					sb!vm:instance-pointer-type)))
+					sb!vm:instance-pointer-lowtag)))
     (write-memory result (make-other-immediate-descriptor
 			  size
 			  sb!vm:instance-header-type))
@@ -1817,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)
@@ -1847,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
 
@@ -1904,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)
@@ -1940,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))
@@ -1955,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))
@@ -1971,7 +1986,7 @@
 	 (data-vector (pop-stack))
 	 (result (allocate-boxed-object *dynamic*
 					(+ sb!vm:array-dimensions-offset rank)
-					sb!vm:other-pointer-type)))
+					sb!vm:other-pointer-lowtag)))
     (write-memory result
 		  (make-other-immediate-descriptor rank
 						   sb!vm:simple-array-type))
@@ -1982,8 +1997,8 @@
     (let ((total-elements 1))
       (dotimes (axis rank)
 	(let ((dim (pop-stack)))
-	  (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-type)
-		      (= (descriptor-lowtag dim) sb!vm:odd-fixnum-type))
+	  (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-lowtag)
+		      (= (descriptor-lowtag dim) sb!vm:odd-fixnum-lowtag))
 	    (error "non-fixnum dimension? (~S)" dim))
 	  (setf total-elements
 		(* total-elements
@@ -2023,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))
@@ -2041,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))
@@ -2058,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))
@@ -2093,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))
@@ -2163,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*
@@ -2193,8 +2208,8 @@
     (write-wordindexed obj
 		   (+ idx
 		      (ecase (descriptor-lowtag obj)
-			(#.sb!vm:instance-pointer-type 1)
-			(#.sb!vm:other-pointer-type 2)))
+			(#.sb!vm:instance-pointer-lowtag 1)
+			(#.sb!vm:other-pointer-lowtag 2)))
 		   (pop-stack))))
 
 (define-cold-fop (fop-structset nil)
@@ -2212,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)))
@@ -2223,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)
@@ -2243,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-lowtag)))
        (write-memory des
 		     (make-other-immediate-descriptor header-n-words
 						      sb!vm:code-header-type))
@@ -2272,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
@@ -2308,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-lowtag))
 	 (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
@@ -2350,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-lowtag))))
+    (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)
@@ -2366,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))
 
@@ -2378,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-lowtag)))
     (write-memory des
 		  (make-other-immediate-descriptor header-n-words
 						   sb!vm:code-header-type))
@@ -2397,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))
@@ -2429,20 +2453,16 @@
 
 ;;;; emitting C header file
 
-(defun tail-comp (string tail)
+(defun tailwise-equal (string tail)
   (and (>= (length string) (length tail))
        (string= string tail :start1 (- (length string) (length tail)))))
 
-(defun head-comp (string head)
-  (and (>= (length string) (length head))
-       (string= string head :end1 (length head))))
-
 (defun write-c-header ()
 
   ;; 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"
@@ -2457,6 +2477,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
@@ -2488,42 +2517,40 @@
 				 (symbol-value symbol)
 				 (documentation symbol 'variable))
 			   constants))
-		   ;; machinery for old-style CMU CL Lisp-to-C naming
+		   ;; machinery for old-style CMU CL Lisp-to-C
+		   ;; arbitrary renaming, being phased out in favor of
+		   ;; the newer systematic RECORD-WITH-TRANSLATED-NAME
+		   ;; renaming
 		   (record-with-munged-name (prefix string priority)
 		     (record (concatenate
 			      'simple-string
 			      prefix
 			      (delete #\- (string-capitalize string)))
 			     priority))
-		   (test-tail (tail prefix priority)
-		     (when (tail-comp name tail)
+		   (maybe-record-with-munged-name (tail prefix priority)
+		     (when (tailwise-equal name tail)
 		       (record-with-munged-name prefix
 						(subseq name 0
 							(- (length name)
 							   (length tail)))
 						priority)))
-		   (test-head (head prefix priority)
-		     (when (head-comp name head)
-		       (record-with-munged-name prefix
-						(subseq name (length head))
-						priority)))
 		   ;; machinery for new-style SBCL Lisp-to-C naming
 		   (record-with-translated-name (priority)
 		     (record (substitute #\_ #\- name)
-			     priority)))
-	    ;; This style of munging of names is used in the code
-	    ;; inherited from CMU CL.
-	    (test-tail "-TYPE" "type_" 0)
-	    (test-tail "-FLAG" "flag_" 1)
-	    (test-tail "-TRAP" "trap_" 2)
-	    (test-tail "-SUBTYPE" "subtype_" 3)
-	    (test-head "TRACE-TABLE-" "tracetab_" 4)
-	    (test-tail "-SC-NUMBER" "sc_" 5)
-	    ;; This simpler style of translation of names seems less
-	    ;; confusing, and is used for newer code.
-	    (when (some (lambda (suffix) (tail-comp name suffix))
-			#("-START" "-END"))
-	      (record-with-translated-name 6))))))
+			     priority))
+		   (maybe-record-with-translated-name (suffixes priority)
+                     (when (some (lambda (suffix)
+				   (tailwise-equal name suffix))
+				 suffixes)
+		       (record-with-translated-name priority))))
+
+	    (maybe-record-with-translated-name '("-LOWTAG") 0)
+	    (maybe-record-with-munged-name "-TYPE" "type_" 1)
+	    (maybe-record-with-munged-name "-FLAG" "flag_" 2)
+	    (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)))))
     (setf constants
 	  (sort constants
 		#'(lambda (const1 const2)
@@ -2568,7 +2595,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)))
@@ -2625,7 +2652,7 @@
 	      ;; We didn't run GENESIS, so guess at the address.
 	      (+ sb!vm:static-space-start
 		 sb!vm:word-bytes
-		 sb!vm:other-pointer-type
+		 sb!vm:other-pointer-lowtag
 		 (if symbol (sb!vm:static-symbol-offset symbol) 0)))))
 
   ;; Voila.
@@ -2648,17 +2675,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
@@ -2673,33 +2701,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))
 
@@ -2772,10 +2797,6 @@ 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.
       (aver (zerop rem))
       (write-long floor))
     (write-long pages)
@@ -2824,7 +2845,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))
@@ -2898,7 +2919,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
@@ -3015,11 +3036,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-lowtag))
       (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-lowtag))
       (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-lowtag))
       (/show "done setting free pointers")
 
       ;; Write results to files.