Enable dumping huge (> 64k) pages in genesis

[sbcl.git] / src / compiler / generic / genesis.lisp

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index fc8fed2..93ebd3c 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -60,7 +60,8 @@
 ;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support,
 ;;;    deleted a slot from DEBUG-SOURCE structure
 ;;; 3: added build ID to cores to discourage sbcl/.core mismatch
 ;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support,
 ;;;    deleted a slot from DEBUG-SOURCE structure
 ;;; 3: added build ID to cores to discourage sbcl/.core mismatch

-(defconstant sbcl-core-version-integer 3)
+;;; 4: added gc page table data
+(defconstant sbcl-core-version-integer 4)

 
 (defun round-up (number size)
   #!+sb-doc
 
 (defun round-up (number size)
   #!+sb-doc

@@ -85,7 +86,8 @@
   `(simple-array (unsigned-byte 8) (,+smallvec-length+)))
 
 (defun make-smallvec ()
   `(simple-array (unsigned-byte 8) (,+smallvec-length+)))
 
 (defun make-smallvec ()

-  (make-array +smallvec-length+ :element-type '(unsigned-byte 8)))
+  (make-array +smallvec-length+ :element-type '(unsigned-byte 8)
+              :initial-element 0))

 
 ;;; a big vector, implemented as a vector of SMALLVECs
 ;;;
 
 ;;; a big vector, implemented as a vector of SMALLVECs
 ;;;

@@ -128,10 +130,14 @@
      +smallvec-length+))
 
 ;;; analogous to WRITE-SEQUENCE, but for a BIGVEC
      +smallvec-length+))
 
 ;;; analogous to WRITE-SEQUENCE, but for a BIGVEC

