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