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