-(defun write-bigvec-as-sequence (bigvec stream &key (start 0) end)
-  (loop for i of-type index from start below (or end (bvlength bigvec)) do
-        (write-byte (bvref bigvec i)
-                    stream)))
+(defun write-bigvec-as-sequence (bigvec stream &key (start 0) end pad-with-zeros)
+  (let* ((bvlength (bvlength bigvec))
+         (data-length (min (or end bvlength) bvlength)))
+    (loop for i of-type index from start below data-length do
+      (write-byte (bvref bigvec i)
+                  stream))
+    (when (and pad-with-zeros (< bvlength data-length))
+      (loop repeat (- data-length bvlength) do (write-byte 0 stream)))))

 
 ;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC
 (defun read-bigvec-as-sequence-or-die (bigvec stream &key (start 0) end)
 
 ;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC
 (defun read-bigvec-as-sequence-or-die (bigvec stream &key (start 0) end)

@@ -229,6 +235,9 @@
 (defvar *read-only*)
 (defconstant read-only-core-space-id 3)
 
 (defvar *read-only*)
 (defconstant read-only-core-space-id 3)
 

+(defconstant max-core-space-id 3)
+(defconstant deflated-core-space-id-flag 4)
+

 (defconstant descriptor-low-bits 16
   "the number of bits in the low half of the descriptor")
 (defconstant target-space-alignment (ash 1 descriptor-low-bits)
 (defconstant descriptor-low-bits 16
   "the number of bits in the low half of the descriptor")
 (defconstant target-space-alignment (ash 1 descriptor-low-bits)

@@ -274,12 +283,22 @@
 \f
 ;;;; representation of descriptors
 
 \f
 ;;;; representation of descriptors
 

+(defun is-fixnum-lowtag (lowtag)
+  (zerop (logand lowtag sb!vm:fixnum-tag-mask)))
+
+(defun is-other-immediate-lowtag (lowtag)
+  ;; The other-immediate lowtags are similar to the fixnum lowtags, in
+  ;; that they have an "effective length" that is shorter than is used
+  ;; for the pointer lowtags.  Unlike the fixnum lowtags, however, the
+  ;; other-immediate lowtags are always effectively two bits wide.
+  (= (logand lowtag 3) sb!vm:other-immediate-0-lowtag))
+

 (defstruct (descriptor
             (:constructor make-descriptor
                           (high low &optional gspace word-offset))
             (:copier nil))
   ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
 (defstruct (descriptor
             (:constructor make-descriptor
                           (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))
+  (gspace nil :type (or gspace (eql :load-time-value) null))

   ;; the offset in words from the start of GSPACE, or NIL if not set yet
   (word-offset nil :type (or sb!vm:word null))
   ;; the high and low halves of the descriptor
   ;; the offset in words from the start of GSPACE, or NIL if not set yet
   (word-offset nil :type (or sb!vm:word null))
   ;; the high and low halves of the descriptor

@@ -295,8 +314,7 @@
 (def!method print-object ((des descriptor) stream)
   (let ((lowtag (descriptor-lowtag des)))
     (print-unreadable-object (des stream :type t)
 (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-lowtag)
-                 (= lowtag sb!vm:odd-fixnum-lowtag))
+      (cond ((is-fixnum-lowtag lowtag)

              (let ((unsigned (logior (ash (descriptor-high des)
                                           (1+ (- descriptor-low-bits
                                                  sb!vm:n-lowtag-bits)))
              (let ((unsigned (logior (ash (descriptor-high des)
                                           (1+ (- descriptor-low-bits
                                                  sb!vm:n-lowtag-bits)))

@@ -307,12 +325,7 @@
                        (if (> unsigned #x1FFFFFFF)
                            (- unsigned #x40000000)
                            unsigned))))
                        (if (> unsigned #x1FFFFFFF)
                            (- unsigned #x40000000)
                            unsigned))))

-            ((or (= lowtag sb!vm:other-immediate-0-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))
+            ((is-other-immediate-lowtag lowtag)

              (format stream
                      "for other immediate: #X~X, type #b~8,'0B"
                      (ash (descriptor-bits des) (- sb!vm:n-widetag-bits))
              (format stream
                      "for other immediate: #X~X, type #b~8,'0B"
                      (ash (descriptor-bits des) (- sb!vm:n-widetag-bits))

@@ -374,16 +387,15 @@
         ;; 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
         ;; 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))
+        (logior (ash bits (- sb!vm:n-fixnum-tag-bits))

                 (ash -1 (1+ sb!vm:n-positive-fixnum-bits)))
                 (ash -1 (1+ sb!vm:n-positive-fixnum-bits)))

-        (ash bits (- 1 sb!vm:n-lowtag-bits)))))
+        (ash bits (- sb!vm:n-fixnum-tag-bits)))))

 
 (defun descriptor-word-sized-integer (des)
   ;; Extract an (unsigned-byte 32), from either its fixnum or bignum
   ;; representation.
   (let ((lowtag (descriptor-lowtag des)))
 
 (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))
+    (if (is-fixnum-lowtag lowtag)

         (make-random-descriptor (descriptor-fixnum des))
         (read-wordindexed des 1))))
 
         (make-random-descriptor (descriptor-fixnum des))
         (read-wordindexed des 1))))
 

@@ -399,21 +411,31 @@
 ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
 (declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace))
 (defun descriptor-intuit-gspace (des)
 ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
 (declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace))
 (defun descriptor-intuit-gspace (des)

-  (if (descriptor-gspace des)
-    (descriptor-gspace des)
-    ;; KLUDGE: It's not completely clear to me what's going on here;
-    ;; this is a literal translation from of some rather mysterious
-    ;; code from CMU CL's DESCRIPTOR-SAP function. Some explanation
-    ;; would be nice. -- WHN 19990817
-    (let ((lowtag (descriptor-lowtag des))
-          (high (descriptor-high des))
-          (low (descriptor-low des)))
-      (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))
+  (or (descriptor-gspace des)
+
+      ;; gspace wasn't set, now we have to search for it.
+      (let ((lowtag (descriptor-lowtag des))
+            (high (descriptor-high des))
+            (low (descriptor-low des)))
+
+        ;; Non-pointer objects don't have a gspace.
+        (unless (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))
+          (error "don't even know how to look for a GSPACE for ~S" des))
+

         (dolist (gspace (list *dynamic* *static* *read-only*)
         (dolist (gspace (list *dynamic* *static* *read-only*)

-                        (error "couldn't find a GSPACE for ~S" des))
+                 (error "couldn't find a GSPACE for ~S" des))
+          ;; Bounds-check the descriptor against the allocated area
+          ;; within each gspace.
+          ;;
+          ;; Most of the faffing around in here involving ash and
+          ;; various computed shift counts is due to the high/low
+          ;; split representation of the descriptor bits and an
+          ;; apparent disinclination to create intermediate values
+          ;; larger than a target fixnum.
+          ;;

           ;; 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)
           ;; 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)

@@ -421,6 +443,8 @@
                      (<= high (ash (+ (gspace-word-address gspace)
                                       (gspace-free-word-index gspace))
                                    (- sb!vm:word-shift descriptor-low-bits))))
                      (<= high (ash (+ (gspace-word-address gspace)
                                       (gspace-free-word-index gspace))
                                    (- sb!vm:word-shift descriptor-low-bits))))

+            ;; Update the descriptor with the correct gspace and the
+            ;; offset within the gspace and return the gspace.

             (setf (descriptor-gspace des) gspace)
             (setf (descriptor-word-offset des)
                   (+ (ash (- high (ash (gspace-word-address gspace)
             (setf (descriptor-gspace des) gspace)
             (setf (descriptor-word-offset des)
                   (+ (ash (- high (ash (gspace-word-address gspace)

@@ -429,8 +453,7 @@
                           (- descriptor-low-bits sb!vm:word-shift))
                      (ash (logandc2 low sb!vm:lowtag-mask)
                           (- sb!vm:word-shift))))
                           (- descriptor-low-bits sb!vm:word-shift))
                      (ash (logandc2 low sb!vm:lowtag-mask)
                           (- sb!vm:word-shift))))

-            (return gspace)))
-        (error "don't even know how to look for a GSPACE for ~S" des)))))
+            (return gspace))))))

 
 (defun make-random-descriptor (value)
   (make-descriptor (logand (ash value (- descriptor-low-bits))
 
 (defun make-random-descriptor (value)
   (make-descriptor (logand (ash value (- descriptor-low-bits))

@@ -441,9 +464,9 @@
 
 (defun make-fixnum-descriptor (num)
   (when (>= (integer-length num)
 
 (defun make-fixnum-descriptor (num)
   (when (>= (integer-length num)

-            (1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits)))
+            (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))

     (error "~W is too big for a fixnum." num))
     (error "~W is too big for a fixnum." num))

-  (make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits))))
+  (make-random-descriptor (ash num sb!vm:n-fixnum-tag-bits)))

 
 (defun make-other-immediate-descriptor (data type)
   (make-descriptor (ash data (- sb!vm:n-widetag-bits descriptor-low-bits))
 
 (defun make-other-immediate-descriptor (data type)
   (make-descriptor (ash data (- sb!vm:n-widetag-bits descriptor-low-bits))

@@ -497,6 +520,13 @@
 ;;; purposes.
 (defvar *current-reversed-cold-toplevels*)
 
 ;;; purposes.
 (defvar *current-reversed-cold-toplevels*)
 

+;;; the head of a list of DEBUG-SOURCEs which need to be patched when
+;;; the cold core starts up
+(defvar *current-debug-sources*)
+
+;;; foreign symbol references
+(defparameter *cold-foreign-undefined-symbols* nil)
+

 ;;; the name of the object file currently being cold loaded (as a string, not a
 ;;; pathname), or NIL if we're not currently cold loading any object file
 (defvar *cold-load-filename* nil)
 ;;; the name of the object file currently being cold loaded (as a string, not a
 ;;; pathname), or NIL if we're not currently cold loading any object file
 (defvar *cold-load-filename* nil)

@@ -528,35 +558,31 @@
   (read-wordindexed address 0))
 
 ;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS
   (read-wordindexed address 0))
 
 ;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS

-;;; value, instead of the SAP-INT we use here.)
-(declaim (ftype (function (sb!vm:word descriptor) (values))
+;;; value, instead of the object-and-offset we use here.)
+(declaim (ftype (function (descriptor sb!vm:word descriptor) (values))

                 note-load-time-value-reference))
                 note-load-time-value-reference))

-(defun note-load-time-value-reference (address marker)
+(defun note-load-time-value-reference (address offset marker)

   (cold-push (cold-cons
               (cold-intern :load-time-value-fixup)
   (cold-push (cold-cons
               (cold-intern :load-time-value-fixup)

-              (cold-cons (sap-int-to-core address)
-                         (cold-cons
-                          (number-to-core (descriptor-word-offset marker))
-                          *nil-descriptor*)))
+              (cold-cons address
+                         (cold-cons (number-to-core offset)
+                                    (cold-cons
+                                     (number-to-core (descriptor-word-offset marker))
+                                     *nil-descriptor*))))

              *current-reversed-cold-toplevels*)
   (values))
 
              *current-reversed-cold-toplevels*)
   (values))
 

-(declaim (ftype (function (descriptor sb!vm:word descriptor)) write-wordindexed))
+(declaim (ftype (function (descriptor sb!vm:word (or descriptor symbol))) write-wordindexed))

 (defun write-wordindexed (address index value)
   #!+sb-doc
   "Write VALUE displaced INDEX words from ADDRESS."
 (defun write-wordindexed (address index value)
   #!+sb-doc
   "Write VALUE displaced INDEX words from ADDRESS."

-  ;; KLUDGE: There is an algorithm (used in DESCRIPTOR-INTUIT-GSPACE)
-  ;; for calculating the value of the GSPACE slot from scratch. It
-  ;; doesn't work for all values, only some of them, but mightn't it
-  ;; be reasonable to see whether it works on VALUE before we give up
-  ;; because (DESCRIPTOR-GSPACE VALUE) isn't set? (Or failing that,
-  ;; perhaps write a comment somewhere explaining why it's not a good
-  ;; idea?) -- WHN 19990817
-  (if (and (null (descriptor-gspace value))
-           (not (null (descriptor-word-offset value))))
-    (note-load-time-value-reference (+ (logandc2 (descriptor-bits address)
-                                                 sb!vm:lowtag-mask)
-                                       (ash index sb!vm:word-shift))
+  ;; If we're passed a symbol as a value then it needs to be interned.
+  (when (symbolp value) (setf value (cold-intern value)))
+  (if (eql (descriptor-gspace value) :load-time-value)
+    (note-load-time-value-reference address
+                                    (- (ash index sb!vm:word-shift)
+                                       (logand (descriptor-bits address)
+                                               sb!vm:lowtag-mask))

                                     value)
     (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
            (byte-index (ash (+ index (descriptor-word-offset address))
                                     value)
     (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
            (byte-index (ash (+ index (descriptor-word-offset address))

@@ -564,7 +590,7 @@
       (setf (bvref-word bytes byte-index)
             (descriptor-bits value)))))
 
       (setf (bvref-word bytes byte-index)
             (descriptor-bits value)))))
 

-(declaim (ftype (function (descriptor descriptor)) write-memory))
+(declaim (ftype (function (descriptor (or descriptor symbol))) write-memory))

 (defun write-memory (address value)
   #!+sb-doc
   "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
 (defun write-memory (address value)
   #!+sb-doc
   "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."

@@ -724,10 +750,17 @@ core and return a descriptor to it."
   (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
                                       (1- sb!vm:complex-single-float-size)
                                       sb!vm:complex-single-float-widetag)))
   (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
                                       (1- sb!vm:complex-single-float-size)
                                       sb!vm:complex-single-float-widetag)))

-    (write-wordindexed des sb!vm:complex-single-float-real-slot
-                   (make-random-descriptor (single-float-bits (realpart num))))
-    (write-wordindexed des sb!vm:complex-single-float-imag-slot
-                   (make-random-descriptor (single-float-bits (imagpart num))))
+    #!-x86-64
+    (progn
+      (write-wordindexed des sb!vm:complex-single-float-real-slot
+                         (make-random-descriptor (single-float-bits (realpart num))))
+      (write-wordindexed des sb!vm:complex-single-float-imag-slot
+                         (make-random-descriptor (single-float-bits (imagpart num)))))
+    #!+x86-64
+    (write-wordindexed des sb!vm:complex-single-float-data-slot
+                       (make-random-descriptor
+                        (logior (ldb (byte 32 0) (single-float-bits (realpart num)))
+                                (ash (single-float-bits (imagpart num)) 32))))

     des))
 
 (defun complex-double-float-to-core (num)
     des))
 
 (defun complex-double-float-to-core (num)

@@ -744,7 +777,7 @@ core and return a descriptor to it."
 (defun number-to-core (number)
   (typecase number
     (integer (if (< (integer-length number)
 (defun number-to-core (number)
   (typecase number
     (integer (if (< (integer-length number)

-                    (- (1+ sb!vm:n-word-bits) sb!vm:n-lowtag-bits))
+                    (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))

                  (make-fixnum-descriptor number)
                  (bignum-to-core number)))
     (ratio (number-pair-to-core (number-to-core (numerator number))
                  (make-fixnum-descriptor number)
                  (bignum-to-core number)))
     (ratio (number-pair-to-core (number-to-core (numerator number))

@@ -792,14 +825,10 @@ core and return a descriptor to it."
 \f
 ;;;; symbol magic
 
 \f
 ;;;; symbol magic
 

-;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL.
-(defvar *cold-symbol-allocation-gspace* nil)
-

 ;;; Allocate (and initialize) a symbol.
 ;;; Allocate (and initialize) a symbol.

-(defun allocate-symbol (name)
+(defun allocate-symbol (name &key (gspace *dynamic*))

   (declare (simple-string name))
   (declare (simple-string name))

-  (let ((symbol (allocate-unboxed-object (or *cold-symbol-allocation-gspace*
-                                             *dynamic*)
+  (let ((symbol (allocate-unboxed-object gspace

                                          sb!vm:n-word-bits
                                          (1- sb!vm:symbol-size)
                                          sb!vm:symbol-header-widetag)))
                                          sb!vm:n-word-bits
                                          (1- sb!vm:symbol-size)
                                          sb!vm:symbol-header-widetag)))

@@ -850,10 +879,27 @@ core and return a descriptor to it."
 ;;; the descriptor for layout's layout (needed when making layouts)
 (defvar *layout-layout*)
 
 ;;; the descriptor for layout's layout (needed when making layouts)
 (defvar *layout-layout*)
 

-;;; 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 17)
+(defconstant target-layout-length
+  (layout-length (find-layout 'layout)))
+
+(defun target-layout-index (slot-name)
+  ;; KLUDGE: this is a little bit sleazy, but the tricky thing is that
+  ;; structure slots don't have a terribly firm idea of their names.
+  ;; At least here if we change LAYOUT's package of definition, we
+  ;; only have to change one thing...
+  (let* ((name (find-symbol (symbol-name slot-name) "SB!KERNEL"))
+         (layout (find-layout 'layout))
+         (dd (layout-info layout))
+         (slots (dd-slots dd))
+         (dsd (find name slots :key #'dsd-name)))
+    (aver dsd)
+    (dsd-index dsd)))
+
+(defun cold-set-layout-slot (cold-layout slot-name value)
+  (write-wordindexed
+   cold-layout
+   (+ sb!vm:instance-slots-offset (target-layout-index slot-name))
+   value))

 
 ;;; Return a list of names created from the cold layout INHERITS data
 ;;; in X.
 
 ;;; Return a list of names created from the cold layout INHERITS data
 ;;; in X.

@@ -877,6 +923,7 @@ core and return a descriptor to it."
 (defun make-cold-layout (name length inherits depthoid nuntagged)
   (let ((result (allocate-boxed-object *dynamic*
                                        ;; KLUDGE: Why 1+? -- WHN 19990901
 (defun make-cold-layout (name length inherits depthoid nuntagged)
   (let ((result (allocate-boxed-object *dynamic*
                                        ;; KLUDGE: Why 1+? -- WHN 19990901

+                                       ;; header word? -- CSR 20051204

                                        (1+ target-layout-length)
                                        sb!vm:instance-pointer-lowtag)))
     (write-memory result
                                        (1+ target-layout-length)
                                        sb!vm:instance-pointer-lowtag)))
     (write-memory result

@@ -890,72 +937,20 @@ core and return a descriptor to it."
     ;; Set slot 0 = the layout of the layout.
     (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*)
 
     ;; Set slot 0 = the layout of the layout.
     (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*)
 

-    ;; Set the immediately following slots = CLOS hash values.
+    ;; Don't set the CLOS hash value: done in cold-init instead.

     ;;
     ;;

-    ;; Note: CMU CL didn't set these in genesis, but instead arranged
-    ;; for them to be set at cold init time. That resulted in slightly
-    ;; kludgy-looking code, but there were at least two things to be
-    ;; said for it:
-    ;;   1. It put the hash values under the control of the target Lisp's
-    ;;      RANDOM function, so that CLOS behavior would be nearly
-    ;;      deterministic (instead of depending on the implementation of
-    ;;      RANDOM in the cross-compilation host, and the state of its
-    ;;      RNG when genesis begins).
-    ;;   2. It automatically ensured that all hash values in the target Lisp
-    ;;      were part of the same sequence, so that we didn't have to worry
-    ;;      about the possibility of the first hash value set in genesis
-    ;;      being precisely equal to the some hash value set in cold init time
-    ;;      (because the target Lisp RNG has advanced to precisely the same
-    ;;      state that the host Lisp RNG was in earlier).
-    ;; Point 1 should not be an issue in practice because of the way we do our
-    ;; build procedure in two steps, so that the SBCL that we end up with has
-    ;; been created by another SBCL (whose RNG is under our control).
-    ;; Point 2 is more of an issue. If ANSI had provided a way to feed
-    ;; entropy into an RNG, we would have no problem: we'd just feed
-    ;; some specialized genesis-time-only pattern into the RNG state
-    ;; before using it. However, they didn't, so we have a slight
-    ;; problem. We address it by generating the hash values using a
-    ;; different algorithm than we use in ordinary operation.
-    (dotimes (i sb!kernel:layout-clos-hash-length)
-      (let (;; The expression here is pretty arbitrary, we just want
-            ;; to make sure that it's not something which is (1)
-            ;; evenly distributed and (2) not foreordained to arise in
-            ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence
-            ;; and show up as the CLOS-HASH value of some other
-            ;; LAYOUT.
-            ;;
-            ;; FIXME: This expression here can generate a zero value,
-            ;; and the CMU CL code goes out of its way to generate
-            ;; strictly positive values (even though the field is
-            ;; declared as an INDEX). Check that it's really OK to
-            ;; have zero values in the CLOS-HASH slots.
-            (hash-value (mod (logxor (logand   (random-layout-clos-hash) 15253)
-                                     (logandc2 (random-layout-clos-hash) 15253)
-                                     1)
-                             ;; (The MOD here is defensive programming
-                             ;; to make sure we never write an
-                             ;; out-of-range value even if some joker
-                             ;; sets LAYOUT-CLOS-HASH-MAX to other
-                             ;; than 2^n-1 at some time in the
-                             ;; future.)
-                             (1+ sb!kernel:layout-clos-hash-max))))
-        (write-wordindexed result
-                           (+ i sb!vm:instance-slots-offset 1)
-                           (make-fixnum-descriptor hash-value))))
-

     ;; Set other slot values.
     ;; Set other slot values.

-    (let ((base (+ sb!vm:instance-slots-offset
-                   sb!kernel:layout-clos-hash-length
-                   1)))
-      ;; (Offset 0 is CLASS, "the class this is a layout for", which
-      ;; is uninitialized at this point.)
-      (write-wordindexed result (+ base 1) *nil-descriptor*) ; marked invalid
-      (write-wordindexed result (+ base 2) inherits)
-      (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 7) nuntagged))
+    ;;
+    ;; leave CLASSOID uninitialized for now
+    (cold-set-layout-slot result 'invalid *nil-descriptor*)
+    (cold-set-layout-slot result 'inherits inherits)
+    (cold-set-layout-slot result 'depthoid depthoid)
+    (cold-set-layout-slot result 'length length)
+    (cold-set-layout-slot result 'info *nil-descriptor*)
+    (cold-set-layout-slot result 'pure *nil-descriptor*)
+    (cold-set-layout-slot result 'n-untagged-slots nuntagged)
+    (cold-set-layout-slot result 'source-location *nil-descriptor*)
+    (cold-set-layout-slot result 'for-std-class-p *nil-descriptor*)

 
     (setf (gethash name *cold-layouts*)
           (list result
 
     (setf (gethash name *cold-layouts*)
           (list result

@@ -975,17 +970,16 @@ core and return a descriptor to it."
   ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and
   ;; #() as INHERITS,
   (setq *layout-layout* *nil-descriptor*)
   ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and
   ;; #() as INHERITS,
   (setq *layout-layout* *nil-descriptor*)

-  (setq *layout-layout*
-        (make-cold-layout 'layout
-                          (number-to-core target-layout-length)
-                          (vector-in-core)
-                          ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT..
-                          (number-to-core 4)
-                          ;; no raw slots in LAYOUT:
-                          (number-to-core 0)))
-  (write-wordindexed *layout-layout*
-                     sb!vm:instance-slots-offset
-                     *layout-layout*)
+  (let ((xlayout-layout (find-layout 'layout)))
+    (aver (= 0 (layout-n-untagged-slots xlayout-layout)))
+    (setq *layout-layout*
+          (make-cold-layout 'layout
+                            (number-to-core target-layout-length)
+                            (vector-in-core)
+                            (number-to-core (layout-depthoid xlayout-layout))
+                            (number-to-core 0)))
+  (write-wordindexed
+   *layout-layout* sb!vm:instance-slots-offset *layout-layout*)

 
   ;; Then we create the layouts that we'll need to make a correct INHERITS
   ;; vector for the layout of LAYOUT itself..
 
   ;; Then we create the layouts that we'll need to make a correct INHERITS
   ;; vector for the layout of LAYOUT itself..

@@ -998,39 +992,26 @@ core and return a descriptor to it."
                             (vector-in-core)
                             (number-to-core 0)
                             (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 0)))

          (so-layout
           (make-cold-layout 'structure-object
                             (number-to-core 1)
          (so-layout
           (make-cold-layout 'structure-object
                             (number-to-core 1)

-                            (vector-in-core t-layout i-layout)
-                            (number-to-core 2)
+                            (vector-in-core t-layout)
+                            (number-to-core 1)

                             (number-to-core 0)))
          (bso-layout
           (make-cold-layout 'structure!object
                             (number-to-core 1)
                             (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)
+                            (vector-in-core t-layout so-layout)
+                            (number-to-core 2)

                             (number-to-core 0)))
          (layout-inherits (vector-in-core t-layout
                             (number-to-core 0)))
          (layout-inherits (vector-in-core t-layout

-                                          i-layout

                                           so-layout
                                           bso-layout)))
 
     ;; ..and return to backpatch the layout of LAYOUT.
     (setf (fourth (gethash 'layout *cold-layouts*))
           (listify-cold-inherits layout-inherits))
                                           so-layout
                                           bso-layout)))
 
     ;; ..and return to backpatch the layout of LAYOUT.
     (setf (fourth (gethash 'layout *cold-layouts*))
           (listify-cold-inherits layout-inherits))

-    (write-wordindexed *layout-layout*
-                       ;; FIXME: hardcoded offset into layout struct
-                       (+ sb!vm:instance-slots-offset
-                          layout-clos-hash-length
-                          1
-                          2)
-                       layout-inherits)))
+    (cold-set-layout-slot *layout-layout* 'inherits layout-inherits))))

 \f
 ;;;; interning symbols in the cold image
 
 \f
 ;;;; interning symbols in the cold image
 

@@ -1118,7 +1099,8 @@ core and return a descriptor to it."
         *cl-package*
         ;; ordinary case
         (let ((result (symbol-package symbol)))
         *cl-package*
         ;; ordinary case
         (let ((result (symbol-package symbol)))

-          (aver (package-ok-for-target-symbol-p result))
+          (unless (package-ok-for-target-symbol-p result)
+            (bug "~A in bad package for target: ~A" symbol result))

           result))))
 
 ;;; Return a handle on an interned symbol. If necessary allocate the
           result))))
 
 ;;; Return a handle on an interned symbol. If necessary allocate the

@@ -1126,8 +1108,9 @@ core and return a descriptor to it."
 ;;; we allocate the symbol, make sure we record a reference to the
 ;;; symbol in the home package so that the package gets set.
 (defun cold-intern (symbol
 ;;; we allocate the symbol, make sure we record a reference to the
 ;;; symbol in the home package so that the package gets set.
 (defun cold-intern (symbol

-                    &optional
-                    (package (symbol-package-for-target-symbol symbol)))
+                    &key
+                    (package (symbol-package-for-target-symbol symbol))
+                    (gspace *dynamic*))

 
   (aver (package-ok-for-target-symbol-p package))
 
 
   (aver (package-ok-for-target-symbol-p package))
 

@@ -1151,7 +1134,7 @@ core and return a descriptor to it."
         (cold-intern-info (get symbol 'cold-intern-info)))
     (unless cold-intern-info
       (cond ((eq (symbol-package-for-target-symbol symbol) package)
         (cold-intern-info (get symbol 'cold-intern-info)))
     (unless cold-intern-info
       (cond ((eq (symbol-package-for-target-symbol symbol) package)

-             (let ((handle (allocate-symbol (symbol-name symbol))))
+             (let ((handle (allocate-symbol (symbol-name symbol) :gspace gspace)))

                (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
                (when (eq package *keyword-package*)
                  (cold-set handle handle))
                (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
                (when (eq package *keyword-package*)
                  (cold-set handle handle))

@@ -1218,34 +1201,48 @@ core and return a descriptor to it."
 (defun initialize-non-nil-symbols ()
   #!+sb-doc
   "Initialize the cold load symbol-hacking data structures."
 (defun initialize-non-nil-symbols ()
   #!+sb-doc
   "Initialize the cold load symbol-hacking data structures."

-  (let ((*cold-symbol-allocation-gspace* *static*))
-    ;; Intern the others.
-    (dolist (symbol sb!vm:*static-symbols*)
-      (let* ((des (cold-intern symbol))
-             (offset-wanted (sb!vm:static-symbol-offset symbol))
-             (offset-found (- (descriptor-low des)
-                              (descriptor-low *nil-descriptor*))))
-        (unless (= offset-wanted offset-found)
-          ;; FIXME: should be fatal
-          (warn "Offset from ~S to ~S is ~W, not ~W"
-                symbol
-                nil
-                offset-found
-                offset-wanted))))
-    ;; Establish the value of T.
-    (let ((t-symbol (cold-intern t)))
-      (cold-set t-symbol t-symbol))))
+  ;; Intern the others.
+  (dolist (symbol sb!vm:*static-symbols*)
+    (let* ((des (cold-intern symbol :gspace *static*))
+           (offset-wanted (sb!vm:static-symbol-offset symbol))
+           (offset-found (- (descriptor-low des)
+                            (descriptor-low *nil-descriptor*))))
+      (unless (= offset-wanted offset-found)
+        ;; FIXME: should be fatal
+        (warn "Offset from ~S to ~S is ~W, not ~W"
+              symbol
+              nil
+              offset-found
+              offset-wanted))))
+  ;; Establish the value of T.
+  (let ((t-symbol (cold-intern t :gspace *static*)))
+    (cold-set t-symbol t-symbol))
+  ;; Establish the value of *PSEUDO-ATOMIC-BITS* so that the
+  ;; allocation sequences that expect it to be zero upon entrance
+  ;; actually find it to be so.
+  #!+(or x86-64 x86)
+  (let ((p-a-a-symbol (cold-intern 'sb!kernel:*pseudo-atomic-bits*
+                                   :gspace *static*)))
+    (cold-set p-a-a-symbol (make-fixnum-descriptor 0))))

 
 ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
 ;;; to be stored in *!INITIAL-LAYOUTS*.
 (defun cold-list-all-layouts ()
 
 ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
 ;;; to be stored in *!INITIAL-LAYOUTS*.
 (defun cold-list-all-layouts ()

-  (let ((result *nil-descriptor*))
+  (let ((layouts nil)
+        (result *nil-descriptor*))

     (maphash (lambda (key stuff)
     (maphash (lambda (key stuff)

-               (cold-push (cold-cons (cold-intern key)
-                                     (first stuff))
-                          result))
+               (push (cons key (first stuff)) layouts))

              *cold-layouts*)
              *cold-layouts*)

-    result))
+    (flet ((sorter (x y)
+             (let ((xpn (package-name (symbol-package-for-target-symbol x)))
+                   (ypn (package-name (symbol-package-for-target-symbol y))))
+               (cond
+                 ((string= x y) (string< xpn ypn))
+                 (t (string< x y))))))
+      (setq layouts (sort layouts #'sorter :key #'car)))
+    (dolist (layout layouts result)
+      (cold-push (cold-cons (cold-intern (car layout)) (cdr layout))
+                 result))))

 
 ;;; Establish initial values for magic symbols.
 ;;;
 
 ;;; Establish initial values for magic symbols.
 ;;;

@@ -1266,17 +1263,8 @@ core and return a descriptor to it."
   ;; the names to highlight that something weird is going on. Perhaps
   ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
   ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...
   ;; the names to highlight that something weird is going on. Perhaps
   ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
   ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...

-  (macrolet ((frob (symbol)
-               `(cold-set ',symbol
-                          (cold-fdefinition-object (cold-intern ',symbol)))))
-    (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))
+  (dolist (symbol sb!vm::*c-callable-static-symbols*)
+    (cold-set symbol (cold-fdefinition-object (cold-intern symbol))))

 
   (cold-set 'sb!vm::*current-catch-block*          (make-fixnum-descriptor 0))
   (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))
 
   (cold-set 'sb!vm::*current-catch-block*          (make-fixnum-descriptor 0))
   (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))

@@ -1291,7 +1279,17 @@ core and return a descriptor to it."
       (let* ((cold-package (car cold-package-symbols-entry))
              (symbols (cdr cold-package-symbols-entry))
              (shadows (package-shadowing-symbols cold-package))
       (let* ((cold-package (car cold-package-symbols-entry))
              (symbols (cdr cold-package-symbols-entry))
              (shadows (package-shadowing-symbols cold-package))

-             (documentation (base-string-to-core (documentation cold-package t)))
+             (documentation (base-string-to-core
+                             ;; KLUDGE: NIL punned as 0-length string.
+                             (unless
+                                 ;; don't propagate the arbitrary
+                                 ;; docstring from host packages into
+                                 ;; the core
+                                 (or (eql cold-package *cl-package*)
+                                     (eql cold-package *keyword-package*))
+                               (documentation cold-package t))))
+             (internal-count 0)
+             (external-count 0)

              (internal *nil-descriptor*)
              (external *nil-descriptor*)
              (imported-internal *nil-descriptor*)
              (internal *nil-descriptor*)
              (external *nil-descriptor*)
              (imported-internal *nil-descriptor*)

@@ -1333,10 +1331,14 @@ core and return a descriptor to it."
               (case where
                 (:internal (if imported-p
                                (cold-push handle imported-internal)
               (case where
                 (:internal (if imported-p
                                (cold-push handle imported-internal)

-                               (cold-push handle internal)))
+                               (progn
+                                 (cold-push handle internal)
+                                 (incf internal-count))))

                 (:external (if imported-p
                                (cold-push handle imported-external)
                 (:external (if imported-p
                                (cold-push handle imported-external)

-                               (cold-push handle external)))))))
+                               (progn
+                                 (cold-push handle external)
+                                 (incf external-count))))))))

         (let ((r *nil-descriptor*))
           (cold-push documentation r)
           (cold-push shadowing r)
         (let ((r *nil-descriptor*))
           (cold-push documentation r)
           (cold-push shadowing r)

@@ -1344,7 +1346,10 @@ core and return a descriptor to it."
           (cold-push imported-internal r)
           (cold-push external r)
           (cold-push internal r)
           (cold-push imported-internal r)
           (cold-push external r)
           (cold-push internal r)

-          (cold-push (make-make-package-args cold-package) r)
+          (cold-push (make-make-package-args cold-package
+                                             internal-count
+                                             external-count)
+                     r)

           ;; FIXME: It would be more space-efficient to use vectors
           ;; instead of lists here, and space-efficiency here would be
           ;; nice, since it would reduce the peak memory usage in
           ;; FIXME: It would be more space-efficient to use vectors
           ;; instead of lists here, and space-efficiency here would be
           ;; nice, since it would reduce the peak memory usage in

@@ -1355,6 +1360,7 @@ core and return a descriptor to it."
   (cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
 
   (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
   (cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
 
   (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)

+  (cold-set '*!initial-debug-sources* *current-debug-sources*)

 
   #!+(or x86 x86-64)
   (progn
 
   #!+(or x86 x86-64)
   (progn

@@ -1363,9 +1369,9 @@ core and return a descriptor to it."
     (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0))
     (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0))))
 
     (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0))
     (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0))))
 

-;;; 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.
-(defun make-make-package-args (pkg)
+;;; 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.
+(defun make-make-package-args (pkg internal-count external-count)

   (let* ((use *nil-descriptor*)
          (cold-nicknames *nil-descriptor*)
          (res *nil-descriptor*))
   (let* ((use *nil-descriptor*)
          (cold-nicknames *nil-descriptor*)
          (res *nil-descriptor*))

@@ -1394,13 +1400,14 @@ core and return a descriptor to it."
       (dolist (warm-nickname warm-nicknames)
         (cold-push (base-string-to-core warm-nickname) cold-nicknames)))
 
       (dolist (warm-nickname warm-nicknames)
         (cold-push (base-string-to-core warm-nickname) cold-nicknames)))
 

-    (cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
-                                         0.8))
-               res)
+    ;; INTERNAL-COUNT and EXTERNAL-COUNT are the number of symbols that
+    ;; the package contains in the core. We arrange for the package
+    ;; symbol tables to be created somewhat larger so that they don't
+    ;; need to be rehashed so easily when additional symbols are
+    ;; interned during the warm build.
+    (cold-push (number-to-core (truncate internal-count 0.8)) res)

     (cold-push (cold-intern :internal-symbols) res)
     (cold-push (cold-intern :internal-symbols) res)

-    (cold-push (number-to-core (truncate (package-external-symbol-count pkg)
-                                         0.8))
-               res)
+    (cold-push (number-to-core (truncate external-count 0.8)) res)

     (cold-push (cold-intern :external-symbols) res)
 
     (cold-push cold-nicknames res)
     (cold-push (cold-intern :external-symbols) res)
 
     (cold-push cold-nicknames res)

@@ -1452,27 +1459,33 @@ core and return a descriptor to it."
 
 ;;; Given a cold representation of a function name, return a warm
 ;;; representation.
 
 ;;; Given a cold representation of a function name, return a warm
 ;;; representation.

-(declaim (ftype (function (descriptor) (or symbol list)) warm-fun-name))
+(declaim (ftype (function ((or descriptor symbol)) (or symbol list)) warm-fun-name))

 (defun warm-fun-name (des)
   (let ((result
 (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)))))
+         (if (symbolp des)
+             ;; This parallels the logic at the start of COLD-INTERN
+             ;; which re-homes symbols in SB-XC to COMMON-LISP.
+             (if (eq (symbol-package des) (find-package "SB-XC"))
+                 (intern (symbol-name des) *cl-package*)
+                 des)
+             (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))))))

     (legal-fun-name-or-type-error result)
     result))
 
 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
     (legal-fun-name-or-type-error result)
     result))
 
 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw)

-  (declare (type descriptor cold-name))
+  (declare (type (or descriptor symbol) cold-name))

   (/show0 "/cold-fdefinition-object")
   (let ((warm-name (warm-fun-name cold-name)))
     (or (gethash warm-name *cold-fdefn-objects*)
   (/show0 "/cold-fdefinition-object")
   (let ((warm-name (warm-fun-name cold-name)))
     (or (gethash warm-name *cold-fdefn-objects*)

@@ -1496,7 +1509,7 @@ core and return a descriptor to it."
 ;;; Handle the at-cold-init-time, fset-for-static-linkage operation
 ;;; requested by FOP-FSET.
 (defun static-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))
+  (declare (type (or descriptor symbol) cold-name))

   (let ((fdefn (cold-fdefinition-object cold-name t))
         (type (logand (descriptor-low (read-memory defn)) sb!vm:widetag-mask)))
     (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn)
   (let ((fdefn (cold-fdefinition-object cold-name t))
         (type (logand (descriptor-low (read-memory defn)) sb!vm:widetag-mask)))
     (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn)

@@ -1534,12 +1547,23 @@ core and return a descriptor to it."
                  sym nil offset desired))))))
 
 (defun list-all-fdefn-objects ()
                  sym nil offset desired))))))
 
 (defun list-all-fdefn-objects ()

-  (let ((result *nil-descriptor*))
+  (let ((fdefns nil)
+        (result *nil-descriptor*))

     (maphash (lambda (key value)
     (maphash (lambda (key value)

-               (declare (ignore key))
-               (cold-push value result))
+               (push (cons key value) fdefns))

              *cold-fdefn-objects*)
              *cold-fdefn-objects*)

-    result))
+    (flet ((sorter (x y)
+             (let* ((xbn (fun-name-block-name x))
+                    (ybn (fun-name-block-name y))
+                    (xbnpn (package-name (symbol-package-for-target-symbol xbn)))
+                    (ybnpn (package-name (symbol-package-for-target-symbol ybn))))
+               (cond
+                 ((eql xbn ybn) (consp x))
+                 ((string= xbn ybn) (string< xbnpn ybnpn))
+                 (t (string< xbn ybn))))))
+      (setq fdefns (sort fdefns #'sorter :key #'car)))
+    (dolist (fdefn fdefns result)
+      (cold-push (cdr fdefn) result))))

 \f
 ;;;; fixups and related stuff
 
 \f
 ;;;; fixups and related stuff
 

@@ -1587,6 +1611,13 @@ core and return a descriptor to it."
                                 (subseq line (1+ p2)))
                         (values (parse-integer line :end p1 :radix 16)
                                 (subseq line (1+ p2))))
                                 (subseq line (1+ p2)))
                         (values (parse-integer line :end p1 :radix 16)
                                 (subseq line (1+ p2))))

+                  ;; KLUDGE CLH 2010-05-31: on darwin, nm gives us
+                  ;; _function but dlsym expects us to look up
+                  ;; function, without the leading _ . Therefore, we
+                  ;; strip it off here.
+                  #!+darwin
+                  (when (equal (char name 0) #\_)
+                    (setf name (subseq name 1)))

                   (multiple-value-bind (old-value found)
                       (gethash name *cold-foreign-symbol-table*)
                     (when (and found
                   (multiple-value-bind (old-value found)
                       (gethash name *cold-foreign-symbol-table*)
                     (when (and found

@@ -1594,7 +1625,19 @@ core and return a descriptor to it."
                       (warn "redefining ~S from #X~X to #X~X"
                             name old-value value)))
                   (/show "adding to *cold-foreign-symbol-table*:" name 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))))))
+                  (setf (gethash name *cold-foreign-symbol-table*) value)
+                  #!+win32
+                  (let ((at-position (position #\@ name)))
+                    (when at-position
+                      (let ((name (subseq name 0 at-position)))
+                        (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))     ;; PROGN
 
 (defun cold-foreign-symbol-address (name)
   (values))     ;; PROGN
 
 (defun cold-foreign-symbol-address (name)

@@ -1634,37 +1677,44 @@ core and return a descriptor to it."
 ;;; The x86 port needs to store code fixups along with code objects if
 ;;; they are to be moved, so fixups for code objects in the dynamic
 ;;; heap need to be noted.
 ;;; The x86 port needs to store code fixups along with code objects if
 ;;; they are to be moved, so fixups for code objects in the dynamic
 ;;; heap need to be noted.

-#!+(or x86 x86-64)
+#!+x86

 (defvar *load-time-code-fixups*)
 
 (defvar *load-time-code-fixups*)
 

-#!+(or x86 x86-64)
-(defun note-load-time-code-fixup (code-object offset value kind)
+#!+x86
+(defun note-load-time-code-fixup (code-object offset)

   ;; If CODE-OBJECT might be moved
   (when (= (gspace-identifier (descriptor-intuit-gspace code-object))
            dynamic-core-space-id)
   ;; If CODE-OBJECT might be moved
   (when (= (gspace-identifier (descriptor-intuit-gspace code-object))
            dynamic-core-space-id)

-    ;; FIXME: pushed thing should be a structure, not just a list
-    (push (list code-object offset value kind) *load-time-code-fixups*))
+    (push offset (gethash (descriptor-bits code-object)
+                          *load-time-code-fixups*
+                          nil)))

   (values))
 
   (values))
 

-#!+(or x86 x86-64)
+#!+x86

 (defun output-load-time-code-fixups ()
 (defun output-load-time-code-fixups ()

-  (dolist (fixups *load-time-code-fixups*)
-    (let ((code-object (first fixups))
-          (offset (second fixups))
-          (value (third fixups))
-          (kind (fourth fixups)))
-      (cold-push (cold-cons
-                  (cold-intern :load-time-code-fixup)
-                  (cold-cons
-                   code-object
-                   (cold-cons
-                    (number-to-core offset)
-                    (cold-cons
-                     (number-to-core value)
-                     (cold-cons
-                      (cold-intern kind)
-                      *nil-descriptor*)))))
-                 *current-reversed-cold-toplevels*))))
+  (let ((fixup-infos nil))
+    (maphash
+     (lambda (code-object-address fixup-offsets)
+       (push (cons code-object-address fixup-offsets) fixup-infos))
+     *load-time-code-fixups*)
+    (setq fixup-infos (sort fixup-infos #'< :key #'car))
+    (dolist (fixup-info fixup-infos)
+      (let ((code-object-address (car fixup-info))
+            (fixup-offsets (cdr fixup-info)))
+        (let ((fixup-vector
+               (allocate-vector-object
+                *dynamic* sb!vm:n-word-bits (length fixup-offsets)
+                sb!vm:simple-array-unsigned-byte-32-widetag)))
+          (do ((index sb!vm:vector-data-offset (1+ index))
+               (fixups fixup-offsets (cdr fixups)))
+              ((null fixups))
+            (write-wordindexed fixup-vector index
+                               (make-random-descriptor (car fixups))))
+          ;; KLUDGE: The fixup vector is stored as the first constant,
+          ;; not as a separately-named slot.
+          (write-wordindexed (make-random-descriptor code-object-address)
+                             sb!vm:code-constants-offset
+                             fixup-vector))))))

 
 ;;; Given a pointer to a code object and an offset relative to the
 ;;; tail of the code object's header, return an offset relative to the
 
 ;;; Given a pointer to a code object and an offset relative to the
 ;;; tail of the code object's header, return an offset relative to the

@@ -1730,32 +1780,44 @@ core and return a descriptor to it."
        (ecase kind
          (:load
           (setf (bvref-32 gspace-bytes gspace-byte-offset)
        (ecase kind
          (:load
           (setf (bvref-32 gspace-bytes gspace-byte-offset)

-                (logior (ash (ldb (byte 11 0) value) 1)
-                        (logand (bvref-32 gspace-bytes gspace-byte-offset)
-                                #xffffc000))))
+                (logior (mask-field (byte 18 14)
+                                    (bvref-32 gspace-bytes gspace-byte-offset))
+                        (if (< value 0)
+                          (1+ (ash (ldb (byte 13 0) value) 1))
+                          (ash (ldb (byte 13 0) value) 1)))))
+         (:load11u
+          (setf (bvref-32 gspace-bytes gspace-byte-offset)
+                (logior (mask-field (byte 18 14)
+                                    (bvref-32 gspace-bytes gspace-byte-offset))
+                        (if (< value 0)
+                          (1+ (ash (ldb (byte 10 0) value) 1))
+                          (ash (ldb (byte 11 0) value) 1)))))

          (:load-short
           (let ((low-bits (ldb (byte 11 0) value)))
          (:load-short
           (let ((low-bits (ldb (byte 11 0) value)))

-            (assert (<= 0 low-bits (1- (ash 1 4))))
-            (setf (bvref-32 gspace-bytes gspace-byte-offset)
-                  (logior (ash low-bits 17)
-                          (logand (bvref-32 gspace-bytes gspace-byte-offset)
-                                  #xffe0ffff)))))
+            (assert (<= 0 low-bits (1- (ash 1 4)))))
+          (setf (bvref-32 gspace-bytes gspace-byte-offset)
+                (logior (ash (dpb (ldb (byte 4 0) value)
+                                  (byte 4 1)
+                                  (ldb (byte 1 4) value)) 17)
+                        (logand (bvref-32 gspace-bytes gspace-byte-offset)
+                                #xffe0ffff))))

          (:hi
           (setf (bvref-32 gspace-bytes gspace-byte-offset)
          (:hi
           (setf (bvref-32 gspace-bytes gspace-byte-offset)

-                (logior (ash (ldb (byte 5 13) value) 16)
+                (logior (mask-field (byte 11 21)
+                                    (bvref-32 gspace-bytes gspace-byte-offset))
+                        (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)
                         (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 (bvref-32 gspace-bytes gspace-byte-offset)
-                                #xffe00000))))
+                        (ldb (byte 1 31) value))))

          (:branch
           (let ((bits (ldb (byte 9 2) value)))
             (assert (zerop (ldb (byte 2 0) value)))
             (setf (bvref-32 gspace-bytes gspace-byte-offset)
                   (logior (ash bits 3)
          (:branch
           (let ((bits (ldb (byte 9 2) value)))
             (assert (zerop (ldb (byte 2 0) value)))
             (setf (bvref-32 gspace-bytes gspace-byte-offset)
                   (logior (ash bits 3)

-                          (logand (bvref-32 gspace-bytes gspace-byte-offset)
-                                  #xffe0e002)))))))
+                          (mask-field (byte 1 1) (bvref-32 gspace-bytes gspace-byte-offset))
+                          (mask-field (byte 3 13) (bvref-32 gspace-bytes gspace-byte-offset))
+                          (mask-field (byte 11 21) (bvref-32 gspace-bytes gspace-byte-offset))))))))

       (:mips
        (ecase kind
          (:jump
       (:mips
        (ecase kind
          (:jump

@@ -1767,27 +1829,35 @@ core and return a descriptor to it."
           (setf (bvref-32 gspace-bytes gspace-byte-offset)
                 (logior (mask-field (byte 16 16)
                                     (bvref-32 gspace-bytes gspace-byte-offset))
           (setf (bvref-32 gspace-bytes gspace-byte-offset)
                 (logior (mask-field (byte 16 16)
                                     (bvref-32 gspace-bytes gspace-byte-offset))

-                        (+ (ash value -16)
-                           (if (logbitp 15 value) 1 0)))))
+                        (ash (1+ (ldb (byte 17 15) value)) -1))))

          (:addi
           (setf (bvref-32 gspace-bytes gspace-byte-offset)
                 (logior (mask-field (byte 16 16)
                                     (bvref-32 gspace-bytes gspace-byte-offset))
                         (ldb (byte 16 0) value))))))
          (:addi
           (setf (bvref-32 gspace-bytes gspace-byte-offset)
                 (logior (mask-field (byte 16 16)
                                     (bvref-32 gspace-bytes gspace-byte-offset))
                         (ldb (byte 16 0) value))))))

+       ;; FIXME: PowerPC Fixups are not fully implemented. The bit
+       ;; here starts to set things up to work properly, but there
+       ;; needs to be corresponding code in ppc-vm.lisp

        (:ppc
        (:ppc

-       (ecase kind
-         (:ba
-          (setf (bvref-32 gspace-bytes gspace-byte-offset)
-                (dpb (ash value -2) (byte 24 2)
-                     (bvref-32 gspace-bytes gspace-byte-offset))))
-         (:ha
-          (let* ((h (ldb (byte 16 16) value))
-                 (l (ldb (byte 16 0) value)))
-            (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
-                  (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
-         (:l
-          (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
-                (ldb (byte 16 0) value)))))
+        (ecase kind
+          (:ba
+           (setf (bvref-32 gspace-bytes gspace-byte-offset)
+                 (dpb (ash value -2) (byte 24 2)
+                      (bvref-32 gspace-bytes gspace-byte-offset))))
+          (:ha
+           (let* ((un-fixed-up (bvref-16 gspace-bytes
+                                         (+ gspace-byte-offset 2)))
+                  (fixed-up (+ un-fixed-up value))
+                  (h (ldb (byte 16 16) fixed-up))
+                  (l (ldb (byte 16 0) fixed-up)))
+             (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
+                   (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
+          (:l
+           (let* ((un-fixed-up (bvref-16 gspace-bytes
+                                         (+ gspace-byte-offset 2)))
+                  (fixed-up (+ un-fixed-up value)))
+             (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
+                   (ldb (byte 16 0) fixed-up))))))

       (:sparc
        (ecase kind
          (:call
       (:sparc
        (ecase kind
          (:call

@@ -1803,6 +1873,11 @@ core and return a descriptor to it."
                      (byte 10 0)
                      (bvref-32 gspace-bytes gspace-byte-offset))))))
       ((:x86 :x86-64)
                      (byte 10 0)
                      (bvref-32 gspace-bytes gspace-byte-offset))))))
       ((:x86 :x86-64)

+       ;; XXX: Note that un-fixed-up is read via bvref-word, which is
+       ;; 64 bits wide on x86-64, but the fixed-up value is written
+       ;; via bvref-32.  This would make more sense if we supported
+       ;; :absolute64 fixups, but apparently the cross-compiler
+       ;; doesn't dump them.

        (let* ((un-fixed-up (bvref-word gspace-bytes
                                                gspace-byte-offset))
               (code-object-start-addr (logandc2 (descriptor-bits code-object)
        (let* ((un-fixed-up (bvref-word gspace-bytes
                                                gspace-byte-offset))
               (code-object-start-addr (logandc2 (descriptor-bits code-object)

@@ -1824,11 +1899,17 @@ core and return a descriptor to it."
               ;; (not beyond it). It would be good to add an
               ;; explanation of why that's true, or an assertion that
               ;; it's really true, or both.
               ;; (not beyond it). It would be good to add an
               ;; explanation of why that's true, or an assertion that
               ;; it's really true, or both.

+              ;;
+              ;; One possible explanation is that all absolute fixups
+              ;; point either within the code object, within the
+              ;; runtime, within read-only or static-space, or within
+              ;; the linkage-table space.  In all x86 configurations,
+              ;; these areas are prior to the start of dynamic space,
+              ;; where all the code-objects are loaded.
+              #!+x86

               (unless (< fixed-up code-object-start-addr)
                 (note-load-time-code-fixup code-object
               (unless (< fixed-up code-object-start-addr)
                 (note-load-time-code-fixup code-object

-                                           after-header
-                                           value
-                                           kind))))
+                                           after-header))))

            (:relative ; (used for arguments to X86 relative CALL instruction)
             (let ((fixed-up (- (+ value un-fixed-up)
                                gspace-byte-address
            (:relative ; (used for arguments to X86 relative CALL instruction)
             (let ((fixed-up (- (+ value un-fixed-up)
                                gspace-byte-address

@@ -1840,10 +1921,9 @@ core and return a descriptor to it."
               ;; object, which is to say all relative fixups, since
               ;; relative addressing within a code object never needs
               ;; a fixup.
               ;; object, which is to say all relative fixups, since
               ;; relative addressing within a code object never needs
               ;; a fixup.

+              #!+x86

               (note-load-time-code-fixup code-object
               (note-load-time-code-fixup code-object

-                                         after-header
-                                         value
-                                         kind))))))))
+                                         after-header))))))))

   (values))
 
 (defun resolve-assembler-fixups ()
   (values))
 
 (defun resolve-assembler-fixups ()

@@ -1853,20 +1933,50 @@ core and return a descriptor to it."
       (when value
         (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
 
       (when value
         (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
 

+#!+sb-dynamic-core
+(progn
+  (defparameter *dyncore-address* sb!vm::linkage-table-space-start)
+  (defparameter *dyncore-linkage-keys* nil)
+  (defparameter *dyncore-table* (make-hash-table :test 'equal))
+
+  (defun dyncore-note-symbol (symbol-name datap)
+    "Register a symbol and return its address in proto-linkage-table."
+    (let ((key (cons symbol-name datap)))
+      (symbol-macrolet ((entry (gethash key *dyncore-table*)))
+        (or entry
+            (setf entry
+                  (prog1 *dyncore-address*
+                    (push key *dyncore-linkage-keys*)
+                    (incf *dyncore-address* sb!vm::linkage-table-entry-size))))))))
+

 ;;; *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 foreign-symbols-to-core ()
 ;;; *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 foreign-symbols-to-core ()

+  (let ((symbols nil)
+        (result *nil-descriptor*))
+    #!-sb-dynamic-core
+    (progn
+      (maphash (lambda (symbol value)
+                 (push (cons symbol value) symbols))
+               *cold-foreign-symbol-table*)
+      (setq symbols (sort symbols #'string< :key #'car))
+      (dolist (symbol symbols)
+        (cold-push (cold-cons (base-string-to-core (car symbol))
+                              (number-to-core (cdr symbol)))
+                   result)))
+    (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result)
+    #!+sb-dynamic-core
+    (let ((runtime-linking-list *nil-descriptor*))
+      (dolist (symbol *dyncore-linkage-keys*)
+        (cold-push (cold-cons (base-string-to-core (car symbol))
+                              (cdr symbol))
+                   runtime-linking-list))
+      (cold-set (cold-intern 'sb!vm::*required-runtime-c-symbols*)
+                runtime-linking-list)))

   (let ((result *nil-descriptor*))
   (let ((result *nil-descriptor*))

-    (maphash (lambda (symbol value)
-               (cold-push (cold-cons (base-string-to-core symbol)
-                                     (number-to-core value))
-                          result))
-             *cold-foreign-symbol-table*)
-    (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result))
-  (let ((result *nil-descriptor*))
-    (dolist (rtn *cold-assembler-routines*)
+    (dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car))

       (cold-push (cold-cons (cold-intern (car rtn))
                             (number-to-core (cdr rtn)))
                  result))
       (cold-push (cold-cons (cold-intern (car rtn))
                             (number-to-core (cdr rtn)))
                  result))

@@ -1882,8 +1992,6 @@ core and return a descriptor to it."
   ;; modified.
   (copy-seq *fop-funs*))
 
   ;; modified.
   (copy-seq *fop-funs*))
 

-(defvar *normal-fop-funs*)
-

 ;;; Cause a fop to have a special definition for cold load.
 ;;;
 ;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version
 ;;; Cause a fop to have a special definition for cold load.
 ;;;
 ;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version

@@ -1927,8 +2035,7 @@ core and return a descriptor to it."
 (defun cold-load (filename)
   #!+sb-doc
   "Load the file named by FILENAME into the cold load image being built."
 (defun cold-load (filename)
   #!+sb-doc
   "Load the file named by FILENAME into the cold load image being built."

-  (let* ((*normal-fop-funs* *fop-funs*)
-         (*fop-funs* *cold-fop-funs*)
+  (let* ((*fop-funs* *cold-fop-funs*)

          (*cold-load-filename* (etypecase filename
                                  (string filename)
                                  (pathname (namestring filename)))))
          (*cold-load-filename* (etypecase filename
                                  (string filename)
                                  (pathname (namestring filename)))))

@@ -1942,17 +2049,8 @@ core and return a descriptor to it."
 (define-cold-fop (fop-short-character)
   (make-character-descriptor (read-byte-arg)))
 
 (define-cold-fop (fop-short-character)
   (make-character-descriptor (read-byte-arg)))
 

-(define-cold-fop (fop-empty-list) *nil-descriptor*)
-(define-cold-fop (fop-truth) (cold-intern t))
-
-(define-cold-fop (fop-normal-load :stackp nil)
-  (setq *fop-funs* *normal-fop-funs*))
-
-(define-fop (fop-maybe-cold-load 82 :stackp nil)
-  (when *cold-load-filename*
-    (setq *fop-funs* *cold-fop-funs*)))
-
-(define-cold-fop (fop-maybe-cold-load :stackp nil))
+(define-cold-fop (fop-empty-list) nil)
+(define-cold-fop (fop-truth) t)

 
 (clone-cold-fop (fop-struct)
                 (fop-small-struct)
 
 (clone-cold-fop (fop-struct)
                 (fop-small-struct)

@@ -1963,7 +2061,10 @@ core and return a descriptor to it."
          (layout (pop-stack))
          (nuntagged
           (descriptor-fixnum
          (layout (pop-stack))
          (nuntagged
           (descriptor-fixnum

-           (read-wordindexed layout (+ sb!vm:instance-slots-offset 16))))
+           (read-wordindexed
+            layout
+            (+ sb!vm:instance-slots-offset
+               (target-layout-index 'n-untagged-slots)))))

          (ntagged (- size nuntagged)))
     (write-memory result (make-other-immediate-descriptor
                           size sb!vm:instance-header-widetag))
          (ntagged (- size nuntagged)))
     (write-memory result (make-other-immediate-descriptor
                           size sb!vm:instance-header-widetag))

@@ -2048,14 +2149,14 @@ core and return a descriptor to it."
 (defun cold-load-symbol (size package)
   (let ((string (make-string size)))
     (read-string-as-bytes *fasl-input-stream* string)
 (defun cold-load-symbol (size package)
   (let ((string (make-string size)))
     (read-string-as-bytes *fasl-input-stream* string)

-    (cold-intern (intern string package))))
+    (intern string package)))

 
 (macrolet ((frob (name pname-len package-len)
              `(define-cold-fop (,name)
                 (let ((index (read-arg ,package-len)))
                   (push-fop-table
                    (cold-load-symbol (read-arg ,pname-len)
 
 (macrolet ((frob (name pname-len package-len)
              `(define-cold-fop (,name)
                 (let ((index (read-arg ,package-len)))
                   (push-fop-table
                    (cold-load-symbol (read-arg ,pname-len)

-                                     (svref *current-fop-table* index)))))))
+                                     (ref-fop-table index)))))))

   (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-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)

@@ -2077,6 +2178,15 @@ core and return a descriptor to it."
     (let ((symbol-des (allocate-symbol name)))
       (push-fop-table symbol-des))))
 \f
     (let ((symbol-des (allocate-symbol name)))
       (push-fop-table symbol-des))))
 \f

+;;;; cold fops for loading packages
+
+(clone-cold-fop (fop-named-package-save :stackp nil)
+                (fop-small-named-package-save)
+  (let* ((size (clone-arg))
+         (name (make-string size)))
+    (read-string-as-bytes *fasl-input-stream* name)
+    (push-fop-table (find-package name))))
+\f

 ;;;; cold fops for loading lists
 
 ;;; Make a list of the top LENGTH things on the fop stack. The last
 ;;;; cold fops for loading lists
 
 ;;; Make a list of the top LENGTH things on the fop stack. The last

@@ -2223,19 +2333,19 @@ core and return a descriptor to it."
     (write-wordindexed result sb!vm:array-data-slot data-vector)
     (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
     (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)
     (write-wordindexed result sb!vm:array-data-slot data-vector)
     (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
     (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)

+    (write-wordindexed result sb!vm:array-displaced-from-slot *nil-descriptor*)

     (let ((total-elements 1))
       (dotimes (axis rank)
         (let ((dim (pop-stack)))
     (let ((total-elements 1))
       (dotimes (axis rank)
         (let ((dim (pop-stack)))

-          (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-lowtag)
-                      (= (descriptor-lowtag dim) sb!vm:odd-fixnum-lowtag))
+          (unless (is-fixnum-lowtag (descriptor-lowtag dim))

             (error "non-fixnum dimension? (~S)" dim))
           (setf total-elements
                 (* total-elements
                    (logior (ash (descriptor-high dim)
                                 (- descriptor-low-bits
             (error "non-fixnum dimension? (~S)" dim))
           (setf total-elements
                 (* total-elements
                    (logior (ash (descriptor-high dim)
                                 (- descriptor-low-bits

-                                   (1- sb!vm:n-lowtag-bits)))
+                                   sb!vm:n-fixnum-tag-bits))

                            (ash (descriptor-low dim)
                            (ash (descriptor-low dim)

-                                (- 1 sb!vm:n-lowtag-bits)))))
+                                sb!vm:n-fixnum-tag-bits))))

           (write-wordindexed result
                              (+ sb!vm:array-dimensions-offset axis)
                              dim)))
           (write-wordindexed result
                              (+ sb!vm:array-dimensions-offset axis)
                              dim)))

@@ -2295,7 +2405,7 @@ core and return a descriptor to it."
                   *nil-descriptor*)))
                *current-reversed-cold-toplevels*)
     (setf *load-time-value-counter* (1+ counter))
                   *nil-descriptor*)))
                *current-reversed-cold-toplevels*)
     (setf *load-time-value-counter* (1+ counter))

-    (make-descriptor 0 0 nil counter)))
+    (make-descriptor 0 0 :load-time-value counter)))

 
 (defun finalize-load-time-value-noise ()
   (cold-set (cold-intern '*!load-time-values*)
 
 (defun finalize-load-time-value-noise ()
   (cold-set (cold-intern '*!load-time-values*)

@@ -2313,17 +2423,17 @@ core and return a descriptor to it."
 ;;;; cold fops for fixing up circularities
 
 (define-cold-fop (fop-rplaca :pushp nil)
 ;;;; cold fops for fixing up circularities
 
 (define-cold-fop (fop-rplaca :pushp nil)

-  (let ((obj (svref *current-fop-table* (read-word-arg)))
+  (let ((obj (ref-fop-table (read-word-arg)))

         (idx (read-word-arg)))
     (write-memory (cold-nthcdr idx obj) (pop-stack))))
 
 (define-cold-fop (fop-rplacd :pushp nil)
         (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-word-arg)))
+  (let ((obj (ref-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)
         (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-word-arg)))
+  (let ((obj (ref-fop-table (read-word-arg)))

         (idx (read-word-arg)))
     (write-wordindexed obj
                    (+ idx
         (idx (read-word-arg)))
     (write-wordindexed obj
                    (+ idx

@@ -2333,7 +2443,7 @@ core and return a descriptor to it."
                    (pop-stack))))
 
 (define-cold-fop (fop-structset :pushp nil)
                    (pop-stack))))
 
 (define-cold-fop (fop-structset :pushp nil)

-  (let ((obj (svref *current-fop-table* (read-word-arg)))
+  (let ((obj (ref-fop-table (read-word-arg)))

         (idx (read-word-arg)))
     (write-wordindexed obj (1+ idx) (pop-stack))))
 
         (idx (read-word-arg)))
     (write-wordindexed obj (1+ idx) (pop-stack))))
 

@@ -2366,6 +2476,10 @@ core and return a descriptor to it."
         (setf (gethash warm-name *cold-fset-warm-names*) t))
     (static-fset cold-name fn)))
 
         (setf (gethash warm-name *cold-fset-warm-names*) t))
     (static-fset cold-name fn)))
 

+(define-cold-fop (fop-note-debug-source :pushp nil)
+  (let ((debug-source (pop-stack)))
+    (cold-push debug-source *current-debug-sources*)))
+

 (define-cold-fop (fop-fdefinition)
   (cold-fdefinition-object (pop-stack)))
 
 (define-cold-fop (fop-fdefinition)
   (cold-fdefinition-object (pop-stack)))
 

@@ -2445,7 +2559,8 @@ core and return a descriptor to it."
     (write-wordindexed code slot value)))
 
 (define-cold-fop (fop-fun-entry)
     (write-wordindexed code slot value)))
 
 (define-cold-fop (fop-fun-entry)

-  (let* ((type (pop-stack))
+  (let* ((info (pop-stack))
+         (type (pop-stack))

          (arglist (pop-stack))
          (name (pop-stack))
          (code-object (pop-stack))
          (arglist (pop-stack))
          (name (pop-stack))
          (code-object (pop-stack))

@@ -2502,6 +2617,7 @@ core and return a descriptor to it."
     (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)
     (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)

+    (write-wordindexed fn sb!vm::simple-fun-info-slot info)

     fn))
 
 (define-cold-fop (fop-foreign-fixup)
     fn))
 
 (define-cold-fop (fop-foreign-fixup)

@@ -2510,6 +2626,12 @@ core and return a descriptor to it."
          (len (read-byte-arg))
          (sym (make-string len)))
     (read-string-as-bytes *fasl-input-stream* sym)
          (len (read-byte-arg))
          (sym (make-string len)))
     (read-string-as-bytes *fasl-input-stream* sym)

+    #!+sb-dynamic-core
+    (let ((offset (read-word-arg))
+          (value (dyncore-note-symbol sym nil)))
+      (do-cold-fixup code-object offset value kind))
+    #!- (and) (format t "Bad non-plt fixup: ~S~S~%" sym code-object)
+    #!-sb-dynamic-core

     (let ((offset (read-word-arg))
           (value (cold-foreign-symbol-address sym)))
       (do-cold-fixup code-object offset value kind))
     (let ((offset (read-word-arg))
           (value (cold-foreign-symbol-address sym)))
       (do-cold-fixup code-object offset value kind))

@@ -2521,11 +2643,19 @@ core and return a descriptor to it."
          (code-object (pop-stack))
          (len (read-byte-arg))
          (sym (make-string len)))
          (code-object (pop-stack))
          (len (read-byte-arg))
          (sym (make-string len)))

+    #!-sb-dynamic-core (declare (ignore code-object))

     (read-string-as-bytes *fasl-input-stream* sym)
     (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)))
+    #!+sb-dynamic-core
+    (let ((offset (read-word-arg))
+          (value (dyncore-note-symbol sym t)))
+      (do-cold-fixup code-object offset value kind)
+      code-object)
+    #!-sb-dynamic-core
+    (progn
+      (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-word-arg))
 
 (define-cold-fop (fop-assembler-code)
   (let* ((length (read-word-arg))

@@ -2583,6 +2713,30 @@ core and return a descriptor to it."
     (do-cold-fixup code-object offset value kind)
     code-object))
 \f
     (do-cold-fixup code-object offset value kind)
     code-object))
 \f

+;;;; sanity checking space layouts
+
+(defun check-spaces ()
+  ;;; Co-opt type machinery to check for intersections...
+  (let (types)
+    (flet ((check (start end space)
+             (unless (< start end)
+               (error "Bogus space: ~A" space))
+             (let ((type (specifier-type `(integer ,start ,end))))
+               (dolist (other types)
+                 (unless (eq *empty-type* (type-intersection (cdr other) type))
+                   (error "Space overlap: ~A with ~A" space (car other))))
+               (push (cons space type) types))))
+      (check sb!vm:read-only-space-start sb!vm:read-only-space-end :read-only)
+      (check sb!vm:static-space-start sb!vm:static-space-end :static)
+      #!+gencgc
+      (check sb!vm:dynamic-space-start sb!vm:dynamic-space-end :dynamic)
+      #!-gencgc
+      (progn
+        (check sb!vm:dynamic-0-space-start sb!vm:dynamic-0-space-end :dynamic-0)
+        (check sb!vm:dynamic-1-space-start sb!vm:dynamic-1-space-end :dynamic-1))
+      #!+linkage-table
+      (check sb!vm:linkage-table-space-start sb!vm:linkage-table-space-end :linkage-table))))
+\f

 ;;;; emitting C header file
 
 (defun tailwise-equal (string tail)
 ;;;; emitting C header file
 
 (defun tailwise-equal (string tail)

@@ -2594,7 +2748,7 @@ core and return a descriptor to it."
   (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.)"
   (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.)"

-             ""
+             nil

              "This file contains low-level information about the"
              "internals of a particular version and configuration"
              "of SBCL. It is used by the C compiler to create a runtime"
              "This file contains low-level information about the"
              "internals of a particular version and configuration"
              "of SBCL. It is used by the C compiler to create a runtime"

@@ -2602,17 +2756,31 @@ core and return a descriptor to it."
              "operating system's native format, which can then be used to"
              "load and run 'core' files, which are basically programs"
              "in SBCL's own format."))
              "operating system's native format, which can then be used to"
              "load and run 'core' files, which are basically programs"
              "in SBCL's own format."))

-    (format t " * ~A~%" line))
+    (format t " *~@[ ~A~]~%" line))

   (format t " */~%"))
 
   (format t " */~%"))
 

+(defun c-name (string &optional strip)
+  (delete #\+
+          (substitute-if #\_ (lambda (c) (member c '(#\- #\/ #\%)))
+                         (remove-if (lambda (c) (position c strip))
+                                    string))))
+
+(defun c-symbol-name (symbol &optional strip)
+  (c-name (symbol-name symbol) strip))
+
+(defun write-makefile-features ()
+  ;; propagating *SHEBANG-FEATURES* into the Makefiles
+  (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name
+                                              sb-cold:*shebang-features*)
+                                      #'string<))
+    (format t "LISP_FEATURE_~A=1~%" shebang-feature-name)))
+

 (defun write-config-h ()
   ;; propagating *SHEBANG-FEATURES* into C-level #define's
 (defun write-config-h ()
   ;; propagating *SHEBANG-FEATURES* into C-level #define's

-  (dolist (shebang-feature-name (sort (mapcar #'symbol-name
+  (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name

                                               sb-cold:*shebang-features*)
                                       #'string<))
                                               sb-cold:*shebang-features*)
                                       #'string<))

-    (format t
-            "#define LISP_FEATURE_~A~%"
-            (substitute #\_ #\- shebang-feature-name)))
+    (format t "#define LISP_FEATURE_~A~%" shebang-feature-name))

   (terpri)
   ;; and miscellaneous constants
   (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
   (terpri)
   ;; and miscellaneous constants
   (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)

@@ -2630,7 +2798,7 @@ core and return a descriptor to it."
 (defun write-constants-h ()
   ;; writing entire families of named constants
   (let ((constants nil))
 (defun write-constants-h ()
   ;; writing entire families of named constants
   (let ((constants nil))

-    (dolist (package-name '(;; Even in CMU CL, constants from VM
+    (dolist (package-name '( ;; Even in CMU CL, constants from VM

                             ;; were automatically propagated
                             ;; into the runtime.
                             "SB!VM"
                             ;; were automatically propagated
                             ;; into the runtime.
                             "SB!VM"

@@ -2641,11 +2809,12 @@ core and return a descriptor to it."
       (do-external-symbols (symbol (find-package package-name))
         (when (constantp symbol)
           (let ((name (symbol-name symbol)))
       (do-external-symbols (symbol (find-package package-name))
         (when (constantp symbol)
           (let ((name (symbol-name symbol)))

-            (labels (;; shared machinery
-                     (record (string priority)
+            (labels ( ;; shared machinery
+                     (record (string priority suffix)

                        (push (list string
                                    priority
                                    (symbol-value symbol)
                        (push (list string
                                    priority
                                    (symbol-value symbol)

+                                   suffix

                                    (documentation symbol 'variable))
                              constants))
                      ;; machinery for old-style CMU CL Lisp-to-C
                                    (documentation symbol 'variable))
                              constants))
                      ;; machinery for old-style CMU CL Lisp-to-C

@@ -2657,7 +2826,8 @@ core and return a descriptor to it."
                                 'simple-string
                                 prefix
                                 (delete #\- (string-capitalize string)))
                                 'simple-string
                                 prefix
                                 (delete #\- (string-capitalize string)))

-                               priority))
+                               priority
+                               ""))

                      (maybe-record-with-munged-name (tail prefix priority)
                        (when (tailwise-equal name tail)
                          (record-with-munged-name prefix
                      (maybe-record-with-munged-name (tail prefix priority)
                        (when (tailwise-equal name tail)
                          (record-with-munged-name prefix

@@ -2666,24 +2836,31 @@ core and return a descriptor to it."
                                                              (length tail)))
                                                   priority)))
                      ;; machinery for new-style SBCL Lisp-to-C naming
                                                              (length tail)))
                                                   priority)))
                      ;; machinery for new-style SBCL Lisp-to-C naming

-                     (record-with-translated-name (priority)
-                       (record (substitute #\_ #\- name)
-                               priority))
-                     (maybe-record-with-translated-name (suffixes priority)
+                     (record-with-translated-name (priority large)
+                       (record (c-name name) priority
+                               (if large
+                                   #!+(and win32 x86-64) "LLU"
+                                   #!-(and win32 x86-64) "LU"
+                                   "")))
+                     (maybe-record-with-translated-name (suffixes priority &key large)

                        (when (some (lambda (suffix)
                                      (tailwise-equal name suffix))
                                    suffixes)
                        (when (some (lambda (suffix)
                                      (tailwise-equal name suffix))
                                    suffixes)

-                         (record-with-translated-name priority))))
-
+                         (record-with-translated-name priority large))))

               (maybe-record-with-translated-name '("-LOWTAG") 0)
               (maybe-record-with-translated-name '("-LOWTAG") 0)

-              (maybe-record-with-translated-name '("-WIDETAG") 1)
+              (maybe-record-with-translated-name '("-WIDETAG" "-SHIFT") 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-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" "-SIZE") 6)
-              (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7)
-              (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8))))))
+              (maybe-record-with-translated-name '("-SIZE") 6)
+              (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES"
+                                                   "-CARD-BYTES" "-GRANULARITY")
+                                                 7 :large t)
+              (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8)
+              (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9)
+              (maybe-record-with-translated-name '("-CORE-SPACE-ID-FLAG") 9)
+              (maybe-record-with-translated-name '("-GENERATION+") 10))))))

     ;; 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
     ;; 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

@@ -2694,61 +2871,38 @@ core and return a descriptor to it."
                  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))
                  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))
+      (push (list (c-symbol-name c)

                   -1                    ; invent a new priority
                   (symbol-value c)
                   -1                    ; invent a new priority
                   (symbol-value c)

+                  ""

                   nil)
             constants))
     ;; One more symbol that doesn't fit into the code above.
                   nil)
             constants))
     ;; One more symbol that doesn't fit into the code above.

-    (flet ((translate (name)
-             (delete #\+ (substitute #\_ #\- name))))
-      (let ((c 'sb!impl::+magic-hash-vector-value+))
-        (push (list (translate (symbol-name c))
-                    9
-                    (symbol-value c)
-                    nil)
-              constants)))
-
+    (let ((c 'sb!impl::+magic-hash-vector-value+))
+      (push (list (c-symbol-name c)
+                  9
+                  (symbol-value c)
+                  #!+(and win32 x86-64) "LLU"
+                  #!-(and win32 x86-64) "LU"
+                  nil)
+            constants))

     (setf constants
           (sort constants
                 (lambda (const1 const2)
                   (if (= (second const1) (second const2))
     (setf constants
           (sort constants
                 (lambda (const1 const2)
                   (if (= (second const1) (second const2))

-                      (< (third const1) (third const2))
+                      (if (= (third const1) (third const2))
+                          (string< (first const1) (first const2))
+                          (< (third const1) (third const2)))

                       (< (second const1) (second const2))))))
     (let ((prev-priority (second (car constants))))
       (dolist (const constants)
                       (< (second const1) (second const2))))))
     (let ((prev-priority (second (car constants))))
       (dolist (const constants)

-        (destructuring-bind (name priority value doc) const
+        (destructuring-bind (name priority value suffix doc) const

           (unless (= prev-priority priority)
             (terpri)
             (setf prev-priority priority))
           (unless (= prev-priority priority)
             (terpri)
             (setf prev-priority priority))

-          (format t "#define ~A " name)
-          (format t
-                  ;; KLUDGE: As of sbcl-0.6.7.14, we're dumping two
-                  ;; different kinds of values here, (1) small codes
-                  ;; and (2) machine addresses. The small codes can be
-                  ;; dumped as bare integer values. The large machine
-                  ;; addresses might cause problems if they're large
-                  ;; and represented as (signed) C integers, so we
-                  ;; want to force them to be unsigned. We do that by
-                  ;; wrapping them in the LISPOBJ macro. (We could do
-                  ;; it with a bare "(unsigned)" cast, except that
-                  ;; this header file is used not only in C files, but
-                  ;; also in assembly files, which don't understand
-                  ;; the cast syntax. The LISPOBJ macro goes away in
-                  ;; assembly files, but that shouldn't matter because
-                  ;; we don't do arithmetic on address constants in
-                  ;; assembly files. See? It really is a kludge..) --
-                  ;; WHN 2000-10-18
-                  (let (;; cutoff for treatment as a small code
-                        (cutoff (expt 2 16)))
-                    (cond ((minusp value)
-                           (error "stub: negative values unsupported"))
-                          ((< value cutoff)
-                           "~D")
-                          (t
-                           "LISPOBJ(~D)")))
-                  value)
-          (format t " /* 0x~X */~@[  /* ~A */~]~%" value doc))))
+          (when (minusp value)
+            (error "stub: negative values unsupported"))
+          (format t "#define ~A ~A~A /* 0x~X ~@[ -- ~A ~]*/~%" name value suffix value doc))))

     (terpri))
 
   ;; writing information about internal errors
     (terpri))
 
   ;; writing information about internal errors

@@ -2759,8 +2913,17 @@ core and return a descriptor to it."
         ;; interr.lisp) -- APD, 2002-03-05
         (unless (eq nil (car current-error))
           (format t "#define ~A ~D~%"
         ;; interr.lisp) -- APD, 2002-03-05
         (unless (eq nil (car current-error))
           (format t "#define ~A ~D~%"

-                  (substitute #\_ #\- (symbol-name (car current-error)))
-                  i)))))
+                  (c-symbol-name (car current-error))
+                  i))))
+    (format t "#define INTERNAL_ERROR_NAMES \\~%~{~S~#[~:;, \\~%~]~}~%"
+            (map 'list #'cdr internal-errors)))
+  (terpri)
+
+  ;; I'm not really sure why this is in SB!C, since it seems
+  ;; conceptually like something that belongs to SB!VM. In any case,
+  ;; it's needed C-side.
+  (format t "#define BACKEND_PAGE_BYTES ~DLU~%" sb!c:*backend-page-bytes*)
+

   (terpri)
 
   ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between
   (terpri)
 
   ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between

@@ -2778,50 +2941,83 @@ core and return a descriptor to it."
   ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
   ;; [possibly applicable to other platforms])
 
   ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
   ;; [possibly applicable to other platforms])
 

+  #!+sb-safepoint
+  (format t "#define GC_SAFEPOINT_PAGE_ADDR ((void*)0x~XUL) /* ~:*~A */~%"
+            sb!vm:gc-safepoint-page-addr)
+

   (dolist (symbol '(sb!vm::float-traps-byte
                     sb!vm::float-exceptions-byte
                     sb!vm::float-sticky-bits
                     sb!vm::float-rounding-mode))
     (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%"
   (dolist (symbol '(sb!vm::float-traps-byte
                     sb!vm::float-exceptions-byte
                     sb!vm::float-sticky-bits
                     sb!vm::float-rounding-mode))
     (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%"

-            (substitute #\_ #\- (symbol-name symbol))
+            (c-symbol-name symbol)

             (sb!xc:byte-position (symbol-value symbol)))
     (format t "#define ~A_MASK 0x~X /* ~:*~A */~%"
             (sb!xc:byte-position (symbol-value symbol)))
     (format t "#define ~A_MASK 0x~X /* ~:*~A */~%"

-            (substitute #\_ #\- (symbol-name symbol))
+            (c-symbol-name symbol)

             (sb!xc:mask-field (symbol-value symbol) -1))))
 
             (sb!xc:mask-field (symbol-value symbol) -1))))
 

-
+#!+sb-ldb
+(defun write-tagnames-h (&optional (out *standard-output*))
+  (labels
+      ((pretty-name (symbol strip)
+         (let ((name (string-downcase symbol)))
+           (substitute #\Space #\-
+                       (subseq name 0 (- (length name) (length strip))))))
+       (list-sorted-tags (tail)
+         (loop for symbol being the external-symbols of "SB!VM"
+               when (and (constantp symbol)
+                         (tailwise-equal (string symbol) tail))
+               collect symbol into tags
+               finally (return (sort tags #'< :key #'symbol-value))))
+       (write-tags (kind limit ash-count)
+         (format out "~%static const char *~(~A~)_names[] = {~%"
+                 (subseq kind 1))
+         (let ((tags (list-sorted-tags kind)))
+           (dotimes (i limit)
+             (if (eql i (ash (or (symbol-value (first tags)) -1) ash-count))
+                 (format out "    \"~A\"" (pretty-name (pop tags) kind))
+                 (format out "    \"unknown [~D]\"" i))
+             (unless (eql i (1- limit))
+               (write-string "," out))
+             (terpri out)))
+         (write-line "};" out)))
+    (write-tags "-LOWTAG" sb!vm:lowtag-limit 0)
+    ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG
+    ;; ending with the same 2 bits. (#b10)
+    (write-tags "-WIDETAG" (ash (1+ sb!vm:widetag-mask) -2) -2))
+  (values))

 
 (defun write-primitive-object (obj)
   ;; writing primitive object layouts
 
 (defun write-primitive-object (obj)
   ;; writing primitive object layouts

-    (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
-      (format t
-              "struct ~A {~%"
-              (substitute #\_ #\-
-              (string-downcase (string (sb!vm:primitive-object-name obj)))))
-      (when (sb!vm:primitive-object-widetag obj)
-        (format t "    lispobj header;~%"))
-      (dolist (slot (sb!vm:primitive-object-slots obj))
-        (format t "    ~A ~A~@[[1]~];~%"
-        (getf (sb!vm:slot-options slot) :c-type "lispobj")
-        (substitute #\_ #\-
-                    (string-downcase (string (sb!vm:slot-name slot))))
-        (sb!vm:slot-rest-p slot)))
+  (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
+  (format t
+          "struct ~A {~%"
+          (c-name (string-downcase (string (sb!vm:primitive-object-name obj)))))
+  (when (sb!vm:primitive-object-widetag obj)
+    (format t "    lispobj header;~%"))
+  (dolist (slot (sb!vm:primitive-object-slots obj))
+    (format t "    ~A ~A~@[[1]~];~%"
+            (getf (sb!vm:slot-options slot) :c-type "lispobj")
+            (c-name (string-downcase (string (sb!vm:slot-name slot))))
+            (sb!vm:slot-rest-p slot)))

   (format t "};~2%")
   (format t "};~2%")

-    (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
-      (let ((name (sb!vm:primitive-object-name obj))
-      (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
-        (when lowtag
-        (dolist (slot (sb!vm:primitive-object-slots obj))
-          (format t "#define ~A_~A_OFFSET ~D~%"
-                  (substitute #\_ #\- (string name))
-                  (substitute #\_ #\- (string (sb!vm:slot-name slot)))
-                  (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
-      (terpri)))
-    (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
+  (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
+  (format t "/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%")
+  (format t " * so they work directly on tagged addresses. */~2%")
+  (let ((name (sb!vm:primitive-object-name obj))
+        (lowtag (or (symbol-value (sb!vm:primitive-object-lowtag obj))
+                    0)))
+    (dolist (slot (sb!vm:primitive-object-slots obj))
+      (format t "#define ~A_~A_OFFSET ~D~%"
+              (c-symbol-name name)
+              (c-symbol-name (sb!vm:slot-name slot))
+              (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
+    (terpri))
+  (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))

 
 (defun write-structure-object (dd)
   (flet ((cstring (designator)
 
 (defun write-structure-object (dd)
   (flet ((cstring (designator)

-           (substitute #\_ #\- (string-downcase (string designator)))))
+           (c-name (string-downcase (string designator)))))

     (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
     (format t "struct ~A {~%" (cstring (dd-name dd)))
     (format t "    lispobj header;~%")
     (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
     (format t "struct ~A {~%" (cstring (dd-name dd)))
     (format t "    lispobj header;~%")

@@ -2830,9 +3026,9 @@ core and return a descriptor to it."
       (when (eq t (dsd-raw-type slot))
         (format t "    lispobj ~A;~%" (cstring (dsd-name slot)))))
     (unless (oddp (+ (dd-length dd) (dd-raw-length 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;~%"))
+      (format t "    lispobj raw_slot_padding;~%"))

     (dotimes (n (dd-raw-length dd))
     (dotimes (n (dd-raw-length dd))

-      (format t "    long raw~D;~%" (- (dd-raw-length dd) n 1)))
+      (format t "    lispobj raw~D;~%" (- (dd-raw-length dd) n 1)))

     (format t "};~2%")
     (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")))
 
     (format t "};~2%")
     (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")))
 

@@ -2841,10 +3037,9 @@ core and return a descriptor to it."
     ;; FIXME: It would be nice to use longer names than NIL and
     ;; (particularly) T in #define statements.
     (format t "#define ~A LISPOBJ(0x~X)~%"
     ;; FIXME: It would be nice to use longer names than NIL and
     ;; (particularly) T in #define statements.
     (format t "#define ~A LISPOBJ(0x~X)~%"

-            (substitute #\_ #\-
-                        (remove-if (lambda (char)
-                                     (member char '(#\% #\* #\. #\!)))
-                                   (symbol-name symbol)))
+            ;; FIXME: It would be nice not to need to strip anything
+            ;; that doesn't get stripped always by C-SYMBOL-NAME.
+            (c-symbol-name symbol "%*.!")

             (if *static*                ; if we ran GENESIS
               ;; We actually ran GENESIS, use the real value.
               (descriptor-bits (cold-intern symbol))
             (if *static*                ; if we ran GENESIS
               ;; We actually ran GENESIS, use the real value.
               (descriptor-bits (cold-intern symbol))

@@ -2901,7 +3096,9 @@ initially undefined function references:~2%")
 
       (setf undefs (sort undefs #'string< :key #'fun-name-block-name))
       (dolist (name undefs)
 
       (setf undefs (sort undefs #'string< :key #'fun-name-block-name))
       (dolist (name undefs)

-        (format t "~S~%" name)))
+        (format t "~8,'0X: ~S~%"
+                (descriptor-bits (gethash name *cold-fdefn-objects*))
+                name)))

 
     (format t "~%~|~%layout names:~2%")
     (collect ((stuff))
 
     (format t "~%~|~%layout names:~2%")
     (collect ((stuff))

@@ -2934,6 +3131,7 @@ initially undefined function references:~2%")
 (defconstant build-id-core-entry-type-code 3899)
 (defconstant new-directory-core-entry-type-code 3861)
 (defconstant initial-fun-core-entry-type-code 3863)
 (defconstant build-id-core-entry-type-code 3899)
 (defconstant new-directory-core-entry-type-code 3861)
 (defconstant initial-fun-core-entry-type-code 3863)

+(defconstant page-table-core-entry-type-code 3880)

 (defconstant end-core-entry-type-code 3840)
 
 (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))
 (defconstant end-core-entry-type-code 3840)
 
 (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))

@@ -2952,17 +3150,17 @@ initially undefined function references:~2%")
   (force-output *core-file*)
   (file-position *core-file*
                  (round-up (file-position *core-file*)
   (force-output *core-file*)
   (file-position *core-file*
                  (round-up (file-position *core-file*)

-                           sb!c:*backend-page-size*)))
+                           sb!c:*backend-page-bytes*)))

 
 (defun output-gspace (gspace)
   (force-output *core-file*)
   (let* ((posn (file-position *core-file*))
          (bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes))
 
 (defun output-gspace (gspace)
   (force-output *core-file*)
   (let* ((posn (file-position *core-file*))
          (bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes))

-         (pages (ceiling bytes sb!c:*backend-page-size*))
-         (total-bytes (* pages sb!c:*backend-page-size*)))
+         (pages (ceiling bytes sb!c:*backend-page-bytes*))
+         (total-bytes (* pages sb!c:*backend-page-bytes*)))

 
     (file-position *core-file*
 
     (file-position *core-file*

-                   (* sb!c:*backend-page-size* (1+ *data-page*)))
+                   (* sb!c:*backend-page-bytes* (1+ *data-page*)))

     (format t
             "writing ~S byte~:P [~S page~:P] from ~S~%"
             total-bytes
     (format t
             "writing ~S byte~:P [~S page~:P] from ~S~%"
             total-bytes

@@ -2978,7 +3176,8 @@ initially undefined function references:~2%")
     ;; 8K).
     (write-bigvec-as-sequence (gspace-bytes gspace)
                               *core-file*
     ;; 8K).
     (write-bigvec-as-sequence (gspace-bytes gspace)
                               *core-file*

-                              :end total-bytes)
+                              :end total-bytes
+                              :pad-with-zeros t)

     (force-output *core-file*)
     (file-position *core-file* posn)
 
     (force-output *core-file*)
     (file-position *core-file* posn)
 

@@ -2992,7 +3191,7 @@ initially undefined function references:~2%")
     (write-word (gspace-free-word-index gspace))
     (write-word *data-page*)
     (multiple-value-bind (floor rem)
     (write-word (gspace-free-word-index gspace))
     (write-word *data-page*)
     (multiple-value-bind (floor rem)

-        (floor (gspace-byte-address gspace) sb!c:*backend-page-size*)
+        (floor (gspace-byte-address gspace) sb!c:*backend-page-bytes*)

       (aver (zerop rem))
       (write-word floor))
     (write-word pages)
       (aver (zerop rem))
       (write-word floor))
     (write-word pages)

@@ -3100,7 +3299,10 @@ initially undefined function references:~2%")
                       symbol-table-file-name
                       core-file-name
                       map-file-name
                       symbol-table-file-name
                       core-file-name
                       map-file-name

-                      c-header-dir-name)
+                      c-header-dir-name
+                      #+nil (list-objects t))
+  #!+sb-dynamic-core
+  (declare (ignorable symbol-table-file-name))

 
   (format t
           "~&beginning GENESIS, ~A~%"
 
   (format t
           "~&beginning GENESIS, ~A~%"

@@ -3114,11 +3316,19 @@ initially undefined function references:~2%")
 
   (let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
 
 
   (let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
 

+    #!-sb-dynamic-core

     (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")))
 
     (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")))
 

+    #!+sb-dynamic-core
+    (progn
+      (setf (gethash (extern-alien-name "undefined_tramp")
+                     *cold-foreign-symbol-table*)
+            (dyncore-note-symbol "undefined_tramp" nil))
+      (dyncore-note-symbol "undefined_alien_function" nil))
+

     ;; Now that we've successfully read our only input file (by
     ;; loading the symbol table, if any), it's a good time to ensure
     ;; that there'll be someplace for our output files to go when
     ;; Now that we've successfully read our only input file (by
     ;; loading the symbol table, if any), it's a good time to ensure
     ;; that there'll be someplace for our output files to go when

@@ -3136,6 +3346,8 @@ initially undefined function references:~2%")
     (do-all-symbols (sym)
       (remprop sym 'cold-intern-info))
 
     (do-all-symbols (sym)
       (remprop sym 'cold-intern-info))
 

+    (check-spaces)
+

     (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0))
            (*load-time-value-counter* 0)
            (*cold-fdefn-objects* (make-hash-table :test 'equal))
     (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0))
            (*load-time-value-counter* 0)
            (*cold-fdefn-objects* (make-hash-table :test 'equal))

@@ -3153,12 +3365,13 @@ initially undefined function references:~2%")
                                      #!-gencgc sb!vm:dynamic-0-space-start))
            (*nil-descriptor* (make-nil-descriptor))
            (*current-reversed-cold-toplevels* *nil-descriptor*)
                                      #!-gencgc sb!vm:dynamic-0-space-start))
            (*nil-descriptor* (make-nil-descriptor))
            (*current-reversed-cold-toplevels* *nil-descriptor*)

+           (*current-debug-sources* *nil-descriptor*)

            (*unbound-marker* (make-other-immediate-descriptor
                               0
                               sb!vm:unbound-marker-widetag))
            *cold-assembler-fixups*
            *cold-assembler-routines*
            (*unbound-marker* (make-other-immediate-descriptor
                               0
                               sb!vm:unbound-marker-widetag))
            *cold-assembler-fixups*
            *cold-assembler-routines*

-           #!+(or x86 x86-64) *load-time-code-fixups*)
+           #!+x86 (*load-time-code-fixups* (make-hash-table)))

 
       ;; Prepare for cold load.
       (initialize-non-nil-symbols)
 
       ;; Prepare for cold load.
       (initialize-non-nil-symbols)

@@ -3211,7 +3424,7 @@ initially undefined function references:~2%")
                    ;; nothing if NAME is NIL.
                    (chill (name)
                      (when name
                    ;; nothing if NAME is NIL.
                    (chill (name)
                      (when name

-                       (cold-intern (intern name package) package))))
+                       (cold-intern (intern name package) :package package))))

             (mapc-on-tree #'chill (sb-cold:package-data-export pd))
             (mapc #'chill (sb-cold:package-data-reexport pd))
             (dolist (sublist (sb-cold:package-data-import-from pd))
             (mapc-on-tree #'chill (sb-cold:package-data-export pd))
             (mapc #'chill (sb-cold:package-data-reexport pd))
             (dolist (sublist (sb-cold:package-data-import-from pd))

@@ -3226,7 +3439,7 @@ initially undefined function references:~2%")
 
       ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
       (resolve-assembler-fixups)
 
       ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
       (resolve-assembler-fixups)

-      #!+(or x86 x86-64) (output-load-time-code-fixups)
+      #!+x86 (output-load-time-code-fixups)

       (foreign-symbols-to-core)
       (finish-symbols)
       (/show "back from FINISH-SYMBOLS")
       (foreign-symbols-to-core)
       (finish-symbols)
       (/show "back from FINISH-SYMBOLS")

@@ -3241,10 +3454,6 @@ initially undefined function references:~2%")
                 (allocate-cold-descriptor *static*
                                           0
                                           sb!vm:even-fixnum-lowtag))
                 (allocate-cold-descriptor *static*
                                           0
                                           sb!vm:even-fixnum-lowtag))

-      (cold-set 'sb!vm:*initial-dynamic-space-free-pointer*
-                (allocate-cold-descriptor *dynamic*
-                                          0
-                                          sb!vm:even-fixnum-lowtag))

       (/show "done setting free pointers")
 
       ;; Write results to files.
       (/show "done setting free pointers")
 
       ;; Write results to files.

@@ -3260,7 +3469,7 @@ initially undefined function references:~2%")
                      (with-open-file (*standard-output* fn
                                       :if-exists :supersede :direction :output)
                        (write-boilerplate)
                      (with-open-file (*standard-output* fn
                                       :if-exists :supersede :direction :output)
                        (write-boilerplate)

-                       (let ((n (substitute #\_ #\- (string-upcase ,name))))
+                       (let ((n (c-name (string-upcase ,name))))

                          (format
                           t
                           "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"
                          (format
                           t
                           "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"

@@ -3269,13 +3478,15 @@ initially undefined function references:~2%")
                        (format t
                         "#endif /* SBCL_GENESIS_~A */~%"
                         (string-upcase ,name))))))
                        (format t
                         "#endif /* SBCL_GENESIS_~A */~%"
                         (string-upcase ,name))))))

-      (when map-file-name
-        (with-open-file (*standard-output* map-file-name
-                                           :direction :output
-                                           :if-exists :supersede)
-          (write-map)))
+        (when map-file-name
+          (with-open-file (*standard-output* map-file-name
+                                             :direction :output
+                                             :if-exists :supersede)
+            (write-map)))

         (out-to "config" (write-config-h))
         (out-to "constants" (write-constants-h))
         (out-to "config" (write-config-h))
         (out-to "constants" (write-constants-h))

+        #!+sb-ldb
+        (out-to "tagnames" (write-tagnames-h))

         (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
                              :key (lambda (obj)
                                     (symbol-name
         (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
                              :key (lambda (obj)
                                     (symbol-name

@@ -3289,12 +3500,22 @@ initially undefined function references:~2%")
                     (format t "~&#include \"~A.h\"~%"
                             (string-downcase
                              (string (sb!vm:primitive-object-name obj)))))))
                     (format t "~&#include \"~A.h\"~%"
                             (string-downcase
                              (string (sb!vm:primitive-object-name obj)))))))

-        (dolist (class '(hash-table layout))
+        (dolist (class '(hash-table
+                         layout
+                         sb!c::compiled-debug-info
+                         sb!c::compiled-debug-fun
+                         sb!xc:package))

           (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))
 
           (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
+        (let ((fn (format nil "~A/Makefile.features" c-header-dir-name)))
+          (ensure-directories-exist fn)
+          (with-open-file (*standard-output* fn :if-exists :supersede
+                                             :direction :output)
+            (write-makefile-features)))
+
+        (when core-file-name

           (write-initial-core-file core-file-name))))))
           (write-initial-core-file core-file-name))))))