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