src/compiler/generic/genesis.lisp

   1 ;;;; "cold" core image builder: This is how we create a target Lisp
   2 ;;;; system from scratch, by converting from fasl files to an image
   3 ;;;; file in the cross-compilation host, without the help of the
   4 ;;;; target Lisp system.
   5 ;;;;
   6 ;;;; As explained by Rob MacLachlan on the CMU CL mailing list Wed, 06
   7 ;;;; Jan 1999 11:05:02 -0500, this cold load generator more or less
   8 ;;;; fakes up static function linking. I.e. it makes sure that all the
   9 ;;;; functions in the fasl files it reads are bound to the
  10 ;;;; corresponding symbols before execution starts. It doesn't do
  11 ;;;; anything to initialize variable values; instead it just arranges
  12 ;;;; for !COLD-INIT to be called at cold load time. !COLD-INIT is
  13 ;;;; responsible for explicitly initializing anything which has to be
  14 ;;;; initialized early before it transfers control to the ordinary
  15 ;;;; top-level forms.
  16
  17 ;;;; This software is part of the SBCL system. See the README file for
  18 ;;;; more information.
  19 ;;;;
  20 ;;;; This software is derived from the CMU CL system, which was
  21 ;;;; written at Carnegie Mellon University and released into the
  22 ;;;; public domain. The software is in the public domain and is
  23 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  24 ;;;; files for more information.
  25
  26 (in-package "SB!IMPL")
  27
  28 ;;; a magic number used to identify our core files
  29 (defconstant core-magic
  30   (logior (ash (char-code #\S) 24)
  31           (ash (char-code #\B) 16)
  32           (ash (char-code #\C) 8)
  33           (char-code #\L)))
  34
  35 ;;; the current version of SBCL core files
  36 ;;;
  37 ;;; FIXME: This is left over from CMU CL, and not well thought out.
  38 ;;; It's good to make sure that the runtime doesn't try to run core
  39 ;;; files from the wrong version, but a single number is not the ideal
  40 ;;; way to do this in high level data like this (as opposed to e.g. in
  41 ;;; IP packets), and in fact the CMU CL version number never ended up
  42 ;;; being incremented past 0. A better approach might be to use a
  43 ;;; string which is set from CVS data.
  44 ;;;
  45 ;;; 0: inherited from CMU CL
  46 ;;; 1: rearranged static symbols for sbcl-0.6.8
  47 (defconstant sbcl-core-version-integer 1)
  48
  49 (defun round-up (number size)
  50   #!+sb-doc
  51   "Round NUMBER up to be an integral multiple of SIZE."
  52   (* size (ceiling number size)))
  53 \f
  54 ;;;; representation of spaces in the core
  55
  56 (defvar *dynamic*)
  57 (defconstant dynamic-space-id 1)
  58
  59 (defvar *static*)
  60 (defconstant static-space-id 2)
  61
  62 (defvar *read-only*)
  63 (defconstant read-only-space-id 3)
  64
  65 (eval-when (:compile-toplevel :execute :load-toplevel)
  66   (defconstant descriptor-low-bits 16
  67     "the number of bits in the low half of the descriptor")
  68   (defconstant target-space-alignment (ash 1 descriptor-low-bits)
  69     "the alignment requirement for spaces in the target.
  70   Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)"))
  71
  72 ;;; a GENESIS-time representation of a memory space (e.g. read-only space,
  73 ;;; dynamic space, or static space)
  74 (defstruct (gspace (:constructor %make-gspace))
  75   ;; name and identifier for this GSPACE
  76   (name (required-argument) :type symbol :read-only t)
  77   (identifier (required-argument) :type fixnum :read-only t)
  78   ;; the word address where the data will be loaded
  79   (word-address (required-argument) :type unsigned-byte :read-only t)
  80   ;; the data themselves. (Note that in CMU CL this was a pair
  81   ;; of fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
  82   (bytes (make-array target-space-alignment :element-type '(unsigned-byte 8))
  83          :type (simple-array (unsigned-byte 8) 1))
  84   ;; the index of the next unwritten word (i.e. chunk of
  85   ;; SB!VM:WORD-BYTES bytes) in BYTES, or equivalently the number of
  86   ;; words actually written in BYTES. In order to convert to an actual
  87   ;; index into BYTES, thus must be multiplied by SB!VM:WORD-BYTES.
  88   (free-word-index 0))
  89
  90 (defun gspace-byte-address (gspace)
  91   (ash (gspace-word-address gspace) sb!vm:word-shift))
  92
  93 (def!method print-object ((gspace gspace) stream)
  94   (print-unreadable-object (gspace stream :type t)
  95     (format stream "~S" (gspace-name gspace))))
  96
  97 (defun make-gspace (name identifier byte-address)
  98   (unless (zerop (rem byte-address target-space-alignment))
  99     (error "The byte address #X~X is not aligned on a #X~X-byte boundary."
 100            byte-address
 101            target-space-alignment))
 102   (%make-gspace :name name
 103                 :identifier identifier
 104                 :word-address (ash byte-address (- sb!vm:word-shift))))
 105
 106 ;;; KLUDGE: Doing it this way seems to partly replicate the
 107 ;;; functionality of Common Lisp adjustable arrays. Is there any way
 108 ;;; to do this stuff in one line of code by using standard Common Lisp
 109 ;;; stuff? -- WHN 19990816
 110 (defun expand-gspace-bytes (gspace)
 111   (let* ((old-bytes (gspace-bytes gspace))
 112          (old-length (length old-bytes))
 113          (new-length (* 2 old-length))
 114          (new-bytes (make-array new-length :element-type '(unsigned-byte 8))))
 115     (replace new-bytes old-bytes :end1 old-length)
 116     (setf (gspace-bytes gspace)
 117           new-bytes))
 118   (values))
 119 \f
 120 ;;;; representation of descriptors
 121
 122 (defstruct (descriptor
 123             (:constructor make-descriptor
 124                           (high low &optional gspace word-offset)))
 125   ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
 126   (gspace nil :type (or gspace null))
 127   ;; the offset in words from the start of GSPACE, or NIL if not set yet
 128   (word-offset nil :type (or (unsigned-byte #.sb!vm:word-bits) null))
 129   ;; the high and low halves of the descriptor KLUDGE: Judging from
 130   ;; the comments in genesis.lisp of the CMU CL old-rt compiler, this
 131   ;; split dates back from a very early version of genesis where
 132   ;; 32-bit integers were represented as conses of two 16-bit
 133   ;; integers. In any system with nice (UNSIGNED-BYTE 32) structure
 134   ;; slots, like CMU CL >= 17 or any version of SBCL, there seems to
 135   ;; be no reason to persist in this. -- WHN 19990917
 136   high low)
 137 (def!method print-object ((des descriptor) stream)
 138   (let ((lowtag (descriptor-lowtag des)))
 139     (print-unreadable-object (des stream :type t)
 140       (cond ((or (= lowtag sb!vm:even-fixnum-type)
 141                  (= lowtag sb!vm:odd-fixnum-type))
 142              (let ((unsigned (logior (ash (descriptor-high des)
 143                                           (1+ (- descriptor-low-bits
 144                                                  sb!vm:lowtag-bits)))
 145                                      (ash (descriptor-low des)
 146                                           (- 1 sb!vm:lowtag-bits)))))
 147                (format stream
 148                        "for fixnum: ~D"
 149                        (if (> unsigned #x1FFFFFFF)
 150                            (- unsigned #x40000000)
 151                            unsigned))))
 152             ((or (= lowtag sb!vm:other-immediate-0-type)
 153                  (= lowtag sb!vm:other-immediate-1-type))
 154              (format stream
 155                      "for other immediate: #X~X, type #b~8,'0B"
 156                      (ash (descriptor-bits des) (- sb!vm:type-bits))
 157                      (logand (descriptor-low des) sb!vm:type-mask)))
 158             (t
 159              (format stream
 160                      "for pointer: #X~X, lowtag #b~3,'0B, ~A"
 161                      (logior (ash (descriptor-high des) descriptor-low-bits)
 162                              (logandc2 (descriptor-low des) sb!vm:lowtag-mask))
 163                      lowtag
 164                      (let ((gspace (descriptor-gspace des)))
 165                        (if gspace
 166                            (gspace-name gspace)
 167                            "unknown"))))))))
 168
 169 (defun allocate-descriptor (gspace length lowtag)
 170   #!+sb-doc
 171   "Return a descriptor for a block of LENGTH bytes out of GSPACE. The free
 172   word index is boosted as necessary, and if additional memory is needed, we
 173   grow the GSPACE. The descriptor returned is a pointer of type LOWTAG."
 174   (let* ((bytes (round-up length (ash 1 sb!vm:lowtag-bits)))
 175          (old-free-word-index (gspace-free-word-index gspace))
 176          (new-free-word-index (+ old-free-word-index
 177                                  (ash bytes (- sb!vm:word-shift)))))
 178     ;; Grow GSPACE as necessary until it's big enough to handle
 179     ;; NEW-FREE-WORD-INDEX.
 180     (do ()
 181         ((>= (length (gspace-bytes gspace))
 182              (* new-free-word-index sb!vm:word-bytes)))
 183       (expand-gspace-bytes gspace))
 184     ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it.
 185     (setf (gspace-free-word-index gspace) new-free-word-index)
 186     (let ((ptr (+ (gspace-word-address gspace) old-free-word-index)))
 187       (make-descriptor (ash ptr (- sb!vm:word-shift descriptor-low-bits))
 188                        (logior (ash (logand ptr
 189                                             (1- (ash 1
 190                                                      (- descriptor-low-bits
 191                                                         sb!vm:word-shift))))
 192                                     sb!vm:word-shift)
 193                                lowtag)
 194                        gspace
 195                        old-free-word-index))))
 196
 197 (defun descriptor-lowtag (des)
 198   #!+sb-doc
 199   "the lowtag bits for DES"
 200   (logand (descriptor-low des) sb!vm:lowtag-mask))
 201
 202 (defun descriptor-bits (des)
 203   (logior (ash (descriptor-high des) descriptor-low-bits)
 204           (descriptor-low des)))
 205
 206 (defun descriptor-fixnum (des)
 207   (let ((bits (descriptor-bits des)))
 208     (if (logbitp (1- sb!vm:word-bits) bits)
 209       ;; KLUDGE: The (- SB!VM:WORD-BITS 2) term here looks right to
 210       ;; me, and it works, but in CMU CL it was (1- SB!VM:WORD-BITS),
 211       ;; and although that doesn't make sense for me, or work for me,
 212       ;; it's hard to see how it could have been wrong, since CMU CL
 213       ;; genesis worked. It would be nice to understand how this came
 214       ;; to be.. -- WHN 19990901
 215       (logior (ash bits -2) (ash -1 (- sb!vm:word-bits 2)))
 216       (ash bits -2))))
 217
 218 ;;; common idioms
 219 (defun descriptor-bytes (des)
 220   (gspace-bytes (descriptor-intuit-gspace des)))
 221 (defun descriptor-byte-offset (des)
 222   (ash (descriptor-word-offset des) sb!vm:word-shift))
 223
 224 ;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise,
 225 ;;; figure out a GSPACE which corresponds to DES, set it into
 226 ;;; (DESCRIPTOR-GSPACE DES), set a consistent value into
 227 ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
 228 (declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace))
 229 (defun descriptor-intuit-gspace (des)
 230   (if (descriptor-gspace des)
 231     (descriptor-gspace des)
 232     ;; KLUDGE: It's not completely clear to me what's going on here;
 233     ;; this is a literal translation from of some rather mysterious
 234     ;; code from CMU CL's DESCRIPTOR-SAP function. Some explanation
 235     ;; would be nice. -- WHN 19990817
 236     (let ((lowtag (descriptor-lowtag des))
 237           (high (descriptor-high des))
 238           (low (descriptor-low des)))
 239       (if (or (eql lowtag sb!vm:function-pointer-type)
 240               (eql lowtag sb!vm:instance-pointer-type)
 241               (eql lowtag sb!vm:list-pointer-type)
 242               (eql lowtag sb!vm:other-pointer-type))
 243         (dolist (gspace (list *dynamic* *static* *read-only*)
 244                         (error "couldn't find a GSPACE for ~S" des))
 245           ;; This code relies on the fact that GSPACEs are aligned such that
 246           ;; the descriptor-low-bits low bits are zero.
 247           (when (and (>= high (ash (gspace-word-address gspace)
 248                                    (- sb!vm:word-shift descriptor-low-bits)))
 249                      (<= high (ash (+ (gspace-word-address gspace)
 250                                       (gspace-free-word-index gspace))
 251                                    (- sb!vm:word-shift descriptor-low-bits))))
 252             (setf (descriptor-gspace des) gspace)
 253             (setf (descriptor-word-offset des)
 254                   (+ (ash (- high (ash (gspace-word-address gspace)
 255                                        (- sb!vm:word-shift
 256                                           descriptor-low-bits)))
 257                           (- descriptor-low-bits sb!vm:word-shift))
 258                      (ash (logandc2 low sb!vm:lowtag-mask)
 259                           (- sb!vm:word-shift))))
 260             (return gspace)))
 261         (error "don't even know how to look for a GSPACE for ~S" des)))))
 262
 263 (defun make-random-descriptor (value)
 264   (make-descriptor (logand (ash value (- descriptor-low-bits))
 265                            (1- (ash 1
 266                                     (- sb!vm:word-bits descriptor-low-bits))))
 267                    (logand value (1- (ash 1 descriptor-low-bits)))))
 268
 269 (defun make-fixnum-descriptor (num)
 270   (when (>= (integer-length num)
 271             (1+ (- sb!vm:word-bits sb!vm:lowtag-bits)))
 272     (error "~D is too big for a fixnum." num))
 273   (make-random-descriptor (ash num (1- sb!vm:lowtag-bits))))
 274
 275 (defun make-other-immediate-descriptor (data type)
 276   (make-descriptor (ash data (- sb!vm:type-bits descriptor-low-bits))
 277                    (logior (logand (ash data (- descriptor-low-bits
 278                                                 sb!vm:type-bits))
 279                                    (1- (ash 1 descriptor-low-bits)))
 280                            type)))
 281
 282 (defun make-character-descriptor (data)
 283   (make-other-immediate-descriptor data sb!vm:base-char-type))
 284
 285 (defun descriptor-beyond (des offset type)
 286   (let* ((low (logior (+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask)
 287                          offset)
 288                       type))
 289          (high (+ (descriptor-high des)
 290                   (ash low (- descriptor-low-bits)))))
 291     (make-descriptor high (logand low (1- (ash 1 descriptor-low-bits))))))
 292 \f
 293 ;;;; miscellaneous variables and other noise
 294
 295 ;;; a numeric value to be returned for undefined foreign symbols, or NIL if
 296 ;;; undefined foreign symbols are to be treated as an error.
 297 ;;; (In the first pass of GENESIS, needed to create a header file before
 298 ;;; the C runtime can be built, various foreign symbols will necessarily
 299 ;;; be undefined, but we don't need actual values for them anyway, and
 300 ;;; we can just use 0 or some other placeholder. In the second pass of
 301 ;;; GENESIS, all foreign symbols should be defined, so any undefined
 302 ;;; foreign symbol is a problem.)
 303 ;;;
 304 ;;; KLUDGE: It would probably be cleaner to rewrite GENESIS so that it
 305 ;;; never tries to look up foreign symbols in the first place unless
 306 ;;; it's actually creating a core file (as in the second pass) instead
 307 ;;; of using this hack to allow it to go through the motions without
 308 ;;; causing an error. -- WHN 20000825
 309 (defvar *foreign-symbol-placeholder-value*)
 310
 311 ;;; a handle on the trap object
 312 (defvar *unbound-marker*)
 313 ;; was:  (make-other-immediate-descriptor 0 sb!vm:unbound-marker-type)
 314
 315 ;;; a handle on the NIL object
 316 (defvar *nil-descriptor*)
 317
 318 ;;; the head of a list of TOPLEVEL-THINGs describing stuff to be done
 319 ;;; when the target Lisp starts up
 320 ;;;
 321 ;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or
 322 ;;; loadtime value, represented by (CONS KEYWORD ..). The FILENAME
 323 ;;; tells which fasl file each list element came from, for debugging
 324 ;;; purposes.
 325 (defvar *current-reversed-cold-toplevels*)
 326
 327 ;;; the name of the object file currently being cold loaded (as a string, not a
 328 ;;; pathname), or NIL if we're not currently cold loading any object file
 329 (defvar *cold-load-filename* nil)
 330 (declaim (type (or string null) *cold-load-filename*))
 331
 332 ;;; This is vestigial support for the CMU CL byte-swapping code. CMU
 333 ;;; CL code tested for whether it needed to swap bytes in GENESIS by
 334 ;;; comparing the byte order of *BACKEND* to the byte order of
 335 ;;; *NATIVE-BACKEND*, a concept which doesn't exist in SBCL. Instead,
 336 ;;; in SBCL byte order swapping would need to be explicitly requested
 337 ;;; with a keyword argument to GENESIS.
 338 ;;;
 339 ;;; I'm not sure whether this is a problem or not, and I don't have a
 340 ;;; machine with different byte order to test to find out for sure.
 341 ;;; The version of the system which is fed to the cross-compiler is
 342 ;;; now written in a subset of Common Lisp which doesn't require
 343 ;;; dumping a lot of things in such a way that machine byte order
 344 ;;; matters. (Mostly this is a matter of not using any specialized
 345 ;;; array type unless there's portable, high-level code to dump it.)
 346 ;;; If it *is* a problem, and you're trying to resurrect this code,
 347 ;;; please test particularly carefully, since I haven't had a chance
 348 ;;; to test the byte-swapping code at all. -- WHN 19990816
 349 ;;;
 350 ;;; When this variable is non-NIL, byte-swapping is enabled wherever
 351 ;;; classic GENESIS would have done it. I.e. the value of this variable
 352 ;;; is the logical complement of
 353 ;;;    (EQ (SB!C:BACKEND-BYTE-ORDER SB!C:*NATIVE-BACKEND*)
 354 ;;;     (SB!C:BACKEND-BYTE-ORDER SB!C:*BACKEND*))
 355 ;;; from CMU CL.
 356 (defvar *genesis-byte-order-swap-p*)
 357 \f
 358 ;;;; miscellaneous stuff to read and write the core memory
 359
 360 ;;; FIXME: should be DEFINE-MODIFY-MACRO
 361 (defmacro cold-push (thing list)
 362   #!+sb-doc
 363   "Push THING onto the given cold-load LIST."
 364   `(setq ,list (cold-cons ,thing ,list)))
 365
 366 (defun maybe-byte-swap (word)
 367   (declare (type (unsigned-byte 32) word))
 368   (assert (= sb!vm:word-bits 32))
 369   (assert (= sb!vm:byte-bits 8))
 370   (if (not *genesis-byte-order-swap-p*)
 371       word
 372       (logior (ash (ldb (byte 8 0) word) 24)
 373               (ash (ldb (byte 8 8) word) 16)
 374               (ash (ldb (byte 8 16) word) 8)
 375               (ldb (byte 8 24) word))))
 376
 377 (defun maybe-byte-swap-short (short)
 378   (declare (type (unsigned-byte 16) short))
 379   (assert (= sb!vm:word-bits 32))
 380   (assert (= sb!vm:byte-bits 8))
 381   (if (not *genesis-byte-order-swap-p*)
 382       short
 383       (logior (ash (ldb (byte 8 0) short) 8)
 384               (ldb (byte 8 8) short))))
 385
 386 ;;; like SAP-REF-32, except that instead of a SAP we use a byte vector
 387 (defun byte-vector-ref-32 (byte-vector byte-index)
 388   (assert (= sb!vm:word-bits 32))
 389   (assert (= sb!vm:byte-bits 8))
 390   (ecase sb!c:*backend-byte-order*
 391     (:little-endian
 392      (logior (ash (aref byte-vector (+ byte-index 0)) 0)
 393              (ash (aref byte-vector (+ byte-index 1)) 8)
 394              (ash (aref byte-vector (+ byte-index 2)) 16)
 395              (ash (aref byte-vector (+ byte-index 3)) 24)))
 396     (:big-endian
 397      (error "stub: no big-endian ports of SBCL (yet?)"))))
 398 (defun (setf byte-vector-ref-32) (new-value byte-vector byte-index)
 399   (assert (= sb!vm:word-bits 32))
 400   (assert (= sb!vm:byte-bits 8))
 401   (ecase sb!c:*backend-byte-order*
 402     (:little-endian
 403      (setf (aref byte-vector (+ byte-index 0)) (ldb (byte 8 0) new-value)
 404            (aref byte-vector (+ byte-index 1)) (ldb (byte 8 8) new-value)
 405            (aref byte-vector (+ byte-index 2)) (ldb (byte 8 16) new-value)
 406            (aref byte-vector (+ byte-index 3)) (ldb (byte 8 24) new-value)))
 407     (:big-endian
 408      (error "stub: no big-endian ports of SBCL (yet?)")))
 409   new-value)
 410
 411 (declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed))
 412 (defun read-wordindexed (address index)
 413   #!+sb-doc
 414   "Return the value which is displaced by INDEX words from ADDRESS."
 415   (let* ((gspace (descriptor-intuit-gspace address))
 416          (bytes (gspace-bytes gspace))
 417          (byte-index (ash (+ index (descriptor-word-offset address))
 418                           sb!vm:word-shift))
 419          ;; KLUDGE: Do we really need to do byte swap here? It seems
 420          ;; as though we shouldn't.. (This attempts to be a literal
 421          ;; translation of CMU CL code, and I don't have a big-endian
 422          ;; machine to test it.) -- WHN 19990817
 423          (value (maybe-byte-swap (byte-vector-ref-32 bytes byte-index))))
 424     (make-random-descriptor value)))
 425
 426 (declaim (ftype (function (descriptor) descriptor) read-memory))
 427 (defun read-memory (address)
 428   #!+sb-doc
 429   "Return the value at ADDRESS."
 430   (read-wordindexed address 0))
 431
 432 ;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS
 433 ;;; value, instead of the SAPINT we use here.)
 434 (declaim (ftype (function (sb!vm:word descriptor) (values)) note-load-time-value-reference))
 435 (defun note-load-time-value-reference (address marker)
 436   (cold-push (cold-cons
 437               (cold-intern :load-time-value-fixup)
 438               (cold-cons (sapint-to-core address)
 439                          (cold-cons
 440                           (number-to-core (descriptor-word-offset marker))
 441                           *nil-descriptor*)))
 442              *current-reversed-cold-toplevels*)
 443   (values))
 444
 445 (declaim (ftype (function (descriptor sb!vm:word descriptor)) write-wordindexed))
 446 (defun write-wordindexed (address index value)
 447   #!+sb-doc
 448   "Write VALUE displaced INDEX words from ADDRESS."
 449   ;; KLUDGE: There is an algorithm (used in DESCRIPTOR-INTUIT-GSPACE)
 450   ;; for calculating the value of the GSPACE slot from scratch. It
 451   ;; doesn't work for all values, only some of them, but mightn't it
 452   ;; be reasonable to see whether it works on VALUE before we give up
 453   ;; because (DESCRIPTOR-GSPACE VALUE) isn't set? (Or failing that,
 454   ;; perhaps write a comment somewhere explaining why it's not a good
 455   ;; idea?) -- WHN 19990817
 456   (if (and (null (descriptor-gspace value))
 457            (not (null (descriptor-word-offset value))))
 458     (note-load-time-value-reference (+ (logandc2 (descriptor-bits address)
 459                                                  sb!vm:lowtag-mask)
 460                                        (ash index sb!vm:word-shift))
 461                                     value)
 462     ;; Note: There's a MAYBE-BYTE-SWAP in here in CMU CL, which I
 463     ;; think is unnecessary now that we're doing the write
 464     ;; byte-by-byte at high level. (I can't test this, though..) --
 465     ;; WHN 19990817
 466     (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
 467            (byte-index (ash (+ index (descriptor-word-offset address))
 468                                sb!vm:word-shift)))
 469       (setf (byte-vector-ref-32 bytes byte-index)
 470             (maybe-byte-swap (descriptor-bits value))))))
 471
 472 (declaim (ftype (function (descriptor descriptor)) write-memory))
 473 (defun write-memory (address value)
 474   #!+sb-doc
 475   "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
 476   (write-wordindexed address 0 value))
 477 \f
 478 ;;;; allocating images of primitive objects in the cold core
 479
 480 ;;; There are three kinds of blocks of memory in the type system:
 481 ;;; * Boxed objects (cons cells, structures, etc): These objects have no
 482 ;;;   header as all slots are descriptors.
 483 ;;; * Unboxed objects (bignums): There is a single header word that contains
 484 ;;;   the length.
 485 ;;; * Vector objects: There is a header word with the type, then a word for
 486 ;;;   the length, then the data.
 487 (defun allocate-boxed-object (gspace length lowtag)
 488   #!+sb-doc
 489   "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
 490   pointing to them."
 491   (allocate-descriptor gspace (ash length sb!vm:word-shift) lowtag))
 492 (defun allocate-unboxed-object (gspace element-bits length type)
 493   #!+sb-doc
 494   "Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and
 495   return an ``other-pointer'' descriptor to them. Initialize the header word
 496   with the resultant length and TYPE."
 497   (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
 498          (des (allocate-descriptor gspace
 499                                    (+ bytes sb!vm:word-bytes)
 500                                    sb!vm:other-pointer-type)))
 501     (write-memory des
 502                   (make-other-immediate-descriptor (ash bytes
 503                                                         (- sb!vm:word-shift))
 504                                                    type))
 505     des))
 506 (defun allocate-vector-object (gspace element-bits length type)
 507   #!+sb-doc
 508   "Allocate LENGTH units of ELEMENT-BITS size plus a header plus a length slot in
 509   GSPACE and return an ``other-pointer'' descriptor to them. Initialize the
 510   header word with TYPE and the length slot with LENGTH."
 511   ;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using
 512   ;; #'/ instead of #'CEILING, which seems wrong.
 513   (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
 514          (des (allocate-descriptor gspace (+ bytes (* 2 sb!vm:word-bytes))
 515                                           sb!vm:other-pointer-type)))
 516     (write-memory des (make-other-immediate-descriptor 0 type))
 517     (write-wordindexed des
 518                        sb!vm:vector-length-slot
 519                        (make-fixnum-descriptor length))
 520     des))
 521 \f
 522 ;;;; copying simple objects into the cold core
 523
 524 (defun string-to-core (string &optional (gspace *dynamic*))
 525   #!+sb-doc
 526   "Copy string into the cold core and return a descriptor to it."
 527   ;; (Remember that the system convention for storage of strings leaves an
 528   ;; extra null byte at the end to aid in call-out to C.)
 529   (let* ((length (length string))
 530          (des (allocate-vector-object gspace
 531                                       sb!vm:byte-bits
 532                                       (1+ length)
 533                                       sb!vm:simple-string-type))
 534          (bytes (gspace-bytes gspace))
 535          (offset (+ (* sb!vm:vector-data-offset sb!vm:word-bytes)
 536                     (descriptor-byte-offset des))))
 537     (write-wordindexed des
 538                        sb!vm:vector-length-slot
 539                        (make-fixnum-descriptor length))
 540     (dotimes (i length)
 541       (setf (aref bytes (+ offset i))
 542             ;; KLUDGE: There's no guarantee that the character
 543             ;; encoding here will be the same as the character
 544             ;; encoding on the target machine, so using CHAR-CODE as
 545             ;; we do, or a bitwise copy as CMU CL code did, is sleazy.
 546             ;; (To make this more portable, perhaps we could use
 547             ;; indices into the sequence which is used to test whether
 548             ;; a character is a STANDARD-CHAR?) -- WHN 19990817
 549             (char-code (aref string i))))
 550     (setf (aref bytes (+ offset length))
 551           0) ; null string-termination character for C
 552     des))
 553
 554 (defun bignum-to-core (n)
 555   #!+sb-doc
 556   "Copy a bignum to the cold core."
 557   (let* ((words (ceiling (1+ (integer-length n)) sb!vm:word-bits))
 558          (handle (allocate-unboxed-object *dynamic*
 559                                           sb!vm:word-bits
 560                                           words
 561                                           sb!vm:bignum-type)))
 562     (declare (fixnum words))
 563     (do ((index 1 (1+ index))
 564          (remainder n (ash remainder (- sb!vm:word-bits))))
 565         ((> index words)
 566          (unless (zerop (integer-length remainder))
 567            ;; FIXME: Shouldn't this be a fatal error?
 568            (warn "~D words of ~D were written, but ~D bits were left over."
 569                  words n remainder)))
 570       (let ((word (ldb (byte sb!vm:word-bits 0) remainder)))
 571         (write-wordindexed handle index
 572                            (make-descriptor (ash word (- descriptor-low-bits))
 573                                             (ldb (byte descriptor-low-bits 0)
 574                                                  word)))))
 575     handle))
 576
 577 (defun number-pair-to-core (first second type)
 578   #!+sb-doc
 579   "Makes a number pair of TYPE (ratio or complex) and fills it in."
 580   (let ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits 2 type)))
 581     (write-wordindexed des 1 first)
 582     (write-wordindexed des 2 second)
 583     des))
 584
 585 (defun float-to-core (x)
 586   (etypecase x
 587     (single-float
 588      (let ((des (allocate-unboxed-object *dynamic*
 589                                          sb!vm:word-bits
 590                                          (1- sb!vm:single-float-size)
 591                                          sb!vm:single-float-type)))
 592        (write-wordindexed des
 593                           sb!vm:single-float-value-slot
 594                           (make-random-descriptor (single-float-bits x)))
 595        des))
 596     (double-float
 597      (let ((des (allocate-unboxed-object *dynamic*
 598                                          sb!vm:word-bits
 599                                          (1- sb!vm:double-float-size)
 600                                          sb!vm:double-float-type))
 601            (high-bits (make-random-descriptor (double-float-high-bits x)))
 602            (low-bits (make-random-descriptor (double-float-low-bits x))))
 603        (ecase sb!c:*backend-byte-order*
 604          (:little-endian
 605           (write-wordindexed des sb!vm:double-float-value-slot low-bits)
 606           (write-wordindexed des (1+ sb!vm:double-float-value-slot) high-bits))
 607          (:big-endian
 608           (write-wordindexed des sb!vm:double-float-value-slot high-bits)
 609           (write-wordindexed des (1+ sb!vm:double-float-value-slot) low-bits)))
 610        des))
 611     #!+(and long-float x86)
 612     (long-float
 613      (let ((des (allocate-unboxed-object *dynamic*
 614                                          sb!vm:word-bits
 615                                          (1- sb!vm:long-float-size)
 616                                          sb!vm:long-float-type))
 617            (exp-bits (make-random-descriptor (long-float-exp-bits x)))
 618            (high-bits (make-random-descriptor (long-float-high-bits x)))
 619            (low-bits (make-random-descriptor (long-float-low-bits x))))
 620        (ecase sb!c:*backend-byte-order*
 621          (:little-endian
 622           (write-wordindexed des sb!vm:long-float-value-slot low-bits)
 623           (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits)
 624           (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits))
 625          (:big-endian
 626           (error "LONG-FLOAT is not supported for big-endian byte order.")))
 627        des))))
 628
 629 (defun complex-single-float-to-core (num)
 630   (declare (type (complex single-float) num))
 631   (let ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
 632                                       (1- sb!vm:complex-single-float-size)
 633                                       sb!vm:complex-single-float-type)))
 634     (write-wordindexed des sb!vm:complex-single-float-real-slot
 635                    (make-random-descriptor (single-float-bits (realpart num))))
 636     (write-wordindexed des sb!vm:complex-single-float-imag-slot
 637                    (make-random-descriptor (single-float-bits (imagpart num))))
 638     des))
 639
 640 (defun complex-double-float-to-core (num)
 641   (declare (type (complex double-float) num))
 642   (let ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
 643                                       (1- sb!vm:complex-double-float-size)
 644                                       sb!vm:complex-double-float-type)))
 645     (let* ((real (realpart num))
 646            (high-bits (make-random-descriptor (double-float-high-bits real)))
 647            (low-bits (make-random-descriptor (double-float-low-bits real))))
 648       (ecase sb!c:*backend-byte-order*
 649         (:little-endian
 650          (write-wordindexed des sb!vm:complex-double-float-real-slot low-bits)
 651          (write-wordindexed des (1+ sb!vm:complex-double-float-real-slot) high-bits))
 652         (:big-endian
 653          (write-wordindexed des sb!vm:complex-double-float-real-slot high-bits)
 654          (write-wordindexed des (1+ sb!vm:complex-double-float-real-slot) low-bits))))
 655     (let* ((imag (imagpart num))
 656            (high-bits (make-random-descriptor (double-float-high-bits imag)))
 657            (low-bits (make-random-descriptor (double-float-low-bits imag))))
 658       (ecase sb!c:*backend-byte-order*
 659         (:little-endian
 660          (write-wordindexed des sb!vm:complex-double-float-imag-slot low-bits)
 661          (write-wordindexed des (1+ sb!vm:complex-double-float-imag-slot) high-bits))
 662         (:big-endian
 663          (write-wordindexed des sb!vm:complex-double-float-imag-slot high-bits)
 664          (write-wordindexed des (1+ sb!vm:complex-double-float-imag-slot) low-bits))))
 665     des))
 666
 667 (defun number-to-core (number)
 668   #!+sb-doc
 669   "Copy the given number to the core, or flame out if we can't deal with it."
 670   (typecase number
 671     (integer (if (< (integer-length number) 30)
 672                  (make-fixnum-descriptor number)
 673                  (bignum-to-core number)))
 674     (ratio (number-pair-to-core (number-to-core (numerator number))
 675                                 (number-to-core (denominator number))
 676                                 sb!vm:ratio-type))
 677     ((complex single-float) (complex-single-float-to-core number))
 678     ((complex double-float) (complex-double-float-to-core number))
 679     #!+long-float
 680     ((complex long-float)
 681      (error "~S isn't a cold-loadable number at all!" number))
 682     (complex (number-pair-to-core (number-to-core (realpart number))
 683                                   (number-to-core (imagpart number))
 684                                   sb!vm:complex-type))
 685     (float (float-to-core number))
 686     (t (error "~S isn't a cold-loadable number at all!" number))))
 687
 688 (declaim (ftype (function (sb!vm:word) descriptor) sap-to-core))
 689 (defun sapint-to-core (sapint)
 690   (let ((des (allocate-unboxed-object *dynamic*
 691                                       sb!vm:word-bits
 692                                       (1- sb!vm:sap-size)
 693                                       sb!vm:sap-type)))
 694     (write-wordindexed des
 695                        sb!vm:sap-pointer-slot
 696                        (make-random-descriptor sapint))
 697     des))
 698
 699 ;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
 700 (defun cold-cons (car cdr &optional (gspace *dynamic*))
 701   (let ((dest (allocate-boxed-object gspace 2 sb!vm:list-pointer-type)))
 702     (write-memory dest car)
 703     (write-wordindexed dest 1 cdr)
 704     dest))
 705
 706 ;;; Make a simple-vector that holds the specified OBJECTS, and return its
 707 ;;; descriptor.
 708 (defun vector-in-core (&rest objects)
 709   (let* ((size (length objects))
 710          (result (allocate-vector-object *dynamic* sb!vm:word-bits size
 711                                          sb!vm:simple-vector-type)))
 712     (dotimes (index size)
 713       (write-wordindexed result (+ index sb!vm:vector-data-offset)
 714                          (pop objects)))
 715     result))
 716 \f
 717 ;;;; symbol magic
 718
 719 ;;; FIXME: This should be a keyword argument of ALLOCATE-SYMBOL.
 720 (defvar *cold-symbol-allocation-gspace* nil)
 721
 722 ;;; Allocate (and initialize) a symbol.
 723 (defun allocate-symbol (name)
 724   (declare (simple-string name))
 725   (let ((symbol (allocate-unboxed-object (or *cold-symbol-allocation-gspace*
 726                                              *dynamic*)
 727                                          sb!vm:word-bits
 728                                          (1- sb!vm:symbol-size)
 729                                          sb!vm:symbol-header-type)))
 730     (write-wordindexed symbol sb!vm:symbol-value-slot *unbound-marker*)
 731     #!+x86
 732     (write-wordindexed symbol
 733                        sb!vm:symbol-hash-slot
 734                        (make-fixnum-descriptor
 735                         (1+ (random sb!vm:*target-most-positive-fixnum*))))
 736     (write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*)
 737     (write-wordindexed symbol sb!vm:symbol-name-slot
 738                        (string-to-core name *dynamic*))
 739     (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
 740     symbol))
 741
 742 ;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a
 743 ;;; descriptor of a cold symbol or (in an abbreviation for the
 744 ;;; most common usage pattern) an ordinary symbol, which will be
 745 ;;; automatically cold-interned.
 746 (declaim (ftype (function ((or descriptor symbol) descriptor)) cold-set))
 747 (defun cold-set (symbol-or-symbol-des value)
 748   (let ((symbol-des (etypecase symbol-or-symbol-des
 749                       (descriptor symbol-or-symbol-des)
 750                       (symbol (cold-intern symbol-or-symbol-des)))))
 751     (write-wordindexed symbol-des sb!vm:symbol-value-slot value)))
 752 \f
 753 ;;;; layouts and type system pre-initialization
 754
 755 ;;; Since we want to be able to dump structure constants and
 756 ;;; predicates with reference layouts, we need to create layouts at
 757 ;;; cold-load time. We use the name to intern layouts by, and dump a
 758 ;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system
 759 ;;; initialization can find them. The only thing that's tricky [sic --
 760 ;;; WHN 19990816] is initializing layout's layout, which must point to
 761 ;;; itself.
 762
 763 ;;; a map from class names to lists of
 764 ;;;    `(,descriptor ,name ,length ,inherits ,depth)
 765 ;;; KLUDGE: It would be more understandable and maintainable to use
 766 ;;; DEFSTRUCT (:TYPE LIST) here. -- WHN 19990823
 767 (defvar *cold-layouts* (make-hash-table :test 'equal))
 768
 769 ;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting
 770 ;;; mapping
 771 (defvar *cold-layout-names* (make-hash-table :test 'eql))
 772
 773 ;;; FIXME: *COLD-LAYOUTS* and *COLD-LAYOUT-NAMES* should be
 774 ;;; initialized by binding in GENESIS.
 775
 776 ;;; the descriptor for layout's layout (needed when making layouts)
 777 (defvar *layout-layout*)
 778
 779 ;;; FIXME: This information should probably be pulled out of the
 780 ;;; cross-compiler's tables at genesis time instead of inserted by
 781 ;;; hand here as a bare numeric constant.
 782 (defconstant target-layout-length 16)
 783
 784 ;;; Return a list of names created from the cold layout INHERITS data
 785 ;;; in X.
 786 (defun listify-cold-inherits (x)
 787   (let ((len (descriptor-fixnum (read-wordindexed x
 788                                                   sb!vm:vector-length-slot))))
 789     (collect ((res))
 790       (dotimes (index len)
 791         (let* ((des (read-wordindexed x (+ sb!vm:vector-data-offset index)))
 792                (found (gethash (descriptor-bits des) *cold-layout-names*)))
 793           (if found
 794             (res found)
 795             (error "unknown descriptor at index ~S (bits = ~8,'0X)"
 796                    index
 797                    (descriptor-bits des)))))
 798       (res))))
 799
 800 (declaim (ftype (function (symbol descriptor descriptor descriptor) descriptor)
 801                 make-cold-layout))
 802 (defun make-cold-layout (name length inherits depthoid)
 803   (let ((result (allocate-boxed-object *dynamic*
 804                                        ;; KLUDGE: Why 1+? -- WHN 19990901
 805                                        (1+ target-layout-length)
 806                                        sb!vm:instance-pointer-type)))
 807     (write-memory result
 808                   (make-other-immediate-descriptor target-layout-length
 809                                                    sb!vm:instance-header-type))
 810
 811     ;; KLUDGE: The offsets into LAYOUT below should probably be pulled out
 812     ;; of the cross-compiler's tables at genesis time instead of inserted
 813     ;; by hand as bare numeric constants. -- WHN ca. 19990901
 814
 815     ;; Set slot 0 = the layout of the layout.
 816     (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*)
 817
 818     ;; Set the immediately following slots = CLOS hash values.
 819     ;;
 820     ;; Note: CMU CL didn't set these in genesis, but instead arranged
 821     ;; for them to be set at cold init time. That resulted in slightly
 822     ;; kludgy-looking code, but there were at least two things to be
 823     ;; said for it:
 824     ;;   1. It put the hash values under the control of the target Lisp's
 825     ;;      RANDOM function, so that CLOS behavior would be nearly
 826     ;;      deterministic (instead of depending on the implementation of
 827     ;;      RANDOM in the cross-compilation host, and the state of its
 828     ;;      RNG when genesis begins).
 829     ;;   2. It automatically ensured that all hash values in the target Lisp
 830     ;;      were part of the same sequence, so that we didn't have to worry
 831     ;;      about the possibility of the first hash value set in genesis
 832     ;;      being precisely equal to the some hash value set in cold init time
 833     ;;      (because the target Lisp RNG has advanced to precisely the same
 834     ;;      state that the host Lisp RNG was in earlier).
 835     ;; Point 1 should not be an issue in practice because of the way we do our
 836     ;; build procedure in two steps, so that the SBCL that we end up with has
 837     ;; been created by another SBCL (whose RNG is under our control).
 838     ;; Point 2 is more of an issue. If ANSI had provided a way to feed
 839     ;; entropy into an RNG, we would have no problem: we'd just feed
 840     ;; some specialized genesis-time-only pattern into the RNG state
 841     ;; before using it. However, they didn't, so we have a slight
 842     ;; problem. We address it by generating the hash values using a
 843     ;; different algorithm than we use in ordinary operation.
 844     (dotimes (i sb!kernel:layout-clos-hash-length)
 845       (let (;; The expression here is pretty arbitrary, we just want
 846             ;; to make sure that it's not something which is (1)
 847             ;; evenly distributed and (2) not foreordained to arise in
 848             ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence
 849             ;; and show up as the CLOS-HASH value of some other
 850             ;; LAYOUT.
 851             ;;
 852             ;; FIXME: This expression here can generate a zero value,
 853             ;; and the CMU CL code goes out of its way to generate
 854             ;; strictly positive values (even though the field is
 855             ;; declared as an INDEX). Check that it's really OK to
 856             ;; have zero values in the CLOS-HASH slots.
 857             (hash-value (mod (logxor (logand   (random-layout-clos-hash) 15253)
 858                                      (logandc2 (random-layout-clos-hash) 15253)
 859                                      1)
 860                              ;; (The MOD here is defensive programming
 861                              ;; to make sure we never write an
 862                              ;; out-of-range value even if some joker
 863                              ;; sets LAYOUT-CLOS-HASH-MAX to other
 864                              ;; than 2^n-1 at some time in the
 865                              ;; future.)
 866                              (1+ sb!kernel:layout-clos-hash-max))))
 867         (write-wordindexed result
 868                            (+ i sb!vm:instance-slots-offset 1)
 869                            (make-fixnum-descriptor hash-value))))
 870
 871     ;; Set other slot values.
 872     (let ((base (+ sb!vm:instance-slots-offset
 873                    sb!kernel:layout-clos-hash-length
 874                    1)))
 875       ;; (Offset 0 is CLASS, "the class this is a layout for", which
 876       ;; is uninitialized at this point.)
 877       (write-wordindexed result (+ base 1) *nil-descriptor*) ; marked invalid
 878       (write-wordindexed result (+ base 2) inherits)
 879       (write-wordindexed result (+ base 3) depthoid)
 880       (write-wordindexed result (+ base 4) length)
 881       (write-wordindexed result (+ base 5) *nil-descriptor*) ; info
 882       (write-wordindexed result (+ base 6) *nil-descriptor*)) ; pure
 883
 884     (setf (gethash name *cold-layouts*)
 885           (list result
 886                 name
 887                 (descriptor-fixnum length)
 888                 (listify-cold-inherits inherits)
 889                 (descriptor-fixnum depthoid)))
 890     (setf (gethash (descriptor-bits result) *cold-layout-names*) name)
 891
 892     result))
 893
 894 (defun initialize-layouts ()
 895
 896   (clrhash *cold-layouts*)
 897
 898   ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and
 899   ;; #() as INHERITS,
 900   (setq *layout-layout* *nil-descriptor*)
 901   (setq *layout-layout*
 902         (make-cold-layout 'layout
 903                           (number-to-core target-layout-length)
 904                           (vector-in-core)
 905                           ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT..
 906                           (number-to-core 4)))
 907   (write-wordindexed *layout-layout*
 908                      sb!vm:instance-slots-offset
 909                      *layout-layout*)
 910
 911   ;; Then we create the layouts that we'll need to make a correct INHERITS
 912   ;; vector for the layout of LAYOUT itself..
 913   ;;
 914   ;; FIXME: The various LENGTH and DEPTHOID numbers should be taken from
 915   ;; the compiler's tables, not set by hand.
 916   (let* ((t-layout
 917           (make-cold-layout 't
 918                             (number-to-core 0)
 919                             (vector-in-core)
 920                             (number-to-core 0)))
 921          (i-layout
 922           (make-cold-layout 'instance
 923                             (number-to-core 0)
 924                             (vector-in-core t-layout)
 925                             (number-to-core 1)))
 926          (so-layout
 927           (make-cold-layout 'structure-object
 928                             (number-to-core 1)
 929                             (vector-in-core t-layout i-layout)
 930                             (number-to-core 2)))
 931          (bso-layout
 932           (make-cold-layout 'structure!object
 933                             (number-to-core 1)
 934                             (vector-in-core t-layout i-layout so-layout)
 935                             (number-to-core 3)))
 936          (layout-inherits (vector-in-core t-layout
 937                                           i-layout
 938                                           so-layout
 939                                           bso-layout)))
 940
 941     ;; ..and return to backpatch the layout of LAYOUT.
 942     (setf (fourth (gethash 'layout *cold-layouts*))
 943           (listify-cold-inherits layout-inherits))
 944     (write-wordindexed *layout-layout*
 945                        ;; FIXME: hardcoded offset into layout struct
 946                        (+ sb!vm:instance-slots-offset
 947                           layout-clos-hash-length
 948                           1
 949                           2)
 950                        layout-inherits)))
 951 \f
 952 ;;;; interning symbols in the cold image
 953
 954 ;;; In order to avoid having to know about the package format, we
 955 ;;; build a data structure in *COLD-PACKAGE-SYMBOLS* that holds all
 956 ;;; interned symbols along with info about their packages. The data
 957 ;;; structure is a list of sublists, where the sublists have the
 958 ;;; following format:
 959 ;;;   (<make-package-arglist>
 960 ;;;    <internal-symbols>
 961 ;;;    <external-symbols>
 962 ;;;    <imported-internal-symbols>
 963 ;;;    <imported-external-symbols>
 964 ;;;    <shadowing-symbols>)
 965 ;;;
 966 ;;; KLUDGE: It would be nice to implement the sublists as instances of
 967 ;;; a DEFSTRUCT (:TYPE LIST). (They'd still be lists, but at least we'd be
 968 ;;; using mnemonically-named operators to access them, instead of trying
 969 ;;; to remember what THIRD and FIFTH mean, and hoping that we never
 970 ;;; need to change the list layout..) -- WHN 19990825
 971
 972 ;;; an alist from packages to lists of that package's symbols to be dumped
 973 (defvar *cold-package-symbols*)
 974 (declaim (type list *cold-package-symbols*))
 975
 976 ;;; a map from descriptors to symbols, so that we can back up. The key is the
 977 ;;; address in the target core.
 978 (defvar *cold-symbols*)
 979 (declaim (type hash-table *cold-symbols*))
 980
 981 ;;; Return a handle on an interned symbol. If necessary allocate the
 982 ;;; symbol and record which package the symbol was referenced in. When
 983 ;;; we allocate the symbol, make sure we record a reference to the
 984 ;;; symbol in the home package so that the package gets set.
 985 (defun cold-intern (symbol &optional (package (symbol-package symbol)))
 986
 987   ;; Anything on the cross-compilation host which refers to the target
 988   ;; machinery through the host SB-XC package can be translated to
 989   ;; something on the target which refers to the same machinery
 990   ;; through the target COMMON-LISP package.
 991   (let ((p (find-package "SB-XC")))
 992     (when (eq package p)
 993       (setf package *cl-package*))
 994     (when (eq (symbol-package symbol) p)
 995       (setf symbol (intern (symbol-name symbol) *cl-package*))))
 996
 997   (let (;; Information about each cold-interned symbol is stored
 998         ;; in COLD-INTERN-INFO.
 999         ;;   (CAR COLD-INTERN-INFO) = descriptor of symbol
1000         ;;   (CDR COLD-INTERN-INFO) = list of packages, other than symbol's
1001         ;;                          own package, referring to symbol
1002         ;; (*COLD-PACKAGE-SYMBOLS* and *COLD-SYMBOLS* store basically the same
1003         ;; information, but with the mapping running the opposite way.)
1004         (cold-intern-info (get symbol 'cold-intern-info)))
1005     (unless cold-intern-info
1006       (cond ((eq (symbol-package symbol) package)
1007              (let ((handle (allocate-symbol (symbol-name symbol))))
1008                (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
1009                (when (eq package *keyword-package*)
1010                  (cold-set handle handle))
1011                (setq cold-intern-info
1012                      (setf (get symbol 'cold-intern-info) (cons handle nil)))))
1013             (t
1014              (cold-intern symbol)
1015              (setq cold-intern-info (get symbol 'cold-intern-info)))))
1016     (unless (or (null package)
1017                 (member package (cdr cold-intern-info)))
1018       (push package (cdr cold-intern-info))
1019       (let* ((old-cps-entry (assoc package *cold-package-symbols*))
1020              (cps-entry (or old-cps-entry
1021                             (car (push (list package)
1022                                        *cold-package-symbols*)))))
1023         (unless old-cps-entry
1024           (/show "created *COLD-PACKAGE-SYMBOLS* entry for" package symbol))
1025         (push symbol (rest cps-entry))))
1026     (car cold-intern-info)))
1027
1028 ;;; Construct and return a value for use as *NIL-DESCRIPTOR*.
1029 (defun make-nil-descriptor ()
1030   (let* ((des (allocate-unboxed-object
1031                *static*
1032                sb!vm:word-bits
1033                sb!vm:symbol-size
1034                0))
1035          (result (make-descriptor (descriptor-high des)
1036                                   (+ (descriptor-low des)
1037                                      (* 2 sb!vm:word-bytes)
1038                                      (- sb!vm:list-pointer-type
1039                                         sb!vm:other-pointer-type)))))
1040     (write-wordindexed des
1041                        1
1042                        (make-other-immediate-descriptor
1043                         0
1044                         sb!vm:symbol-header-type))
1045     (write-wordindexed des
1046                        (+ 1 sb!vm:symbol-value-slot)
1047                        result)
1048     (write-wordindexed des
1049                        (+ 2 sb!vm:symbol-value-slot)
1050                        result)
1051     (write-wordindexed des
1052                        (+ 1 sb!vm:symbol-plist-slot)
1053                        result)
1054     (write-wordindexed des
1055                        (+ 1 sb!vm:symbol-name-slot)
1056                        ;; This is *DYNAMIC*, and DES is *STATIC*,
1057                        ;; because that's the way CMU CL did it; I'm
1058                        ;; not sure whether there's an underlying
1059                        ;; reason. -- WHN 1990826
1060                        (string-to-core "NIL" *dynamic*))
1061     (write-wordindexed des
1062                        (+ 1 sb!vm:symbol-package-slot)
1063                        result)
1064     (setf (get nil 'cold-intern-info)
1065           (cons result nil))
1066     (cold-intern nil)
1067     result))
1068
1069 ;;; Since the initial symbols must be allocated before we can intern
1070 ;;; anything else, we intern those here. We also set the value of T.
1071 (defun initialize-non-nil-symbols ()
1072   #!+sb-doc
1073   "Initialize the cold load symbol-hacking data structures."
1074   (let ((*cold-symbol-allocation-gspace* *static*))
1075     ;; Intern the others.
1076     (dolist (symbol sb!vm:*static-symbols*)
1077       (let* ((des (cold-intern symbol))
1078              (offset-wanted (sb!vm:static-symbol-offset symbol))
1079              (offset-found (- (descriptor-low des)
1080                               (descriptor-low *nil-descriptor*))))
1081         (unless (= offset-wanted offset-found)
1082           ;; FIXME: should be fatal
1083           (warn "Offset from ~S to ~S is ~D, not ~D"
1084                 symbol
1085                 nil
1086                 offset-found
1087                 offset-wanted))))
1088     ;; Establish the value of T.
1089     (let ((t-symbol (cold-intern t)))
1090       (cold-set t-symbol t-symbol))))
1091
1092 ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
1093 ;;; to be stored in *!INITIAL-LAYOUTS*.
1094 (defun cold-list-all-layouts ()
1095   (let ((result *nil-descriptor*))
1096     (maphash (lambda (key stuff)
1097                (cold-push (cold-cons (cold-intern key)
1098                                      (first stuff))
1099                           result))
1100              *cold-layouts*)
1101     result))
1102
1103 ;;; Establish initial values for magic symbols.
1104 ;;;
1105 ;;; Scan over all the symbols referenced in each package in
1106 ;;; *COLD-PACKAGE-SYMBOLS* making that for each one there's an
1107 ;;; appropriate entry in the *!INITIAL-SYMBOLS* data structure to
1108 ;;; intern it.
1109 (defun finish-symbols ()
1110
1111   ;; FIXME: Why use SETQ (setting symbol value) instead of just using
1112   ;; the function values for these things?? I.e. why do we need this
1113   ;; section at all? Is it because all the FDEFINITION stuff gets in
1114   ;; the way of reading function values and is too hairy to rely on at
1115   ;; cold boot? FIXME: 5/6 of these are in *STATIC-SYMBOLS* in
1116   ;; parms.lisp, but %HANDLE-FUNCTION-END-BREAKPOINT is not. Why?
1117   ;; Explain.
1118   (macrolet ((frob (symbol)
1119                `(cold-set ',symbol
1120                           (cold-fdefinition-object (cold-intern ',symbol)))))
1121     (frob !cold-init)
1122     (frob sb!impl::maybe-gc)
1123     (frob internal-error)
1124     (frob sb!di::handle-breakpoint)
1125     (frob sb!di::handle-function-end-breakpoint)
1126     (frob sb!impl::fdefinition-object))
1127
1128   (cold-set '*current-catch-block*          (make-fixnum-descriptor 0))
1129   (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0))
1130   (cold-set '*eval-stack-top*               (make-fixnum-descriptor 0))
1131
1132   (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0))
1133
1134   ;; FIXME: *!INITIAL-LAYOUTS* should be exported from SB!KERNEL, or
1135   ;; perhaps from SB-LD.
1136   (cold-set 'sb!kernel::*!initial-layouts* (cold-list-all-layouts))
1137
1138   (/show "dumping packages" (mapcar #'car *cold-package-symbols*))
1139   (let ((initial-symbols *nil-descriptor*))
1140     (dolist (cold-package-symbols-entry *cold-package-symbols*)
1141       (let* ((cold-package (car cold-package-symbols-entry))
1142              (symbols (cdr cold-package-symbols-entry))
1143              (shadows (package-shadowing-symbols cold-package))
1144              (internal *nil-descriptor*)
1145              (external *nil-descriptor*)
1146              (imported-internal *nil-descriptor*)
1147              (imported-external *nil-descriptor*)
1148              (shadowing *nil-descriptor*))
1149         (/show "dumping" cold-package symbols)
1150
1151         ;; FIXME: Add assertions here to make sure that inappropriate stuff
1152         ;; isn't being dumped:
1153         ;;   * the CL-USER package
1154         ;;   * the SB-COLD package
1155         ;;   * any internal symbols in the CL package
1156         ;;   * basically any package other than CL, KEYWORD, or the packages
1157         ;;     in package-data-list.lisp-expr
1158         ;; and that the structure of the KEYWORD package (e.g. whether
1159         ;; any symbols are internal to it) matches what we want in the
1160         ;; target SBCL.
1161
1162         ;; FIXME: It seems possible that by looking at the contents of
1163         ;; packages in the target SBCL we could find which symbols in
1164         ;; package-data-lisp.lisp-expr are now obsolete. (If I
1165         ;; understand correctly, only symbols which actually have
1166         ;; definitions or which are otherwise referred to actually end
1167         ;; up in the target packages.)
1168
1169         (dolist (symbol symbols)
1170           (let ((handle (car (get symbol 'cold-intern-info)))
1171                 (imported-p (not (eq (symbol-package symbol) cold-package))))
1172             (multiple-value-bind (found where)
1173                 (find-symbol (symbol-name symbol) cold-package)
1174               (unless (and where (eq found symbol))
1175                 (error "The symbol ~S is not available in ~S."
1176                        symbol
1177                        cold-package))
1178               (when (memq symbol shadows)
1179                 (cold-push handle shadowing))
1180               (case where
1181                 (:internal (if imported-p
1182                                (cold-push handle imported-internal)
1183                                (cold-push handle internal)))
1184                 (:external (if imported-p
1185                                (cold-push handle imported-external)
1186                                (cold-push handle external)))))))
1187         (let ((r *nil-descriptor*))
1188           (cold-push shadowing r)
1189           (cold-push imported-external r)
1190           (cold-push imported-internal r)
1191           (cold-push external r)
1192           (cold-push internal r)
1193           (cold-push (make-make-package-args cold-package) r)
1194           ;; FIXME: It would be more space-efficient to use vectors
1195           ;; instead of lists here, and space-efficiency here would be
1196           ;; nice, since it would reduce the peak memory usage in
1197           ;; genesis and cold init.
1198           (cold-push r initial-symbols))))
1199     (cold-set '*!initial-symbols* initial-symbols))
1200
1201   (cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
1202
1203   (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
1204
1205   #!+x86
1206   (progn
1207     (cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0))
1208     (cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0))
1209     (cold-set 'sb!vm::*fp-constant-0s0* (number-to-core 0s0))
1210     (cold-set 'sb!vm::*fp-constant-1s0* (number-to-core 1s0))
1211     #!+long-float
1212     (progn
1213       (cold-set 'sb!vm::*fp-constant-0l0* (number-to-core 0L0))
1214       (cold-set 'sb!vm::*fp-constant-1l0* (number-to-core 1L0))
1215       ;; FIXME: Why is initialization of PI conditional on LONG-FLOAT?
1216       ;; (ditto LG2, LN2, L2E, etc.)
1217       (cold-set 'sb!vm::*fp-constant-pi* (number-to-core pi))
1218       (cold-set 'sb!vm::*fp-constant-l2t* (number-to-core (log 10L0 2L0)))
1219       (cold-set 'sb!vm::*fp-constant-l2e*
1220             (number-to-core (log 2.718281828459045235360287471352662L0 2L0)))
1221       (cold-set 'sb!vm::*fp-constant-lg2* (number-to-core (log 2L0 10L0)))
1222       (cold-set 'sb!vm::*fp-constant-ln2*
1223             (number-to-core
1224              (log 2L0 2.718281828459045235360287471352662L0))))
1225     #!+gencgc
1226     (cold-set 'sb!vm::*SCAVENGE-READ-ONLY-GSPACE* *nil-descriptor*)))
1227
1228 ;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order
1229 ;;; to make a package that is similar to PKG.
1230 (defun make-make-package-args (pkg)
1231   (let* ((use *nil-descriptor*)
1232          (cold-nicknames *nil-descriptor*)
1233          (res *nil-descriptor*))
1234     (dolist (u (package-use-list pkg))
1235       (when (assoc u *cold-package-symbols*)
1236         (cold-push (string-to-core (package-name u)) use)))
1237     (let* ((pkg-name (package-name pkg))
1238            ;; Make the package nickname lists for the standard packages
1239            ;; be the minimum specified by ANSI, regardless of what value
1240            ;; the cross-compilation host happens to use.
1241            (warm-nicknames (cond ((string= pkg-name "COMMON-LISP")
1242                                   '("CL"))
1243                                  ((string= pkg-name "COMMON-LISP-USER")
1244                                   '("CL-USER"))
1245                                  ((string= pkg-name "KEYWORD")
1246                                   '())
1247                                  ;; For packages other than the
1248                                  ;; standard packages, the nickname
1249                                  ;; list was specified by our package
1250                                  ;; setup code, not by properties of
1251                                  ;; what cross-compilation host we
1252                                  ;; happened to use, and we can just
1253                                  ;; propagate it into the target.
1254                                  (t
1255                                   (package-nicknames pkg)))))
1256       (dolist (warm-nickname warm-nicknames)
1257         (cold-push (string-to-core warm-nickname) cold-nicknames)))
1258
1259     (cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
1260                                          0.8))
1261                res)
1262     (cold-push (cold-intern :internal-symbols) res)
1263     (cold-push (number-to-core (truncate (package-external-symbol-count pkg)
1264                                          0.8))
1265                res)
1266     (cold-push (cold-intern :external-symbols) res)
1267
1268     (cold-push cold-nicknames res)
1269     (cold-push (cold-intern :nicknames) res)
1270
1271     (cold-push use res)
1272     (cold-push (cold-intern :use) res)
1273
1274     (cold-push (string-to-core (package-name pkg)) res)
1275     res))
1276 \f
1277 ;;;; fdefinition objects
1278
1279 ;;; a hash table mapping from fdefinition names to descriptors of cold
1280 ;;; objects. Note: Since fdefinition names can be lists like '(SETF
1281 ;;; FOO), and we want to have only one entry per name, this must be an
1282 ;;; 'EQUAL hash table, not the default 'EQL.
1283 (defvar *cold-fdefn-objects*)
1284
1285 (defvar *cold-fdefn-gspace* nil)
1286
1287 ;;; Given a cold representation of an FDEFN name, return a warm representation.
1288 ;;;
1289 ;;; Note: Despite the name, this actually has little to do with
1290 ;;; FDEFNs, it's just a function for warming up values, and the only
1291 ;;; values it knows how to warm up are symbols and lists. (The
1292 ;;; connection to FDEFNs is that symbols and lists are the only
1293 ;;; possible names for functions.)
1294 (declaim (ftype (function (descriptor) (or symbol list)) warm-fdefn-name))
1295 (defun warm-fdefn-name (des)
1296   (ecase (descriptor-lowtag des)
1297     (#.sb!vm:list-pointer-type ; FIXME: no #.
1298      (if (= (descriptor-bits des) (descriptor-bits *nil-descriptor*))
1299          nil
1300          ;; FIXME: If we cold-intern this again, we might get a different
1301          ;; name. Check to make sure that any hash tables along the way
1302          ;; are 'EQUAL not 'EQL.
1303          (cons (warm-fdefn-name (read-wordindexed des sb!vm:cons-car-slot))
1304                (warm-fdefn-name (read-wordindexed des sb!vm:cons-cdr-slot)))))
1305     (#.sb!vm:other-pointer-type ; FIXME: no #.
1306      (or (gethash (descriptor-bits des) *cold-symbols*)
1307          (descriptor-bits des)))))
1308
1309 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
1310   (declare (type descriptor cold-name))
1311   (let ((warm-name (warm-fdefn-name cold-name)))
1312     (or (gethash warm-name *cold-fdefn-objects*)
1313         (let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace* *dynamic*)
1314                                             (1- sb!vm:fdefn-size)
1315                                             sb!vm:other-pointer-type)))
1316
1317           (setf (gethash warm-name *cold-fdefn-objects*) fdefn)
1318           (write-memory fdefn (make-other-immediate-descriptor
1319                                (1- sb!vm:fdefn-size) sb!vm:fdefn-type))
1320           (write-wordindexed fdefn sb!vm:fdefn-name-slot cold-name)
1321           (unless leave-fn-raw
1322             (write-wordindexed fdefn sb!vm:fdefn-function-slot
1323                                *nil-descriptor*)
1324             (write-wordindexed fdefn
1325                                sb!vm:fdefn-raw-addr-slot
1326                                (make-random-descriptor
1327                                 (lookup-foreign-symbol "undefined_tramp"))))
1328           fdefn))))
1329
1330 (defun cold-fset (cold-name defn)
1331   (declare (type descriptor cold-name))
1332   (let ((fdefn (cold-fdefinition-object cold-name t))
1333         (type (logand (descriptor-low (read-memory defn)) sb!vm:type-mask)))
1334     (write-wordindexed fdefn sb!vm:fdefn-function-slot defn)
1335     (write-wordindexed fdefn
1336                        sb!vm:fdefn-raw-addr-slot
1337                        (ecase type
1338                          (#.sb!vm:function-header-type
1339                           #!+sparc
1340                           defn
1341                           #!-sparc
1342                           (make-random-descriptor
1343                            (+ (logandc2 (descriptor-bits defn)
1344                                         sb!vm:lowtag-mask)
1345                               (ash sb!vm:function-code-offset
1346                                    sb!vm:word-shift))))
1347                          (#.sb!vm:closure-header-type
1348                           (make-random-descriptor
1349                            (lookup-foreign-symbol "closure_tramp")))))
1350     fdefn))
1351
1352 (defun initialize-static-fns ()
1353   (let ((*cold-fdefn-gspace* *static*))
1354     (dolist (sym sb!vm:*static-functions*)
1355       (let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
1356              (offset (- (+ (- (descriptor-low fdefn)
1357                               sb!vm:other-pointer-type)
1358                            (* sb!vm:fdefn-raw-addr-slot sb!vm:word-bytes))
1359                         (descriptor-low *nil-descriptor*)))
1360              (desired (sb!vm:static-function-offset sym)))
1361         (unless (= offset desired)
1362           ;; FIXME: should be fatal
1363           (warn "Offset from FDEFN ~S to ~S is ~D, not ~D."
1364                 sym nil offset desired))))))
1365
1366 (defun list-all-fdefn-objects ()
1367   (let ((result *nil-descriptor*))
1368     (maphash #'(lambda (key value)
1369                  (declare (ignore key))
1370                  (cold-push value result))
1371              *cold-fdefn-objects*)
1372     result))
1373 \f
1374 ;;;; fixups and related stuff
1375
1376 ;;; an EQUAL hash table
1377 (defvar *cold-foreign-symbol-table*)
1378 (declaim (type hash-table *cold-foreign-symbol-table*))
1379
1380 (defun load-foreign-symbol-table (filename)
1381   (with-open-file (file filename)
1382     (loop
1383       (let ((line (read-line file nil nil)))
1384         (unless line
1385           (return))
1386         ;; UNIX symbol tables might have tabs in them, and tabs are
1387         ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
1388         ;; nice portable way to deal with them within Lisp, alas.
1389         ;; Fortunately, it's easy to use UNIX command line tools like
1390         ;; sed to remove the problem, so it's not too painful for us
1391         ;; to push responsibility for converting tabs to spaces out to
1392         ;; the caller.
1393         ;;
1394         ;; Other non-STANDARD-CHARs are problematic for the same reason.
1395         ;; Make sure that there aren't any..
1396         (let ((ch (find-if (lambda (char)
1397                              (not (typep char 'standard-char)))
1398                           line)))
1399           (when ch
1400             (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
1401                    ch
1402                    line)))
1403         (setf line (string-trim '(#\space) line))
1404         (let ((p1 (position #\space line :from-end nil))
1405               (p2 (position #\space line :from-end t)))
1406           (if (not (and p1 p2 (< p1 p2)))
1407               ;; KLUDGE: It's too messy to try to understand all
1408               ;; possible output from nm, so we just punt the lines we
1409               ;; don't recognize. We realize that there's some chance
1410               ;; that might get us in trouble someday, so we warn
1411               ;; about it.
1412               (warn "ignoring unrecognized line ~S in ~A" line filename)
1413               (multiple-value-bind (value name)
1414                   (if (string= "0x" line :end2 2)
1415                       (values (parse-integer line :start 2 :end p1 :radix 16)
1416                               (subseq line (1+ p2)))
1417                       (values (parse-integer line :end p1 :radix 16)
1418                               (subseq line (1+ p2))))
1419                 (multiple-value-bind (old-value found)
1420                     (gethash name *cold-foreign-symbol-table*)
1421                   (when (and found
1422                              (not (= old-value value)))
1423                     (warn "redefining ~S from #X~X to #X~X"
1424                           name old-value value)))
1425                 (setf (gethash name *cold-foreign-symbol-table*) value))))))
1426     (values)))
1427
1428 (defun lookup-foreign-symbol (name)
1429   #!+x86
1430   (let ((prefixes
1431          #!+linux #(;; FIXME: How many of these are actually
1432                     ;; needed? The first four are taken from rather
1433                     ;; disorganized CMU CL code, which could easily
1434                     ;; have had redundant values in it..
1435                     "_"
1436                     "__"
1437                     "__libc_"
1438                     "ldso_stub__"
1439                     ;; ..and the fifth seems to match most
1440                     ;; actual symbols, at least in RedHat 6.2.
1441                     "")
1442          #!+freebsd #("" "ldso_stub__")
1443          #!+openbsd #("_")))
1444     (or (some (lambda (prefix)
1445                 (gethash (concatenate 'string prefix name)
1446                          *cold-foreign-symbol-table*
1447                          nil))
1448               prefixes)
1449         *foreign-symbol-placeholder-value*
1450         (progn
1451           (format *error-output* "~&The foreign symbol table is:~%")
1452           (maphash (lambda (k v)
1453                      (format *error-output* "~&~S = #X~8X~%" k v))
1454                    *cold-foreign-symbol-table*)
1455           (format *error-output* "~&The prefix table is: ~S~%" prefixes)
1456           (error "The foreign symbol ~S is undefined." name))))
1457   #!-x86 (error "non-x86 unsupported in SBCL (but see old CMU CL code)"))
1458
1459 (defvar *cold-assembler-routines*)
1460
1461 (defvar *cold-assembler-fixups*)
1462
1463 (defun record-cold-assembler-routine (name address)
1464   (/xhow "in RECORD-COLD-ASSEMBLER-ROUTINE" name address)
1465   (push (cons name address)
1466         *cold-assembler-routines*))
1467
1468 (defun record-cold-assembler-fixup (routine
1469                                     code-object
1470                                     offset
1471                                     &optional
1472                                     (kind :both))
1473   (push (list routine code-object offset kind)
1474         *cold-assembler-fixups*))
1475
1476 (defun lookup-assembler-reference (symbol)
1477   (let ((value (cdr (assoc symbol *cold-assembler-routines*))))
1478     ;; FIXME: Should this be ERROR instead of WARN?
1479     (unless value
1480       (warn "Assembler routine ~S not defined." symbol))
1481     value))
1482
1483 ;;; The x86 port needs to store code fixups along with code objects if
1484 ;;; they are to be moved, so fixups for code objects in the dynamic
1485 ;;; heap need to be noted.
1486 #!+x86
1487 (defvar *load-time-code-fixups*)
1488
1489 #!+x86
1490 (defun note-load-time-code-fixup (code-object offset value kind)
1491   ;; If CODE-OBJECT might be moved
1492   (when (= (gspace-identifier (descriptor-intuit-gspace code-object))
1493            dynamic-space-id)
1494     ;; FIXME: pushed thing should be a structure, not just a list
1495     (push (list code-object offset value kind) *load-time-code-fixups*))
1496   (values))
1497
1498 #!+x86
1499 (defun output-load-time-code-fixups ()
1500   (dolist (fixups *load-time-code-fixups*)
1501     (let ((code-object (first fixups))
1502           (offset (second fixups))
1503           (value (third fixups))
1504           (kind (fourth fixups)))
1505       (cold-push (cold-cons
1506                   (cold-intern :load-time-code-fixup)
1507                   (cold-cons
1508                    code-object
1509                    (cold-cons
1510                     (number-to-core offset)
1511                     (cold-cons
1512                      (number-to-core value)
1513                      (cold-cons
1514                       (cold-intern kind)
1515                       *nil-descriptor*)))))
1516                  *current-reversed-cold-toplevels*))))
1517
1518 ;;; Given a pointer to a code object and an offset relative to the
1519 ;;; tail of the code object's header, return an offset relative to the
1520 ;;; (beginning of the) code object.
1521 ;;;
1522 ;;; FIXME: It might be clearer to reexpress
1523 ;;;    (LET ((X (CALC-OFFSET CODE-OBJECT OFFSET0))) ..)
1524 ;;; as
1525 ;;;    (LET ((X (+ OFFSET0 (CODE-OBJECT-HEADER-N-BYTES CODE-OBJECT)))) ..).
1526 (declaim (ftype (function (descriptor sb!vm:word)) calc-offset))
1527 (defun calc-offset (code-object offset-from-tail-of-header)
1528   (let* ((header (read-memory code-object))
1529          (header-n-words (ash (descriptor-bits header) (- sb!vm:type-bits)))
1530          (header-n-bytes (ash header-n-words sb!vm:word-shift))
1531          (result (+ offset-from-tail-of-header header-n-bytes)))
1532     result))
1533
1534 (declaim (ftype (function (descriptor sb!vm:word sb!vm:word keyword))
1535                 do-cold-fixup))
1536 (defun do-cold-fixup (code-object after-header value kind)
1537   (let* ((offset-within-code-object (calc-offset code-object after-header))
1538          (gspace-bytes (descriptor-bytes code-object))
1539          (gspace-byte-offset (+ (descriptor-byte-offset code-object)
1540                                 offset-within-code-object))
1541          (gspace-byte-address (gspace-byte-address
1542                                (descriptor-gspace code-object))))
1543     (ecase sb!c:*backend-fasl-file-implementation*
1544       ;; Classic CMU CL supported these, and I haven't gone out of my way
1545       ;; to break them, but I have no way of testing them.. -- WHN 19990817
1546       #|
1547       (#.sb!c:pmax-fasl-file-implementation
1548        (ecase kind
1549          (:jump
1550           (assert (zerop (ash value -28)))
1551           (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
1552                 (ash value -2)))
1553          (:lui
1554           (setf (sap-ref-16 sap 0)
1555                 (+ (ash value -16)
1556                    (if (logbitp 15 value) 1 0))))
1557          (:addi
1558           (setf (sap-ref-16 sap 0)
1559                 (ldb (byte 16 0) value)))))
1560       (#.sb!c:sparc-fasl-file-implementation
1561        (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
1562          (ecase kind
1563            (:call
1564             (error "Can't deal with call fixups yet."))
1565            (:sethi
1566             (setf inst
1567                   (dpb (ldb (byte 22 10) value)
1568                        (byte 22 0)
1569                        inst)))
1570            (:add
1571             (setf inst
1572                   (dpb (ldb (byte 10 0) value)
1573                        (byte 10 0)
1574                        inst))))
1575          (setf (sap-ref-32 sap 0)
1576                (maybe-byte-swap inst))))
1577       ((#.sb!c:rt-fasl-file-implementation
1578         #.sb!c:rt-afpa-fasl-file-implementation)
1579        (ecase kind
1580          (:cal
1581           (setf (sap-ref-16 sap 2)
1582                 (maybe-byte-swap-short
1583                  (ldb (byte 16 0) value))))
1584          (:cau
1585           (let ((high (ldb (byte 16 16) value)))
1586             (setf (sap-ref-16 sap 2)
1587                   (maybe-byte-swap-short
1588                    (if (logbitp 15 value) (1+ high) high)))))
1589          (:ba
1590           (unless (zerop (ash value -24))
1591             (warn "#X~8,'0X out of range for branch-absolute." value))
1592           (let ((inst (maybe-byte-swap-short (sap-ref-16 sap 0))))
1593             (setf (sap-ref-16 sap 0)
1594                   (maybe-byte-swap-short
1595                    (dpb (ldb (byte 8 16) value)
1596                         (byte 8 0)
1597                         inst))))
1598           (setf (sap-ref-16 sap 2)
1599                 (maybe-byte-swap-short (ldb (byte 16 0) value))))))
1600       |#
1601       (:x86
1602        (let* ((un-fixed-up (byte-vector-ref-32 gspace-bytes
1603                                                gspace-byte-offset))
1604               (code-object-start-addr (logandc2 (descriptor-bits code-object)
1605                                                 sb!vm:lowtag-mask)))
1606          (assert (= code-object-start-addr
1607                     (+ gspace-byte-address
1608                        (descriptor-byte-offset code-object))))
1609          (ecase kind
1610            (:absolute
1611             (let ((fixed-up (+ value un-fixed-up)))
1612               (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
1613                     fixed-up)
1614               ;; comment from CMU CL sources:
1615               ;;
1616               ;; Note absolute fixups that point within the object.
1617               ;; KLUDGE: There seems to be an implicit assumption in
1618               ;; the old CMU CL code here, that if it doesn't point
1619               ;; before the object, it must point within the object
1620               ;; (not beyond it). It would be good to add an
1621               ;; explanation of why that's true, or an assertion that
1622               ;; it's really true, or both.
1623               (unless (< fixed-up code-object-start-addr)
1624                 (note-load-time-code-fixup code-object
1625                                            after-header
1626                                            value
1627                                            kind))))
1628            (:relative ; (used for arguments to X86 relative CALL instruction)
1629             (let ((fixed-up (- (+ value un-fixed-up)
1630                                gspace-byte-address
1631                                gspace-byte-offset
1632                                sb!vm:word-bytes))) ; length of CALL argument
1633               (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
1634                     fixed-up)
1635               ;; Note relative fixups that point outside the code
1636               ;; object, which is to say all relative fixups, since
1637               ;; relative addressing within a code object never needs
1638               ;; a fixup.
1639               (note-load-time-code-fixup code-object
1640                                          after-header
1641                                          value
1642                                          kind))))))
1643       ;; CMU CL supported these, and I haven't gone out of my way to break
1644       ;; them, but I have no way of testing them.. -- WHN 19990817
1645       #|
1646       (#.sb!c:hppa-fasl-file-implementation
1647        (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
1648          (setf (sap-ref-32 sap 0)
1649                (maybe-byte-swap
1650                 (ecase kind
1651                   (:load
1652                    (logior (ash (ldb (byte 11 0) value) 1)
1653                            (logand inst #xffffc000)))
1654                   (:load-short
1655                    (let ((low-bits (ldb (byte 11 0) value)))
1656                      (assert (<= 0 low-bits (1- (ash 1 4))))
1657                      (logior (ash low-bits 17)
1658                              (logand inst #xffe0ffff))))
1659                   (:hi
1660                    (logior (ash (ldb (byte 5 13) value) 16)
1661                            (ash (ldb (byte 2 18) value) 14)
1662                            (ash (ldb (byte 2 11) value) 12)
1663                            (ash (ldb (byte 11 20) value) 1)
1664                            (ldb (byte 1 31) value)
1665                            (logand inst #xffe00000)))
1666                   (:branch
1667                    (let ((bits (ldb (byte 9 2) value)))
1668                      (assert (zerop (ldb (byte 2 0) value)))
1669                      (logior (ash bits 3)
1670                              (logand inst #xffe0e002)))))))))
1671       (#.sb!c:alpha-fasl-file-implementation
1672        (ecase kind
1673          (:jmp-hint
1674           (assert (zerop (ldb (byte 2 0) value)))
1675           #+nil
1676           (setf (sap-ref-16 sap 0)
1677                 (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2)))))
1678          (:bits-63-48
1679           (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
1680                  (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
1681                  (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
1682             (setf (sap-ref-8 sap 0) (ldb (byte 8 48) value))
1683             (setf (sap-ref-8 sap 1) (ldb (byte 8 56) value))))
1684          (:bits-47-32
1685           (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
1686                  (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
1687             (setf (sap-ref-8 sap 0) (ldb (byte 8 32) value))
1688             (setf (sap-ref-8 sap 1) (ldb (byte 8 40) value))))
1689          (:ldah
1690           (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
1691             (setf (sap-ref-8 sap 0) (ldb (byte 8 16) value))
1692             (setf (sap-ref-8 sap 1) (ldb (byte 8 24) value))))
1693          (:lda
1694           (setf (sap-ref-8 sap 0) (ldb (byte 8 0) value))
1695           (setf (sap-ref-8 sap 1) (ldb (byte 8 8) value)))))
1696       (#.sb!c:sgi-fasl-file-implementation
1697        (ecase kind
1698          (:jump
1699           (assert (zerop (ash value -28)))
1700           (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
1701                 (ash value -2)))
1702          (:lui
1703           (setf (sap-ref-16 sap 2)
1704                 (+ (ash value -16)
1705                    (if (logbitp 15 value) 1 0))))
1706          (:addi
1707           (setf (sap-ref-16 sap 2)
1708                 (ldb (byte 16 0) value)))))
1709       |#
1710       ))
1711   (values))
1712
1713 (defun resolve-assembler-fixups ()
1714   (dolist (fixup *cold-assembler-fixups*)
1715     (let* ((routine (car fixup))
1716            (value (lookup-assembler-reference routine)))
1717       (when value
1718         (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
1719
1720 (defun linkage-info-to-core ()
1721   (let ((result *nil-descriptor*))
1722     (maphash #'(lambda (symbol value)
1723                  (cold-push (cold-cons (string-to-core symbol)
1724                                        (number-to-core value))
1725                             result))
1726              *cold-foreign-symbol-table*)
1727     (cold-set (cold-intern '*!initial-foreign-symbols*) result))
1728   (let ((result *nil-descriptor*))
1729     (dolist (rtn *cold-assembler-routines*)
1730       (cold-push (cold-cons (cold-intern (car rtn))
1731                             (number-to-core (cdr rtn)))
1732                  result))
1733     (cold-set (cold-intern '*!initial-assembler-routines*) result)))
1734 \f
1735 ;;;; general machinery for cold-loading FASL files
1736
1737 (defvar *cold-fop-functions* (replace (make-array 256) *fop-functions*)
1738   #!+sb-doc
1739   "FOP functions for cold loading")
1740
1741 (defvar *normal-fop-functions*)
1742
1743 ;;; This is like DEFINE-FOP which defines fops for warm load, but unlike
1744 ;;; DEFINE-FOP, this version
1745 ;;;   (1) looks up the code for this name (created by a previous DEFINE-FOP)
1746 ;;;       instead of creating a code, and
1747 ;;;   (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector, instead
1748 ;;;       of storing in the *FOP-FUNCTIONS* vector.
1749 (defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
1750   (check-type pushp (member nil t :nope))
1751   (let ((code (get name 'fop-code))
1752         (fname (concat-pnames 'cold- name)))
1753     (unless code
1754       (error "~S is not a defined FOP." name))
1755     `(progn
1756        (defun ,fname ()
1757          ,@(if (eq pushp :nope)
1758              forms
1759              `((with-fop-stack ,pushp ,@forms))))
1760        (setf (svref *cold-fop-functions* ,code) #',fname))))
1761
1762 (defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
1763   (check-type pushp (member nil t :nope))
1764   `(progn
1765     (macrolet ((clone-arg () '(read-arg 4)))
1766       (define-cold-fop (,name ,pushp) ,@forms))
1767     (macrolet ((clone-arg () '(read-arg 1)))
1768       (define-cold-fop (,small-name ,pushp) ,@forms))))
1769
1770 ;;; Cause a fop to be undefined in cold load.
1771 (defmacro not-cold-fop (name)
1772   `(define-cold-fop (,name)
1773      (error "The fop ~S is not supported in cold load." ',name)))
1774
1775 ;;; COLD-LOAD loads stuff into the core image being built by calling FASLOAD
1776 ;;; with the fop function table rebound to a table of cold loading functions.
1777 (defun cold-load (filename)
1778   #!+sb-doc
1779   "Load the file named by FILENAME into the cold load image being built."
1780   (let* ((*normal-fop-functions* *fop-functions*)
1781          (*fop-functions* *cold-fop-functions*)
1782          (*cold-load-filename* (etypecase filename
1783                                  (string filename)
1784                                  (pathname (namestring filename)))))
1785     (with-open-file (s filename :element-type '(unsigned-byte 8))
1786       (fasload s nil nil))))
1787 \f
1788 ;;;; miscellaneous cold fops
1789
1790 (define-cold-fop (fop-misc-trap) *unbound-marker*)
1791
1792 (define-cold-fop (fop-character)
1793   (make-character-descriptor (read-arg 3)))
1794 (define-cold-fop (fop-short-character)
1795   (make-character-descriptor (read-arg 1)))
1796
1797 (define-cold-fop (fop-empty-list) *nil-descriptor*)
1798 (define-cold-fop (fop-truth) (cold-intern t))
1799
1800 (define-cold-fop (fop-normal-load :nope)
1801   (setq *fop-functions* *normal-fop-functions*))
1802
1803 (define-fop (fop-maybe-cold-load 82 :nope)
1804   (when *cold-load-filename*
1805     (setq *fop-functions* *cold-fop-functions*)))
1806
1807 (define-cold-fop (fop-maybe-cold-load :nope))
1808
1809 (clone-cold-fop (fop-struct)
1810                 (fop-small-struct)
1811   (let* ((size (clone-arg))
1812          (result (allocate-boxed-object *dynamic*
1813                                         (1+ size)
1814                                         sb!vm:instance-pointer-type)))
1815     (write-memory result (make-other-immediate-descriptor
1816                           size
1817                           sb!vm:instance-header-type))
1818     (do ((index (1- size) (1- index)))
1819         ((minusp index))
1820       (declare (fixnum index))
1821       (write-wordindexed result
1822                          (+ index sb!vm:instance-slots-offset)
1823                          (pop-stack)))
1824     result))
1825
1826 (define-cold-fop (fop-layout)
1827   (let* ((length-des (pop-stack))
1828          (depthoid-des (pop-stack))
1829          (cold-inherits (pop-stack))
1830          (name (pop-stack))
1831          (old (gethash name *cold-layouts*)))
1832     (declare (type descriptor length-des depthoid-des cold-inherits))
1833     (declare (type symbol name))
1834     ;; If a layout of this name has been defined already
1835     (if old
1836       ;; Enforce consistency between the previous definition and the
1837       ;; current definition, then return the previous definition.
1838       (destructuring-bind
1839           ;; FIXME: This would be more maintainable if we used
1840           ;; DEFSTRUCT (:TYPE LIST) to define COLD-LAYOUT. -- WHN 19990825
1841           (old-layout-descriptor
1842            old-name
1843            old-length
1844            old-inherits-list
1845            old-depthoid)
1846           old
1847         (declare (type descriptor old-layout-descriptor))
1848         (declare (type index old-length))
1849         (declare (type fixnum old-depthoid))
1850         (declare (type list old-inherits-list))
1851         (assert (eq name old-name))
1852         (let ((length (descriptor-fixnum length-des))
1853               (inherits-list (listify-cold-inherits cold-inherits))
1854               (depthoid (descriptor-fixnum depthoid-des)))
1855           (unless (= length old-length)
1856             (error "cold loading a reference to class ~S when the compile~%~
1857                    time length was ~S and current length is ~S"
1858                    name
1859                    length
1860                    old-length))
1861           (unless (equal inherits-list old-inherits-list)
1862             (error "cold loading a reference to class ~S when the compile~%~
1863                    time inherits were ~S~%~
1864                    and current inherits are ~S"
1865                    name
1866                    inherits-list
1867                    old-inherits-list))
1868           (unless (= depthoid old-depthoid)
1869             (error "cold loading a reference to class ~S when the compile~%~
1870                    time inheritance depthoid was ~S and current inheritance~%~
1871                    depthoid is ~S"
1872                    name
1873                    depthoid
1874                    old-depthoid)))
1875         old-layout-descriptor)
1876       ;; Make a new definition from scratch.
1877       (make-cold-layout name length-des cold-inherits depthoid-des))))
1878 \f
1879 ;;;; cold fops for loading symbols
1880
1881 ;;; Load a symbol SIZE characters long from *FASL-FILE* and intern
1882 ;;; that symbol in PACKAGE.
1883 (defun cold-load-symbol (size package)
1884   (let ((string (make-string size)))
1885     (read-string-as-bytes *fasl-file* string)
1886     (cold-intern (intern string package) package)))
1887
1888 (macrolet ((frob (name pname-len package-len)
1889              `(define-cold-fop (,name)
1890                 (let ((index (read-arg ,package-len)))
1891                   (push-fop-table
1892                    (cold-load-symbol (read-arg ,pname-len)
1893                                      (svref *current-fop-table* index)))))))
1894   (frob fop-symbol-in-package-save 4 4)
1895   (frob fop-small-symbol-in-package-save 1 4)
1896   (frob fop-symbol-in-byte-package-save 4 1)
1897   (frob fop-small-symbol-in-byte-package-save 1 1))
1898
1899 (clone-cold-fop (fop-lisp-symbol-save)
1900                 (fop-lisp-small-symbol-save)
1901   (push-fop-table (cold-load-symbol (clone-arg) *cl-package*)))
1902
1903 (clone-cold-fop (fop-keyword-symbol-save)
1904                 (fop-keyword-small-symbol-save)
1905   (push-fop-table (cold-load-symbol (clone-arg) *keyword-package*)))
1906
1907 (clone-cold-fop (fop-uninterned-symbol-save)
1908                 (fop-uninterned-small-symbol-save)
1909   (let* ((size (clone-arg))
1910          (name (make-string size)))
1911     (read-string-as-bytes *fasl-file* name)
1912     (let ((symbol (allocate-symbol name)))
1913       (push-fop-table symbol))))
1914 \f
1915 ;;;; cold fops for loading lists
1916
1917 ;;; Make a list of the top LENGTH things on the fop stack. The last
1918 ;;; cdr of the list is set to LAST.
1919 (defmacro cold-stack-list (length last)
1920   `(do* ((index ,length (1- index))
1921          (result ,last (cold-cons (pop-stack) result)))
1922         ((= index 0) result)
1923      (declare (fixnum index))))
1924
1925 (define-cold-fop (fop-list)
1926   (cold-stack-list (read-arg 1) *nil-descriptor*))
1927 (define-cold-fop (fop-list*)
1928   (cold-stack-list (read-arg 1) (pop-stack)))
1929 (define-cold-fop (fop-list-1)
1930   (cold-stack-list 1 *nil-descriptor*))
1931 (define-cold-fop (fop-list-2)
1932   (cold-stack-list 2 *nil-descriptor*))
1933 (define-cold-fop (fop-list-3)
1934   (cold-stack-list 3 *nil-descriptor*))
1935 (define-cold-fop (fop-list-4)
1936   (cold-stack-list 4 *nil-descriptor*))
1937 (define-cold-fop (fop-list-5)
1938   (cold-stack-list 5 *nil-descriptor*))
1939 (define-cold-fop (fop-list-6)
1940   (cold-stack-list 6 *nil-descriptor*))
1941 (define-cold-fop (fop-list-7)
1942   (cold-stack-list 7 *nil-descriptor*))
1943 (define-cold-fop (fop-list-8)
1944   (cold-stack-list 8 *nil-descriptor*))
1945 (define-cold-fop (fop-list*-1)
1946   (cold-stack-list 1 (pop-stack)))
1947 (define-cold-fop (fop-list*-2)
1948   (cold-stack-list 2 (pop-stack)))
1949 (define-cold-fop (fop-list*-3)
1950   (cold-stack-list 3 (pop-stack)))
1951 (define-cold-fop (fop-list*-4)
1952   (cold-stack-list 4 (pop-stack)))
1953 (define-cold-fop (fop-list*-5)
1954   (cold-stack-list 5 (pop-stack)))
1955 (define-cold-fop (fop-list*-6)
1956   (cold-stack-list 6 (pop-stack)))
1957 (define-cold-fop (fop-list*-7)
1958   (cold-stack-list 7 (pop-stack)))
1959 (define-cold-fop (fop-list*-8)
1960   (cold-stack-list 8 (pop-stack)))
1961 \f
1962 ;;;; cold fops for loading vectors
1963
1964 (clone-cold-fop (fop-string)
1965                 (fop-small-string)
1966   (let* ((len (clone-arg))
1967          (string (make-string len)))
1968     (read-string-as-bytes *fasl-file* string)
1969     (string-to-core string)))
1970
1971 (clone-cold-fop (fop-vector)
1972                 (fop-small-vector)
1973   (let* ((size (clone-arg))
1974          (result (allocate-vector-object *dynamic*
1975                                          sb!vm:word-bits
1976                                          size
1977                                          sb!vm:simple-vector-type)))
1978     (do ((index (1- size) (1- index)))
1979         ((minusp index))
1980       (declare (fixnum index))
1981       (write-wordindexed result
1982                          (+ index sb!vm:vector-data-offset)
1983                          (pop-stack)))
1984     result))
1985
1986 (define-cold-fop (fop-int-vector)
1987   (let* ((len (read-arg 4))
1988          (sizebits (read-arg 1))
1989          (type (case sizebits
1990                  (1 sb!vm:simple-bit-vector-type)
1991                  (2 sb!vm:simple-array-unsigned-byte-2-type)
1992                  (4 sb!vm:simple-array-unsigned-byte-4-type)
1993                  (8 sb!vm:simple-array-unsigned-byte-8-type)
1994                  (16 sb!vm:simple-array-unsigned-byte-16-type)
1995                  (32 sb!vm:simple-array-unsigned-byte-32-type)
1996                  (t (error "losing element size: ~D" sizebits))))
1997          (result (allocate-vector-object *dynamic* sizebits len type))
1998          (start (+ (descriptor-byte-offset result)
1999                    (ash sb!vm:vector-data-offset sb!vm:word-shift)))
2000          (end (+ start
2001                  (ceiling (* len sizebits)
2002                           sb!vm:byte-bits))))
2003     (read-sequence-or-die (descriptor-bytes result)
2004                           *fasl-file*
2005                           :start start
2006                           :end end)
2007     result))
2008
2009 (define-cold-fop (fop-single-float-vector)
2010   (let* ((len (read-arg 4))
2011          (result (allocate-vector-object *dynamic*
2012                                          sb!vm:word-bits
2013                                          len
2014                                          sb!vm:simple-array-single-float-type))
2015          (start (+ (descriptor-byte-offset result)
2016                    (ash sb!vm:vector-data-offset sb!vm:word-shift)))
2017          (end (+ start (* len sb!vm:word-bytes))))
2018     (read-sequence-or-die (descriptor-bytes result)
2019                           *fasl-file*
2020                           :start start
2021                           :end end)
2022     result))
2023
2024 (not-cold-fop fop-double-float-vector)
2025 #!+long-float (not-cold-fop fop-long-float-vector)
2026 (not-cold-fop fop-complex-single-float-vector)
2027 (not-cold-fop fop-complex-double-float-vector)
2028 #!+long-float (not-cold-fop fop-complex-long-float-vector)
2029
2030 (define-cold-fop (fop-array)
2031   (let* ((rank (read-arg 4))
2032          (data-vector (pop-stack))
2033          (result (allocate-boxed-object *dynamic*
2034                                         (+ sb!vm:array-dimensions-offset rank)
2035                                         sb!vm:other-pointer-type)))
2036     (write-memory result
2037                   (make-other-immediate-descriptor rank
2038                                                    sb!vm:simple-array-type))
2039     (write-wordindexed result sb!vm:array-fill-pointer-slot *nil-descriptor*)
2040     (write-wordindexed result sb!vm:array-data-slot data-vector)
2041     (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
2042     (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)
2043     (let ((total-elements 1))
2044       (dotimes (axis rank)
2045         (let ((dim (pop-stack)))
2046           (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-type)
2047                       (= (descriptor-lowtag dim) sb!vm:odd-fixnum-type))
2048             (error "non-fixnum dimension? (~S)" dim))
2049           (setf total-elements
2050                 (* total-elements
2051                    (logior (ash (descriptor-high dim)
2052                                 (- descriptor-low-bits (1- sb!vm:lowtag-bits)))
2053                            (ash (descriptor-low dim)
2054                                 (- 1 sb!vm:lowtag-bits)))))
2055           (write-wordindexed result
2056                              (+ sb!vm:array-dimensions-offset axis)
2057                              dim)))
2058       (write-wordindexed result
2059                          sb!vm:array-elements-slot
2060                          (make-fixnum-descriptor total-elements)))
2061     result))
2062 \f
2063 ;;;; cold fops for loading numbers
2064
2065 (defmacro define-cold-number-fop (fop)
2066   `(define-cold-fop (,fop :nope)
2067      ;; Invoke the ordinary warm version of this fop to push the
2068      ;; number.
2069      (,fop)
2070      ;; Replace the warm fop result with the cold image of the warm
2071      ;; fop result.
2072      (with-fop-stack t
2073        (let ((number (pop-stack)))
2074          (number-to-core number)))))
2075
2076 (define-cold-number-fop fop-single-float)
2077 (define-cold-number-fop fop-double-float)
2078 (define-cold-number-fop fop-integer)
2079 (define-cold-number-fop fop-small-integer)
2080 (define-cold-number-fop fop-word-integer)
2081 (define-cold-number-fop fop-byte-integer)
2082 (define-cold-number-fop fop-complex-single-float)
2083 (define-cold-number-fop fop-complex-double-float)
2084
2085 #!+long-float
2086 (define-cold-fop (fop-long-float)
2087   (ecase sb!c:*backend-fasl-file-implementation*
2088     (:x86 ; 80 bit long-float format
2089      (prepare-for-fast-read-byte *fasl-file*
2090        (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
2091                                             (1- sb!vm:long-float-size)
2092                                             sb!vm:long-float-type))
2093               (low-bits (make-random-descriptor (fast-read-u-integer 4)))
2094               (high-bits (make-random-descriptor (fast-read-u-integer 4)))
2095               (exp-bits (make-random-descriptor (fast-read-s-integer 2))))
2096          (done-with-fast-read-byte)
2097          (write-wordindexed des sb!vm:long-float-value-slot low-bits)
2098          (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits)
2099          (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits)
2100          des)))
2101     ;; This was supported in CMU CL, but isn't currently supported in
2102     ;; SBCL.
2103     #+nil
2104     (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format
2105      (prepare-for-fast-read-byte *fasl-file*
2106        (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
2107                                             (1- sb!vm:long-float-size)
2108                                             sb!vm:long-float-type))
2109               (low-bits (make-random-descriptor (fast-read-u-integer 4)))
2110               (mid-bits (make-random-descriptor (fast-read-u-integer 4)))
2111               (high-bits (make-random-descriptor (fast-read-u-integer 4)))
2112               (exp-bits (make-random-descriptor (fast-read-s-integer 4))))
2113          (done-with-fast-read-byte)
2114          (write-wordindexed des sb!vm:long-float-value-slot exp-bits)
2115          (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits)
2116          (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) mid-bits)
2117          (write-wordindexed des (+ 3 sb!vm:long-float-value-slot) low-bits)
2118          des)))))
2119
2120 #!+long-float
2121 (define-cold-fop (fop-complex-long-float)
2122   (ecase sb!c:*backend-fasl-file-implementation*
2123     (:x86 ; 80 bit long-float format
2124      (prepare-for-fast-read-byte *fasl-file*
2125        (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
2126                                             (1- sb!vm:complex-long-float-size)
2127                                             sb!vm:complex-long-float-type))
2128               (real-low-bits (make-random-descriptor (fast-read-u-integer 4)))
2129               (real-high-bits (make-random-descriptor (fast-read-u-integer 4)))
2130               (real-exp-bits (make-random-descriptor (fast-read-s-integer 2)))
2131               (imag-low-bits (make-random-descriptor (fast-read-u-integer 4)))
2132               (imag-high-bits (make-random-descriptor (fast-read-u-integer 4)))
2133               (imag-exp-bits (make-random-descriptor (fast-read-s-integer 2))))
2134          (done-with-fast-read-byte)
2135          (write-wordindexed des
2136                             sb!vm:complex-long-float-real-slot
2137                             real-low-bits)
2138          (write-wordindexed des
2139                             (1+ sb!vm:complex-long-float-real-slot)
2140                             real-high-bits)
2141          (write-wordindexed des
2142                             (+ 2 sb!vm:complex-long-float-real-slot)
2143                             real-exp-bits)
2144          (write-wordindexed des
2145                             sb!vm:complex-long-float-imag-slot
2146                             imag-low-bits)
2147          (write-wordindexed des
2148                             (1+ sb!vm:complex-long-float-imag-slot)
2149                             imag-high-bits)
2150          (write-wordindexed des
2151                             (+ 2 sb!vm:complex-long-float-imag-slot)
2152                             imag-exp-bits)
2153          des)))
2154     ;; This was supported in CMU CL, but isn't currently supported in SBCL.
2155     #+nil
2156     (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format
2157      (prepare-for-fast-read-byte *fasl-file*
2158        (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
2159                                             (1- sb!vm:complex-long-float-size)
2160                                             sb!vm:complex-long-float-type))
2161               (real-low-bits (make-random-descriptor (fast-read-u-integer 4)))
2162               (real-mid-bits (make-random-descriptor (fast-read-u-integer 4)))
2163               (real-high-bits (make-random-descriptor (fast-read-u-integer 4)))
2164               (real-exp-bits (make-random-descriptor (fast-read-s-integer 4)))
2165               (imag-low-bits (make-random-descriptor (fast-read-u-integer 4)))
2166               (imag-mid-bits (make-random-descriptor (fast-read-u-integer 4)))
2167               (imag-high-bits (make-random-descriptor (fast-read-u-integer 4)))
2168               (imag-exp-bits (make-random-descriptor (fast-read-s-integer 4))))
2169          (done-with-fast-read-byte)
2170          (write-wordindexed des
2171                             sb!vm:complex-long-float-real-slot
2172                             real-exp-bits)
2173          (write-wordindexed des
2174                             (1+ sb!vm:complex-long-float-real-slot)
2175                             real-high-bits)
2176          (write-wordindexed des
2177                             (+ 2 sb!vm:complex-long-float-real-slot)
2178                             real-mid-bits)
2179          (write-wordindexed des
2180                             (+ 3 sb!vm:complex-long-float-real-slot)
2181                             real-low-bits)
2182          (write-wordindexed des
2183                             sb!vm:complex-long-float-real-slot
2184                             imag-exp-bits)
2185          (write-wordindexed des
2186                             (1+ sb!vm:complex-long-float-real-slot)
2187                             imag-high-bits)
2188          (write-wordindexed des
2189                             (+ 2 sb!vm:complex-long-float-real-slot)
2190                             imag-mid-bits)
2191          (write-wordindexed des
2192                             (+ 3 sb!vm:complex-long-float-real-slot)
2193                             imag-low-bits)
2194          des)))))
2195
2196 (define-cold-fop (fop-ratio)
2197   (let ((den (pop-stack)))
2198     (number-pair-to-core (pop-stack) den sb!vm:ratio-type)))
2199
2200 (define-cold-fop (fop-complex)
2201   (let ((im (pop-stack)))
2202     (number-pair-to-core (pop-stack) im sb!vm:complex-type)))
2203 \f
2204 ;;;; cold fops for calling (or not calling)
2205
2206 (not-cold-fop fop-eval)
2207 (not-cold-fop fop-eval-for-effect)
2208
2209 (defvar *load-time-value-counter*)
2210
2211 (define-cold-fop (fop-funcall)
2212   (unless (= (read-arg 1) 0)
2213     (error "You can't FOP-FUNCALL arbitrary stuff in cold load."))
2214   (let ((counter *load-time-value-counter*))
2215     (cold-push (cold-cons
2216                 (cold-intern :load-time-value)
2217                 (cold-cons
2218                  (pop-stack)
2219                  (cold-cons
2220                   (number-to-core counter)
2221                   *nil-descriptor*)))
2222                *current-reversed-cold-toplevels*)
2223     (setf *load-time-value-counter* (1+ counter))
2224     (make-descriptor 0 0 nil counter)))
2225
2226 (defun finalize-load-time-value-noise ()
2227   (cold-set (cold-intern 'sb!impl::*!load-time-values*)
2228             (allocate-vector-object *dynamic*
2229                                     sb!vm:word-bits
2230                                     *load-time-value-counter*
2231                                     sb!vm:simple-vector-type)))
2232
2233 (define-cold-fop (fop-funcall-for-effect nil)
2234   (if (= (read-arg 1) 0)
2235       (cold-push (pop-stack)
2236                  *current-reversed-cold-toplevels*)
2237       (error "You can't FOP-FUNCALL arbitrary stuff in cold load.")))
2238 \f
2239 ;;;; cold fops for fixing up circularities
2240
2241 (define-cold-fop (fop-rplaca nil)
2242   (let ((obj (svref *current-fop-table* (read-arg 4)))
2243         (idx (read-arg 4)))
2244     (write-memory (cold-nthcdr idx obj) (pop-stack))))
2245
2246 (define-cold-fop (fop-rplacd nil)
2247   (let ((obj (svref *current-fop-table* (read-arg 4)))
2248         (idx (read-arg 4)))
2249     (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack))))
2250
2251 (define-cold-fop (fop-svset nil)
2252   (let ((obj (svref *current-fop-table* (read-arg 4)))
2253         (idx (read-arg 4)))
2254     (write-wordindexed obj
2255                    (+ idx
2256                       (ecase (descriptor-lowtag obj)
2257                         (#.sb!vm:instance-pointer-type 1)
2258                         (#.sb!vm:other-pointer-type 2)))
2259                    (pop-stack))))
2260
2261 (define-cold-fop (fop-structset nil)
2262   (let ((obj (svref *current-fop-table* (read-arg 4)))
2263         (idx (read-arg 4)))
2264     (write-wordindexed obj (1+ idx) (pop-stack))))
2265
2266 (define-cold-fop (fop-nthcdr t)
2267   (cold-nthcdr (read-arg 4) (pop-stack)))
2268
2269 (defun cold-nthcdr (index obj)
2270   (dotimes (i index)
2271     (setq obj (read-wordindexed obj 1)))
2272   obj)
2273 \f
2274 ;;;; cold fops for loading code objects and functions
2275
2276 (define-cold-fop (fop-fset nil)
2277   (let ((fn (pop-stack))
2278         (name (pop-stack)))
2279     (cold-fset name fn)))
2280
2281 (define-cold-fop (fop-fdefinition)
2282   (cold-fdefinition-object (pop-stack)))
2283
2284 (define-cold-fop (fop-sanctify-for-execution)
2285   (pop-stack))
2286
2287 (not-cold-fop fop-make-byte-compiled-function)
2288
2289 ;;; Setting this variable shows what code looks like before any
2290 ;;; fixups (or function headers) are applied.
2291 #!+sb-show (defvar *show-pre-fixup-code-p* nil)
2292
2293 ;;; FIXME: The logic here should be converted into a function
2294 ;;; COLD-CODE-FOP-GUTS (NCONST CODE-SIZE) called by DEFINE-COLD-FOP
2295 ;;; FOP-CODE and DEFINE-COLD-FOP FOP-SMALL-CODE, so that
2296 ;;; variable-capture nastiness like (LET ((NCONST ,NCONST) ..) ..)
2297 ;;; doesn't keep me awake at night.
2298 (defmacro define-cold-code-fop (name nconst code-size)
2299   `(define-cold-fop (,name)
2300      (let* ((nconst ,nconst)
2301             (code-size ,code-size)
2302             (raw-header-n-words (+ sb!vm:code-trace-table-offset-slot nconst))
2303             (header-n-words
2304              ;; Note: we round the number of constants up to ensure
2305              ;; that the code vector will be properly aligned.
2306              (round-up raw-header-n-words 2))
2307             (des (allocate-descriptor
2308                   ;; In the X86 with CGC, code can't be relocated, so
2309                   ;; we have to put it into static space. In all other
2310                   ;; configurations, code can go into dynamic space.
2311                   #!+(and x86 cgc) *static* ; KLUDGE: Why? -- WHN 19990907
2312                   #!-(and x86 cgc) *dynamic*
2313                   (+ (ash header-n-words sb!vm:word-shift) code-size)
2314                   sb!vm:other-pointer-type)))
2315        (write-memory des
2316                      (make-other-immediate-descriptor header-n-words
2317                                                       sb!vm:code-header-type))
2318        (write-wordindexed des
2319                           sb!vm:code-code-size-slot
2320                           (make-fixnum-descriptor
2321                            (ash (+ code-size (1- (ash 1 sb!vm:word-shift)))
2322                                 (- sb!vm:word-shift))))
2323        (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
2324        (write-wordindexed des sb!vm:code-debug-info-slot (pop-stack))
2325        (when (oddp raw-header-n-words)
2326          (write-wordindexed des
2327                             raw-header-n-words
2328                             (make-random-descriptor 0)))
2329        (do ((index (1- raw-header-n-words) (1- index)))
2330            ((< index sb!vm:code-trace-table-offset-slot))
2331          (write-wordindexed des index (pop-stack)))
2332        (let* ((start (+ (descriptor-byte-offset des)
2333                         (ash header-n-words sb!vm:word-shift)))
2334               (end (+ start code-size)))
2335          (read-sequence-or-die (descriptor-bytes des)
2336                                *fasl-file*
2337                                :start start
2338                                :end end)
2339          #!+sb-show
2340          (when *show-pre-fixup-code-p*
2341            (format *trace-output*
2342                    "~&/raw code from code-fop ~D ~D:~%"
2343                    nconst
2344                    code-size)
2345            (do ((i start (+ i sb!vm:word-bytes)))
2346                ((>= i end))
2347              (format *trace-output*
2348                      "/#X~8,'0x: #X~8,'0x~%"
2349                      (+ i (gspace-byte-address (descriptor-gspace des)))
2350                      (byte-vector-ref-32 (descriptor-bytes des) i)))))
2351        des)))
2352
2353 (define-cold-code-fop fop-code (read-arg 4) (read-arg 4))
2354
2355 (define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2))
2356
2357 (clone-cold-fop (fop-alter-code nil)
2358                 (fop-byte-alter-code)
2359   (let ((slot (clone-arg))
2360         (value (pop-stack))
2361         (code (pop-stack)))
2362     (write-wordindexed code slot value)))
2363
2364 (define-cold-fop (fop-function-entry)
2365   (let* ((type (pop-stack))
2366          (arglist (pop-stack))
2367          (name (pop-stack))
2368          (code-object (pop-stack))
2369          (offset (calc-offset code-object (read-arg 4)))
2370          (fn (descriptor-beyond code-object
2371                                 offset
2372                                 sb!vm:function-pointer-type))
2373          (next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
2374     (unless (zerop (logand offset sb!vm:lowtag-mask))
2375       ;; FIXME: This should probably become a fatal error.
2376       (warn "unaligned function entry: ~S at #X~X" name offset))
2377     (write-wordindexed code-object sb!vm:code-entry-points-slot fn)
2378     (write-memory fn
2379                   (make-other-immediate-descriptor (ash offset
2380                                                         (- sb!vm:word-shift))
2381                                                    sb!vm:function-header-type))
2382     (write-wordindexed fn
2383                        sb!vm:function-self-slot
2384                        ;; KLUDGE: Wiring decisions like this in at
2385                        ;; this level ("if it's an x86") instead of a
2386                        ;; higher level of abstraction ("if it has such
2387                        ;; and such relocation peculiarities (which
2388                        ;; happen to be confined to the x86)") is bad.
2389                        ;; It would be nice if the code were instead
2390                        ;; conditional on some more descriptive
2391                        ;; feature, :STICKY-CODE or
2392                        ;; :LOAD-GC-INTERACTION or something.
2393                        ;;
2394                        ;; FIXME: The X86 definition of the function
2395                        ;; self slot breaks everything object.tex says
2396                        ;; about it. (As far as I can tell, the X86
2397                        ;; definition makes it a pointer to the actual
2398                        ;; code instead of a pointer back to the object
2399                        ;; itself.) Ask on the mailing list whether
2400                        ;; this is documented somewhere, and if not,
2401                        ;; try to reverse engineer some documentation
2402                        ;; before release.
2403                        #!-x86
2404                        ;; a pointer back to the function object, as
2405                        ;; described in CMU CL
2406                        ;; src/docs/internals/object.tex
2407                        fn
2408                        #!+x86
2409                        ;; KLUDGE: a pointer to the actual code of the
2410                        ;; object, as described nowhere that I can find
2411                        ;; -- WHN 19990907
2412                        (make-random-descriptor
2413                         (+ (descriptor-bits fn)
2414                            (- (ash sb!vm:function-code-offset sb!vm:word-shift)
2415                               ;; FIXME: We should mask out the type
2416                               ;; bits, not assume we know what they
2417                               ;; are and subtract them out this way.
2418                               sb!vm:function-pointer-type))))
2419     (write-wordindexed fn sb!vm:function-next-slot next)
2420     (write-wordindexed fn sb!vm:function-name-slot name)
2421     (write-wordindexed fn sb!vm:function-arglist-slot arglist)
2422     (write-wordindexed fn sb!vm:function-type-slot type)
2423     fn))
2424
2425 (define-cold-fop (fop-foreign-fixup)
2426   (let* ((kind (pop-stack))
2427          (code-object (pop-stack))
2428          (len (read-arg 1))
2429          (sym (make-string len)))
2430     (read-string-as-bytes *fasl-file* sym)
2431     (let ((offset (read-arg 4))
2432           (value (lookup-foreign-symbol sym)))
2433       (do-cold-fixup code-object offset value kind))
2434     code-object))
2435
2436 (define-cold-fop (fop-assembler-code)
2437   (let* ((length (read-arg 4))
2438          (header-n-words
2439           ;; Note: we round the number of constants up to ensure that
2440           ;; the code vector will be properly aligned.
2441           (round-up sb!vm:code-constants-offset 2))
2442          (des (allocate-descriptor *read-only*
2443                                    (+ (ash header-n-words sb!vm:word-shift)
2444                                       length)
2445                                    sb!vm:other-pointer-type)))
2446     (write-memory des
2447                   (make-other-immediate-descriptor header-n-words
2448                                                    sb!vm:code-header-type))
2449     (write-wordindexed des
2450                        sb!vm:code-code-size-slot
2451                        (make-fixnum-descriptor
2452                         (ash (+ length (1- (ash 1 sb!vm:word-shift)))
2453                              (- sb!vm:word-shift))))
2454     (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
2455     (write-wordindexed des sb!vm:code-debug-info-slot *nil-descriptor*)
2456
2457     (let* ((start (+ (descriptor-byte-offset des)
2458                      (ash header-n-words sb!vm:word-shift)))
2459            (end (+ start length)))
2460       (read-sequence-or-die (descriptor-bytes des)
2461                             *fasl-file*
2462                             :start start
2463                             :end end))
2464     des))
2465
2466 (define-cold-fop (fop-assembler-routine)
2467   (let* ((routine (pop-stack))
2468          (des (pop-stack))
2469          (offset (calc-offset des (read-arg 4))))
2470     (record-cold-assembler-routine
2471      routine
2472      (+ (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) offset))
2473     des))
2474
2475 (define-cold-fop (fop-assembler-fixup)
2476   (let* ((routine (pop-stack))
2477          (kind (pop-stack))
2478          (code-object (pop-stack))
2479          (offset (read-arg 4)))
2480     (record-cold-assembler-fixup routine code-object offset kind)
2481     code-object))
2482
2483 (define-cold-fop (fop-code-object-fixup)
2484   (let* ((kind (pop-stack))
2485          (code-object (pop-stack))
2486          (offset (read-arg 4))
2487          (value (descriptor-bits code-object)))
2488     (do-cold-fixup code-object offset value kind)
2489     code-object))
2490 \f
2491 ;;;; emitting C header file
2492
2493 (defun tail-comp (string tail)
2494   (and (>= (length string) (length tail))
2495        (string= string tail :start1 (- (length string) (length tail)))))
2496
2497 (defun head-comp (string head)
2498   (and (>= (length string) (length head))
2499        (string= string head :end1 (length head))))
2500
2501 (defun write-c-header ()
2502
2503   ;; writing beginning boilerplate
2504   (format t "/*~%")
2505   (dolist (line
2506            '("This is a machine-generated file. Do not edit it by hand."
2507              ""
2508              "This file contains low-level information about the"
2509              "internals of a particular version and configuration"
2510              "of SBCL. It is used by the C compiler to create a runtime"
2511              "support environment, an executable program in the host"
2512              "operating system's native format, which can then be used to"
2513              "load and run 'core' files, which are basically programs"
2514              "in SBCL's own format."))
2515     (format t " * ~A~%" line))
2516   (format t " */~%")
2517   (terpri)
2518   (format t "#ifndef _SBCL_H_~%#define _SBCL_H_~%")
2519   (terpri)
2520
2521   ;; writing miscellaneous constants
2522   (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
2523   (format t
2524           "#define SBCL_VERSION_STRING ~S~%"
2525           (sb!xc:lisp-implementation-version))
2526   (format t "#define CORE_MAGIC 0x~X~%" core-magic)
2527   (terpri)
2528   ;; FIXME: Other things from core.h should be defined here too:
2529   ;; #define CORE_END 3840
2530   ;; #define CORE_NDIRECTORY 3861
2531   ;; #define CORE_VALIDATE 3845
2532   ;; #define CORE_VERSION 3860
2533   ;; #define CORE_MACHINE_STATE 3862
2534   ;; (Except that some of them are obsolete and should be deleted instead.)
2535   ;; also
2536   ;; #define DYNAMIC_SPACE_ID (1)
2537   ;; #define STATIC_SPACE_ID (2)
2538   ;; #define READ_ONLY_SPACE_ID (3)
2539
2540   ;; writing entire families of named constants from SB!VM
2541   (let ((constants nil))
2542     (do-external-symbols (symbol (find-package "SB!VM"))
2543       (when (constantp symbol)
2544         (let ((name (symbol-name symbol)))
2545           (labels (;; shared machinery
2546                    (record (string priority)
2547                      (push (list string
2548                                  priority
2549                                  (symbol-value symbol)
2550                                  (documentation symbol 'variable))
2551                            constants))
2552                    ;; machinery for old-style CMU CL Lisp-to-C naming
2553                    (record-with-munged-name (prefix string priority)
2554                      (record (concatenate
2555                               'simple-string
2556                               prefix
2557                               (delete #\- (string-capitalize string)))
2558                              priority))
2559                    (test-tail (tail prefix priority)
2560                      (when (tail-comp name tail)
2561                        (record-with-munged-name prefix
2562                                                 (subseq name 0
2563                                                         (- (length name)
2564                                                            (length tail)))
2565                                                 priority)))
2566                    (test-head (head prefix priority)
2567                      (when (head-comp name head)
2568                        (record-with-munged-name prefix
2569                                                 (subseq name (length head))
2570                                                 priority)))
2571                    ;; machinery for new-style SBCL Lisp-to-C naming
2572                    (record-with-translated-name (priority)
2573                      (record (substitute #\_ #\- name)
2574                              priority)))
2575             ;; This style of munging of names is used in the code
2576             ;; inherited from CMU CL.
2577             (test-tail "-TYPE" "type_" 0)
2578             (test-tail "-FLAG" "flag_" 1)
2579             (test-tail "-TRAP" "trap_" 2)
2580             (test-tail "-SUBTYPE" "subtype_" 3)
2581             (test-head "TRACE-TABLE-" "tracetab_" 4)
2582             (test-tail "-SC-NUMBER" "sc_" 5)
2583             ;; This simpler style of translation of names seems less
2584             ;; confusing, and is used for newer code.
2585             (when (some (lambda (suffix) (tail-comp name suffix))
2586                         #("-START" "-END"))
2587               (record-with-translated-name 6))))))
2588     (setf constants
2589           (sort constants
2590                 #'(lambda (const1 const2)
2591                     (if (= (second const1) (second const2))
2592                       (< (third const1) (third const2))
2593                       (< (second const1) (second const2))))))
2594     (let ((prev-priority (second (car constants))))
2595       (dolist (const constants)
2596         (destructuring-bind (name priority value doc) const
2597           (unless (= prev-priority priority)
2598             (terpri)
2599             (setf prev-priority priority))
2600           (format t "#define ~A " name)
2601           (format t
2602                   ;; KLUDGE: As of sbcl-0.6.7.14, we're dumping two
2603                   ;; different kinds of values here, (1) small codes
2604                   ;; and (2) machine addresses. The small codes can be
2605                   ;; dumped as bare integer values. The large machine
2606                   ;; addresses might cause problems if they're large
2607                   ;; and represented as (signed) C integers, so we
2608                   ;; want to force them to be unsigned. We do that by
2609                   ;; wrapping them in the LISPOBJ macro. (We could do
2610                   ;; it with a bare "(unsigned)" cast, except that
2611                   ;; this header file is used not only in C files, but
2612                   ;; also in assembly files, which don't understand
2613                   ;; the cast syntax. The LISPOBJ macro goes away in
2614                   ;; assembly files, but that shouldn't matter because
2615                   ;; we don't do arithmetic on address constants in
2616                   ;; assembly files. See? It really is a kludge..) --
2617                   ;; WHN 2000-10-18
2618                   (let (;; cutoff for treatment as a small code
2619                         (cutoff (expt 2 16)))
2620                     (cond ((minusp value)
2621                            (error "stub: negative values unsupported"))
2622                           ((< value cutoff)
2623                            "~D")
2624                           (t
2625                            "LISPOBJ(~D)")))
2626                   value)
2627           (format t " /* 0x~X */~@[  /* ~A */~]~%" value doc))))
2628     (terpri))
2629
2630   ;; writing codes/strings for internal errors
2631   (format t "#define ERRORS { \\~%")
2632   ;; FIXME: Is this just DO-VECTOR?
2633   (let ((internal-errors sb!c:*backend-internal-errors*))
2634     (dotimes (i (length internal-errors))
2635       (format t "    ~S, /*~D*/ \\~%" (cdr (aref internal-errors i)) i)))
2636   (format t "    NULL \\~%}~%")
2637   (terpri)
2638
2639   ;; writing primitive object layouts
2640   (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
2641                        :key #'(lambda (obj)
2642                                 (symbol-name
2643                                  (sb!vm:primitive-object-name obj))))))
2644     (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
2645     (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
2646     (dolist (obj structs)
2647       (format t
2648               "struct ~A {~%"
2649               (nsubstitute #\_ #\-
2650               (string-downcase (string (sb!vm:primitive-object-name obj)))))
2651       (when (sb!vm:primitive-object-header obj)
2652         (format t "    lispobj header;~%"))
2653       (dolist (slot (sb!vm:primitive-object-slots obj))
2654         (format t "    ~A ~A~@[[1]~];~%"
2655         (getf (sb!vm:slot-options slot) :c-type "lispobj")
2656         (nsubstitute #\_ #\-
2657                      (string-downcase (string (sb!vm:slot-name slot))))
2658         (sb!vm:slot-rest-p slot)))
2659       (format t "};~2%"))
2660     (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
2661     (format t "#define LISPOBJ(thing) thing~2%")
2662     (dolist (obj structs)
2663       (let ((name (sb!vm:primitive-object-name obj))
2664       (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
2665         (when lowtag
2666         (dolist (slot (sb!vm:primitive-object-slots obj))
2667           (format t "#define ~A_~A_OFFSET ~D~%"
2668                   (substitute #\_ #\- (string name))
2669                   (substitute #\_ #\- (string (sb!vm:slot-name slot)))
2670                   (- (* (sb!vm:slot-offset slot) sb!vm:word-bytes) lowtag)))
2671         (terpri))))
2672     (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
2673
2674   ;; writing static symbol offsets
2675   (dolist (symbol (cons nil sb!vm:*static-symbols*))
2676     ;; FIXME: It would be nice to use longer names NIL and (particularly) T
2677     ;; in #define statements.
2678     (format t "#define ~A LISPOBJ(0x~X)~%"
2679             (nsubstitute #\_ #\-
2680                          (remove-if #'(lambda (char)
2681                                         (member char '(#\% #\* #\. #\!)))
2682                                     (symbol-name symbol)))
2683             (if *static*                ; if we ran GENESIS
2684               ;; We actually ran GENESIS, use the real value.
2685               (descriptor-bits (cold-intern symbol))
2686               ;; We didn't run GENESIS, so guess at the address.
2687               (+ sb!vm:static-space-start
2688                  sb!vm:word-bytes
2689                  sb!vm:other-pointer-type
2690                  (if symbol (sb!vm:static-symbol-offset symbol) 0)))))
2691
2692   ;; Voila.
2693   (format t "~%#endif~%"))
2694 \f
2695 ;;;; writing map file
2696
2697 ;;; Write a map file describing the cold load. Some of this
2698 ;;; information is subject to change due to relocating GC, but even so
2699 ;;; it can be very handy when attempting to troubleshoot the early
2700 ;;; stages of cold load.
2701 (defun write-map ()
2702   (let ((*print-pretty* nil)
2703         (*print-case* :upcase))
2704     (format t "assembler routines defined in core image:~2%")
2705     (dolist (routine (sort (copy-list *cold-assembler-routines*) #'<
2706                            :key #'cdr))
2707       (format t "#X~8,'0X: ~S~%" (cdr routine) (car routine)))
2708     (let ((funs nil)
2709           (undefs nil))
2710       (maphash #'(lambda (name fdefn)
2711                    (let ((fun (read-wordindexed fdefn
2712                                                 sb!vm:fdefn-function-slot)))
2713                      (if (= (descriptor-bits fun)
2714                             (descriptor-bits *nil-descriptor*))
2715                          (push name undefs)
2716                          (let ((addr (read-wordindexed fdefn
2717                                                        sb!vm:fdefn-raw-addr-slot)))
2718                            (push (cons name (descriptor-bits addr))
2719                                  funs)))))
2720                *cold-fdefn-objects*)
2721       (format t "~%~|~%initially defined functions:~2%")
2722       (dolist (info (sort funs #'< :key #'cdr))
2723         (format t "0x~8,'0X: ~S   #X~8,'0X~%" (cdr info) (car info)
2724                 (- (cdr info) #x17)))
2725       (format t
2726 "~%~|
2727 (a note about initially undefined function references: These functions
2728 are referred to by code which is installed by GENESIS, but they are not
2729 installed by GENESIS. This is not necessarily a problem; functions can
2730 be defined later, by cold init toplevel forms, or in files compiled and
2731 loaded at warm init, or elsewhere. As long as they are defined before
2732 they are called, everything should be OK. Things are also OK if the
2733 cross-compiler knew their inline definition and used that everywhere
2734 that they were called before the out-of-line definition is installed,
2735 as is fairly common for structure accessors.)
2736 initially undefined function references:~2%")
2737       (labels ((key (name)
2738                  (etypecase name
2739                    (symbol (symbol-name name))
2740                    ;; FIXME: should use standard SETF-function parsing logic
2741                    (list (key (second name))))))
2742         (dolist (name (sort undefs #'string< :key #'key))
2743           (format t "~S" name)
2744           ;; FIXME: This ACCESSOR-FOR stuff should go away when the
2745           ;; code has stabilized. (It's only here to help me
2746           ;; categorize the flood of undefined functions caused by
2747           ;; completely rewriting the bootstrap process. Hopefully any
2748           ;; future maintainers will mostly have small numbers of
2749           ;; undefined functions..)
2750           (let ((accessor-for (info :function :accessor-for name)))
2751             (when accessor-for
2752               (format t " (accessor for ~S)" accessor-for)))
2753           (format t "~%")))))
2754
2755   (format t "~%~|~%layout names:~2%")
2756   (collect ((stuff))
2757     (maphash #'(lambda (name gorp)
2758                  (declare (ignore name))
2759                  (stuff (cons (descriptor-bits (car gorp))
2760                               (cdr gorp))))
2761              *cold-layouts*)
2762     (dolist (x (sort (stuff) #'< :key #'car))
2763       (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x)))
2764
2765   (values))
2766 \f
2767 ;;;; writing core file
2768
2769 (defvar *core-file*)
2770 (defvar *data-page*)
2771
2772 ;;; KLUDGE: These numbers correspond to values in core.h. If they're
2773 ;;; documented anywhere, I haven't found it. (I haven't tried very
2774 ;;; hard yet.) -- WHN 19990826
2775 (defparameter version-entry-type-code 3860)
2776 (defparameter validate-entry-type-code 3845)
2777 (defparameter directory-entry-type-code 3841)
2778 (defparameter new-directory-entry-type-code 3861)
2779 (defparameter initial-function-entry-type-code 3863)
2780 (defparameter end-entry-type-code 3840)
2781
2782 (declaim (ftype (function (sb!vm:word) sb!vm:word) write-long))
2783 (defun write-long (num) ; FIXME: WRITE-WORD would be a better name.
2784   (ecase sb!c:*backend-byte-order*
2785     (:little-endian
2786      (dotimes (i 4)
2787        (write-byte (ldb (byte 8 (* i 8)) num) *core-file*)))
2788     (:big-endian
2789      (dotimes (i 4)
2790        (write-byte (ldb (byte 8 (* (- 3 i) 8)) num) *core-file*))))
2791   num)
2792
2793 (defun advance-to-page ()
2794   (force-output *core-file*)
2795   (file-position *core-file*
2796                  (round-up (file-position *core-file*)
2797                            sb!c:*backend-page-size*)))
2798
2799 (defun output-gspace (gspace)
2800   (force-output *core-file*)
2801   (let* ((posn (file-position *core-file*))
2802          (bytes (* (gspace-free-word-index gspace) sb!vm:word-bytes))
2803          (pages (ceiling bytes sb!c:*backend-page-size*))
2804          (total-bytes (* pages sb!c:*backend-page-size*)))
2805
2806     (file-position *core-file*
2807                    (* sb!c:*backend-page-size* (1+ *data-page*)))
2808     (format t
2809             "writing ~S byte~:P [~S page~:P] from ~S~%"
2810             total-bytes
2811             pages
2812             gspace)
2813     (force-output)
2814
2815     ;; Note: It is assumed that the GSPACE allocation routines always
2816     ;; allocate whole pages (of size *target-page-size*) and that any
2817     ;; empty gspace between the free pointer and the end of page will
2818     ;; be zero-filled. This will always be true under Mach on machines
2819     ;; where the page size is equal. (RT is 4K, PMAX is 4K, Sun 3 is
2820     ;; 8K).
2821     (write-sequence (gspace-bytes gspace) *core-file* :end total-bytes)
2822     (force-output *core-file*)
2823     (file-position *core-file* posn)
2824
2825     ;; Write part of a (new) directory entry which looks like this:
2826     ;;   GSPACE IDENTIFIER
2827     ;;   WORD COUNT
2828     ;;   DATA PAGE
2829     ;;   ADDRESS
2830     ;;   PAGE COUNT
2831     (write-long (gspace-identifier gspace))
2832     (write-long (gspace-free-word-index gspace))
2833     (write-long *data-page*)
2834     (multiple-value-bind (floor rem)
2835         (floor (gspace-byte-address gspace) sb!c:*backend-page-size*)
2836       ;; FIXME: Define an INSIST macro which does like ASSERT, but
2837       ;; less expensively (ERROR, not CERROR), and which reports
2838       ;; "internal error" on failure. Use it here and elsewhere in the
2839       ;; system.
2840       (assert (zerop rem))
2841       (write-long floor))
2842     (write-long pages)
2843
2844     (incf *data-page* pages)))
2845
2846 ;;; Create a core file created from the cold loaded image. (This is
2847 ;;; the "initial core file" because core files could be created later
2848 ;;; by executing SAVE-LISP in a running system, perhaps after we've
2849 ;;; added some functionality to the system.)
2850 (declaim (ftype (function (string)) write-initial-core-file))
2851 (defun write-initial-core-file (filename)
2852
2853   (let ((filenamestring (namestring filename))
2854         (*data-page* 0))
2855
2856     (format t
2857             "[building initial core file in ~S: ~%"
2858             filenamestring)
2859     (force-output)
2860
2861     (with-open-file (*core-file* filenamestring
2862                                  :direction :output
2863                                  :element-type '(unsigned-byte 8)
2864                                  :if-exists :rename-and-delete)
2865
2866       ;; Write the magic number.
2867       (write-long core-magic)
2868
2869       ;; Write the Version entry.
2870       (write-long version-entry-type-code)
2871       (write-long 3)
2872       (write-long sbcl-core-version-integer)
2873
2874       ;; Write the New Directory entry header.
2875       (write-long new-directory-entry-type-code)
2876       (write-long 17) ; length = (5 words/space) * 3 spaces + 2 for header.
2877
2878       (output-gspace *read-only*)
2879       (output-gspace *static*)
2880       (output-gspace *dynamic*)
2881
2882       ;; Write the initial function.
2883       (write-long initial-function-entry-type-code)
2884       (write-long 3)
2885       (let* ((cold-name (cold-intern '!cold-init))
2886              (cold-fdefn (cold-fdefinition-object cold-name))
2887              (initial-function (read-wordindexed cold-fdefn
2888                                                  sb!vm:fdefn-function-slot)))
2889         (format t
2890                 "~&/(DESCRIPTOR-BITS INITIAL-FUNCTION)=#X~X~%"
2891                 (descriptor-bits initial-function))
2892         (write-long (descriptor-bits initial-function)))
2893
2894       ;; Write the End entry.
2895       (write-long end-entry-type-code)
2896       (write-long 2)))
2897
2898   (format t "done]~%")
2899   (force-output)
2900   (/show "leaving WRITE-INITIAL-CORE-FILE")
2901   (values))
2902 \f
2903 ;;;; the actual GENESIS function
2904
2905 ;;; Read the FASL files in OBJECT-FILE-NAMES and produce a Lisp core,
2906 ;;; and/or information about a Lisp core, therefrom.
2907 ;;;
2908 ;;; input file arguments:
2909 ;;;   SYMBOL-TABLE-FILE-NAME names a UNIX-style .nm file *with* *any*
2910 ;;;     *tab* *characters* *converted* *to* *spaces*. (We push
2911 ;;;     responsibility for removing tabs out to the caller it's
2912 ;;;     trivial to remove them using UNIX command line tools like
2913 ;;;     sed, whereas it's a headache to do it portably in Lisp because
2914 ;;;     #\TAB is not a STANDARD-CHAR.) If this file is not supplied,
2915 ;;;     a core file cannot be built (but a C header file can be).
2916 ;;;
2917 ;;; output files arguments (any of which may be NIL to suppress output):
2918 ;;;   CORE-FILE-NAME gets a Lisp core.
2919 ;;;   C-HEADER-FILE-NAME gets a C header file, traditionally called
2920 ;;;     internals.h, which is used by the C compiler when constructing
2921 ;;;     the executable which will load the core.
2922 ;;;   MAP-FILE-NAME gets (?) a map file. (dunno about this -- WHN 19990815)
2923 ;;;
2924 ;;; other arguments:
2925 ;;;   BYTE-ORDER-SWAP-P controls whether GENESIS tries to swap bytes
2926 ;;;     in some places in the output. It's only appropriate when
2927 ;;;     cross-compiling from a machine with one byte order to a
2928 ;;;     machine with the opposite byte order, which is irrelevant in
2929 ;;;     current (19990816) SBCL, since only the X86 architecture is
2930 ;;;     supported. If you're trying to add support for more
2931 ;;;     architectures, see the comments on DEFVAR
2932 ;;;     *GENESIS-BYTE-ORDER-SWAP-P* for more information.
2933 ;;;
2934 ;;; FIXME: GENESIS doesn't belong in SB!VM. Perhaps in %KERNEL for now,
2935 ;;; perhaps eventually in SB-LD or SB-BOOT.
2936 (defun sb!vm:genesis (&key
2937                       object-file-names
2938                       symbol-table-file-name
2939                       core-file-name
2940                       map-file-name
2941                       c-header-file-name
2942                       byte-order-swap-p)
2943
2944   (when (and core-file-name
2945              (not symbol-table-file-name))
2946     (error "can't output a core file without symbol table file input"))
2947
2948   (format t
2949           "~&beginning GENESIS, ~A~%"
2950           (if core-file-name
2951             ;; Note: This output summarizing what we're doing is
2952             ;; somewhat telegraphic in style, not meant to imply that
2953             ;; we're not e.g. also creating a header file when we
2954             ;; create a core.
2955             (format nil "creating core ~S" core-file-name)
2956             (format nil "creating header ~S" c-header-file-name)))
2957
2958   (let* ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
2959
2960     ;; Read symbol table, if any.
2961     (when symbol-table-file-name
2962       (load-foreign-symbol-table symbol-table-file-name))
2963
2964     ;; Now that we've successfully read our only input file (by
2965     ;; loading the symbol table, if any), it's a good time to ensure
2966     ;; that there'll be someplace for our output files to go when
2967     ;; we're done.
2968     (flet ((frob (filename)
2969              (when filename
2970                (ensure-directories-exist filename :verbose t))))
2971       (frob core-file-name)
2972       (frob map-file-name)
2973       (frob c-header-file-name))
2974
2975     ;; (This shouldn't matter in normal use, since GENESIS normally
2976     ;; only runs once in any given Lisp image, but it could reduce
2977     ;; confusion if we ever experiment with running, tweaking, and
2978     ;; rerunning genesis interactively.)
2979     (do-all-symbols (sym)
2980       (remprop sym 'cold-intern-info))
2981
2982     (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0))
2983            (*load-time-value-counter* 0)
2984            (*genesis-byte-order-swap-p* byte-order-swap-p)
2985            (*cold-fdefn-objects* (make-hash-table :test 'equal))
2986            (*cold-symbols* (make-hash-table :test 'equal))
2987            (*cold-package-symbols* nil)
2988            (*read-only* (make-gspace :read-only
2989                                      read-only-space-id
2990                                      sb!vm:read-only-space-start))
2991            (*static*    (make-gspace :static
2992                                      static-space-id
2993                                      sb!vm:static-space-start))
2994            (*dynamic*   (make-gspace :dynamic
2995                                      dynamic-space-id
2996                                      sb!vm:dynamic-space-start))
2997            (*nil-descriptor* (make-nil-descriptor))
2998            (*current-reversed-cold-toplevels* *nil-descriptor*)
2999            (*unbound-marker* (make-other-immediate-descriptor
3000                               0
3001                               sb!vm:unbound-marker-type))
3002            *cold-assembler-fixups*
3003            *cold-assembler-routines*
3004            #!+x86 *load-time-code-fixups*)
3005
3006       ;; Prepare for cold load.
3007       (initialize-non-nil-symbols)
3008       (initialize-layouts)
3009       (initialize-static-fns)
3010
3011       ;; Initialize the *COLD-SYMBOLS* system with the information
3012       ;; from package-data-list.lisp-expr and
3013       ;; common-lisp-exports.lisp-expr.
3014       ;;
3015       ;; Why do things this way? Historically, the *COLD-SYMBOLS*
3016       ;; machinery was designed and implemented in CMU CL long before
3017       ;; I (WHN) ever heard of CMU CL. It dumped symbols and packages
3018       ;; iff they were used in the cold image. When I added the
3019       ;; package-data-list.lisp-expr mechanism, the idea was to
3020       ;; centralize all information about packages and exports. Thus,
3021       ;; it was the natural place for information even about packages
3022       ;; (such as SB!PCL and SB!WALKER) which aren't used much until
3023       ;; after cold load. This didn't quite match the CMU CL approach
3024       ;; of filling *COLD-SYMBOLS* with symbols which appear in the
3025       ;; cold image and then dumping only those symbols. By explicitly
3026       ;; putting all the symbols from package-data-list.lisp-expr and
3027       ;; from common-lisp-exports.lisp-expr into *COLD-SYMBOLS* here,
3028       ;; we feed our centralized symbol information into the old CMU
3029       ;; CL code without having to change the old CMU CL code too
3030       ;; much. (And the old CMU CL code is still useful for making
3031       ;; sure that the appropriate keywords and internal symbols end
3032       ;; up interned in the target Lisp, which is good, e.g. in order
3033       ;; to make keyword arguments work right and in order to make
3034       ;; BACKTRACEs into target Lisp system code be legible.)
3035       (dolist (exported-name
3036                (sb-cold:read-from-file "common-lisp-exports.lisp-expr"))
3037         (cold-intern (intern exported-name *cl-package*)))
3038       (dolist (pd (sb-cold:read-from-file "package-data-list.lisp-expr"))
3039         (declare (type sb-cold:package-data pd))
3040         (let ((package (find-package (sb-cold:package-data-name pd))))
3041           (labels (;; Call FN on every node of the TREE.
3042                    (mapc-on-tree (fn tree)
3043                                  (typecase tree
3044                                    (cons (mapc-on-tree fn (car tree))
3045                                          (mapc-on-tree fn (cdr tree)))
3046                                    (t (funcall fn tree)
3047                                       (values))))
3048                    ;; Make sure that information about the association
3049                    ;; between PACKAGE and the symbol named NAME gets
3050                    ;; recorded in the cold-intern system or (as a
3051                    ;; convenience when dealing with the tree structure
3052                    ;; allowed in the PACKAGE-DATA-EXPORTS slot) do
3053                    ;; nothing if NAME is NIL.
3054                    (chill (name)
3055                      (when name
3056                        (cold-intern (intern name package) package))))
3057             (mapc-on-tree #'chill (sb-cold:package-data-export pd))
3058             (mapc #'chill (sb-cold:package-data-reexport pd))
3059             (dolist (sublist (sb-cold:package-data-import-from pd))
3060               (destructuring-bind (package-name &rest symbol-names) sublist
3061                 (declare (ignore package-name))
3062                 (mapc #'chill symbol-names))))))
3063
3064       ;; Cold load.
3065       (dolist (file-name object-file-names)
3066         (write-line (namestring file-name))
3067         (cold-load file-name))
3068
3069       ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
3070       (resolve-assembler-fixups)
3071       #!+x86 (output-load-time-code-fixups)
3072       (linkage-info-to-core)
3073       (finish-symbols)
3074       (/show "back from FINISH-SYMBOLS")
3075       (finalize-load-time-value-noise)
3076
3077       ;; Tell the target Lisp how much stuff we've allocated.
3078       (cold-set 'sb!vm:*read-only-space-free-pointer*
3079                 (allocate-descriptor *read-only* 0 sb!vm:even-fixnum-type))
3080       (cold-set 'sb!vm:*static-space-free-pointer*
3081                 (allocate-descriptor *static* 0 sb!vm:even-fixnum-type))
3082       (cold-set 'sb!vm:*initial-dynamic-space-free-pointer*
3083                 (allocate-descriptor *dynamic* 0 sb!vm:even-fixnum-type))
3084       (/show "done setting free pointers")
3085
3086       ;; Write results to files.
3087       ;;
3088       ;; FIXME: I dislike this approach of redefining
3089       ;; *STANDARD-OUTPUT* instead of putting the new stream in a
3090       ;; lexical variable, and it's annoying to have WRITE-MAP (to
3091       ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE
3092       ;; (to a stream explicitly passed as an argument).
3093       (when map-file-name
3094         (with-open-file (*standard-output* map-file-name
3095                                            :direction :output
3096                                            :if-exists :supersede)
3097           (write-map)))
3098       (when c-header-file-name
3099         (with-open-file (*standard-output* c-header-file-name
3100                                            :direction :output
3101                                            :if-exists :supersede)
3102           (write-c-header)))
3103       (when core-file-name
3104         (write-initial-core-file core-file-name)))))