1.0.24.42: fix bug 235a

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

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index fc8fed2..ecf2735 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

@@ -850,10 +851,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 +895,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,7 +909,7 @@ 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.
+    ;; Set the CLOS hash value.

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

@@ -916,46 +935,31 @@ core and return a descriptor to it."
     ;; 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.
     ;; 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))))
+    (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.
+          (hash-value
+           (1+ (mod (logxor (logand   (random-layout-clos-hash) 15253)
+                            (logandc2 (random-layout-clos-hash) 15253)
+                            1)
+                    (1- sb!kernel:layout-clos-hash-limit)))))
+      (cold-set-layout-slot result 'clos-hash
+                            (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 'for-std-class-p *nil-descriptor*)

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

@@ -975,17 +979,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 +1001,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 +1108,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

@@ -1234,7 +1225,13 @@ core and return a descriptor to it."
                 offset-wanted))))
     ;; Establish the value of T.
     (let ((t-symbol (cold-intern t)))
                 offset-wanted))))
     ;; Establish the value of T.
     (let ((t-symbol (cold-intern t)))

-      (cold-set t-symbol t-symbol))))
+      (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*)))
+      (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*.
 
 ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
 ;;; to be stored in *!INITIAL-LAYOUTS*.

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

@@ -1292,6 +1280,8 @@ core and return a descriptor to it."
              (symbols (cdr cold-package-symbols-entry))
              (shadows (package-shadowing-symbols cold-package))
              (documentation (base-string-to-core (documentation cold-package t)))
              (symbols (cdr cold-package-symbols-entry))
              (shadows (package-shadowing-symbols cold-package))
              (documentation (base-string-to-core (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 +1323,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 +1338,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

@@ -1363,9 +1360,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 +1391,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)

@@ -1730,32 +1728,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 +1777,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

@@ -1963,7 +1981,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))

@@ -2445,7 +2466,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* ((xrefs (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 +2524,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-xrefs-slot xrefs)

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

@@ -2583,6 +2606,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 +2641,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 +2649,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 +2691,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 +2702,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 +2719,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 +2729,23 @@ 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 "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") 7 :large t)
+              (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8)
+              (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9))))))

     ;; 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,21 +2756,20 @@ 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)
+                  "LU"
+                  nil)
+            constants))

     (setf constants
           (sort constants
                 (lambda (const1 const2)
     (setf constants
           (sort constants
                 (lambda (const1 const2)

@@ -2717,38 +2778,13 @@ core and return a descriptor to it."
                       (< (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,10 +2795,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)))
+                  (c-symbol-name (car current-error))

                   i)))))
   (terpri)
 
                   i)))))
   (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
   ;; platforms. If we export this from the SB!VM package, it gets
   ;; written out as #define trap_PseudoAtomic, which is confusing as
   ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between
   ;; platforms. If we export this from the SB!VM package, it gets
   ;; written out as #define trap_PseudoAtomic, which is confusing as

@@ -2783,45 +2826,45 @@ core and return a descriptor to it."
                     sb!vm::float-sticky-bits
                     sb!vm::float-rounding-mode))
     (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%"
                     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))))
 
 
 
 (defun write-primitive-object (obj)
   ;; writing primitive object layouts
             (sb!xc:mask-field (symbol-value symbol) -1))))
 
 
 
 (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)))
+  (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 (eval (sb!vm:primitive-object-lowtag obj))))
+    (when lowtag
+      (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)))
       (terpri)))

-    (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
+  (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 +2873,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 +2884,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))

@@ -2934,6 +2976,9 @@ 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)
+#!+(and sb-lutex sb-thread)
+(defconstant lutex-table-core-entry-type-code 3887)

 (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 +2997,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

@@ -2992,7 +3037,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)

@@ -3136,6 +3181,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))

@@ -3241,10 +3288,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 +3303,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,11 +3312,11 @@ 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))
         (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
         (out-to "config" (write-config-h))
         (out-to "constants" (write-constants-h))
         (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<

@@ -3289,12 +3332,24 @@ 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))))))

+
+