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