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 ;;;; DEFUN-defined functions in the fasl files it reads are bound to the
10 ;;;; corresponding symbols before execution starts. It doesn't do
11 ;;;; anything to initialize variable values; instead it just arranges
12 ;;;; for !COLD-INIT to be called at cold load time. !COLD-INIT is
13 ;;;; responsible for explicitly initializing anything which has to be
14 ;;;; initialized early before it transfers control to the ordinary
17 ;;;; (In CMU CL, and in SBCL as of 0.6.9 anyway, functions not defined
18 ;;;; by DEFUN aren't set up specially by GENESIS. In particular,
19 ;;;; structure slot accessors are not set up. Slot accessors are
20 ;;;; available at cold init time because they're usually compiled
21 ;;;; inline. They're not available as out-of-line functions until the
22 ;;;; toplevel forms installing them have run.)
24 ;;;; This software is part of the SBCL system. See the README file for
25 ;;;; more information.
27 ;;;; This software is derived from the CMU CL system, which was
28 ;;;; written at Carnegie Mellon University and released into the
29 ;;;; public domain. The software is in the public domain and is
30 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
31 ;;;; files for more information.
33 (in-package "SB!FASL")
35 ;;; a magic number used to identify our core files
36 (defconstant core-magic
37 (logior (ash (sb!xc:char-code #\S) 24)
38 (ash (sb!xc:char-code #\B) 16)
39 (ash (sb!xc:char-code #\C) 8)
40 (sb!xc:char-code #\L)))
42 ;;; the current version of SBCL core files
44 ;;; FIXME: This is left over from CMU CL, and not well thought out.
45 ;;; It's good to make sure that the runtime doesn't try to run core
46 ;;; files from the wrong version, but a single number is not the ideal
47 ;;; way to do this in high level data like this (as opposed to e.g. in
48 ;;; IP packets), and in fact the CMU CL version number never ended up
49 ;;; being incremented past 0. A better approach might be to use a
50 ;;; string which is set from CVS data. (Though now as of sbcl-0.7.8 or
51 ;;; so, we have another problem that the core incompatibility
52 ;;; detection mechanisms are on such a hair trigger -- with even
53 ;;; different builds from the same sources being considered
54 ;;; incompatible -- that any coarser-grained versioning mechanisms
55 ;;; like this are largely irrelevant as long as the hair-triggering
58 ;;; 0: inherited from CMU CL
59 ;;; 1: rearranged static symbols for sbcl-0.6.8
60 ;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support,
61 ;;; deleted a slot from DEBUG-SOURCE structure
62 ;;; 3: added build ID to cores to discourage sbcl/.core mismatch
63 (defconstant sbcl-core-version-integer 3)
65 (defun round-up (number size)
67 "Round NUMBER up to be an integral multiple of SIZE."
68 (* size (ceiling number size)))
70 ;;;; implementing the concept of "vector" in (almost) portable
73 ;;;; "If you only need to do such simple things, it doesn't really
74 ;;;; matter which language you use." -- _ANSI Common Lisp_, p. 1, Paul
75 ;;;; Graham (evidently not considering the abstraction "vector" to be
76 ;;;; such a simple thing:-)
78 (eval-when (:compile-toplevel :load-toplevel :execute)
79 (defconstant +smallvec-length+
82 ;;; an element of a BIGVEC -- a vector small enough that we have
83 ;;; a good chance of it being portable to other Common Lisps
85 `(simple-array (unsigned-byte 8) (,+smallvec-length+)))
87 (defun make-smallvec ()
88 (make-array +smallvec-length+ :element-type '(unsigned-byte 8)))
90 ;;; a big vector, implemented as a vector of SMALLVECs
92 ;;; KLUDGE: This implementation seems portable enough for our
93 ;;; purposes, since realistically every modern implementation is
94 ;;; likely to support vectors of at least 2^16 elements. But if you're
95 ;;; masochistic enough to read this far into the contortions imposed
96 ;;; on us by ANSI and the Lisp community, for daring to use the
97 ;;; abstraction of a large linearly addressable memory space, which is
98 ;;; after all only directly supported by the underlying hardware of at
99 ;;; least 99% of the general-purpose computers in use today, then you
100 ;;; may be titillated to hear that in fact this code isn't really
101 ;;; portable, because as of sbcl-0.7.4 we need somewhat more than
102 ;;; 16Mbytes to represent a core, and ANSI only guarantees that
103 ;;; ARRAY-DIMENSION-LIMIT is not less than 1024. -- WHN 2002-06-13
105 (outer-vector (vector (make-smallvec)) :type (vector smallvec)))
107 ;;; analogous to SVREF, but into a BIGVEC
108 (defun bvref (bigvec index)
109 (multiple-value-bind (outer-index inner-index)
110 (floor index +smallvec-length+)
112 (svref (bigvec-outer-vector bigvec) outer-index))
114 (defun (setf bvref) (new-value bigvec index)
115 (multiple-value-bind (outer-index inner-index)
116 (floor index +smallvec-length+)
117 (setf (aref (the smallvec
118 (svref (bigvec-outer-vector bigvec) outer-index))
122 ;;; analogous to LENGTH, but for a BIGVEC
124 ;;; the length of BIGVEC, measured in the number of BVREFable bytes it
126 (defun bvlength (bigvec)
127 (* (length (bigvec-outer-vector bigvec))
130 ;;; analogous to WRITE-SEQUENCE, but for a BIGVEC
131 (defun write-bigvec-as-sequence (bigvec stream &key (start 0) end)
132 (loop for i of-type index from start below (or end (bvlength bigvec)) do
133 (write-byte (bvref bigvec i)
136 ;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC
137 (defun read-bigvec-as-sequence-or-die (bigvec stream &key (start 0) end)
138 (loop for i of-type index from start below (or end (bvlength bigvec)) do
139 (setf (bvref bigvec i)
140 (read-byte stream))))
142 ;;; Grow BIGVEC (exponentially, so that large increases in size have
143 ;;; asymptotic logarithmic cost per byte).
144 (defun expand-bigvec (bigvec)
145 (let* ((old-outer-vector (bigvec-outer-vector bigvec))
146 (length-old-outer-vector (length old-outer-vector))
147 (new-outer-vector (make-array (* 2 length-old-outer-vector))))
148 (dotimes (i length-old-outer-vector)
149 (setf (svref new-outer-vector i)
150 (svref old-outer-vector i)))
151 (loop for i from length-old-outer-vector below (length new-outer-vector) do
152 (setf (svref new-outer-vector i)
154 (setf (bigvec-outer-vector bigvec)
158 ;;;; looking up bytes and multi-byte values in a BIGVEC (considering
159 ;;;; it as an image of machine memory on the cross-compilation target)
161 ;;; BVREF-32 and friends. These are like SAP-REF-n, except that
162 ;;; instead of a SAP we use a BIGVEC.
163 (macrolet ((make-bvref-n
165 (let* ((name (intern (format nil "BVREF-~A" n)))
166 (number-octets (/ n 8))
168 (loop for i from 0 to (1- number-octets)
169 collect `(ash (bvref bigvec (+ byte-index ,i))
172 (loop for i from 0 to (1- number-octets)
173 collect `(ash (bvref bigvec
175 ,(- number-octets 1 i)))
178 (loop for i from 0 to (1- number-octets)
180 `((bvref bigvec (+ byte-index ,i))
181 (ldb (byte 8 ,(* i 8)) new-value))))
183 (loop for i from 0 to (1- number-octets)
185 `((bvref bigvec (+ byte-index ,i))
186 (ldb (byte 8 ,(- n 8 (* i 8))) new-value)))))
188 (defun ,name (bigvec byte-index)
189 (logior ,@(ecase sb!c:*backend-byte-order*
190 (:little-endian ash-list-le)
191 (:big-endian ash-list-be))))
192 (defun (setf ,name) (new-value bigvec byte-index)
193 (setf ,@(ecase sb!c:*backend-byte-order*
194 (:little-endian setf-list-le)
195 (:big-endian setf-list-be))))))))
201 ;; lispobj-sized word, whatever that may be
202 ;; hopefully nobody ever wants a 128-bit SBCL...
203 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
205 (defun bvref-word (bytes index)
206 (bvref-64 bytes index))
207 (defun (setf bvref-word) (new-val bytes index)
208 (setf (bvref-64 bytes index) new-val)))
210 #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
212 (defun bvref-word (bytes index)
213 (bvref-32 bytes index))
214 (defun (setf bvref-word) (new-val bytes index)
215 (setf (bvref-32 bytes index) new-val)))
218 ;;;; representation of spaces in the core
220 ;;; If there is more than one dynamic space in memory (i.e., if a
221 ;;; copying GC is in use), then only the active dynamic space gets
224 (defconstant dynamic-core-space-id 1)
227 (defconstant static-core-space-id 2)
230 (defconstant read-only-core-space-id 3)
232 (defconstant descriptor-low-bits 16
233 "the number of bits in the low half of the descriptor")
234 (defconstant target-space-alignment (ash 1 descriptor-low-bits)
235 "the alignment requirement for spaces in the target.
236 Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)")
238 ;;; a GENESIS-time representation of a memory space (e.g. read-only
239 ;;; space, dynamic space, or static space)
240 (defstruct (gspace (:constructor %make-gspace)
242 ;; name and identifier for this GSPACE
243 (name (missing-arg) :type symbol :read-only t)
244 (identifier (missing-arg) :type fixnum :read-only t)
245 ;; the word address where the data will be loaded
246 (word-address (missing-arg) :type unsigned-byte :read-only t)
247 ;; the data themselves. (Note that in CMU CL this was a pair of
248 ;; fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
249 ;; (And then in SBCL this was a VECTOR, but turned out to be
250 ;; unportable too, since ANSI doesn't think that arrays longer than
251 ;; 1024 (!) should needed by portable CL code...)
252 (bytes (make-bigvec) :read-only t)
253 ;; the index of the next unwritten word (i.e. chunk of
254 ;; SB!VM:N-WORD-BYTES bytes) in BYTES, or equivalently the number of
255 ;; words actually written in BYTES. In order to convert to an actual
256 ;; index into BYTES, thus must be multiplied by SB!VM:N-WORD-BYTES.
259 (defun gspace-byte-address (gspace)
260 (ash (gspace-word-address gspace) sb!vm:word-shift))
262 (def!method print-object ((gspace gspace) stream)
263 (print-unreadable-object (gspace stream :type t)
264 (format stream "~S" (gspace-name gspace))))
266 (defun make-gspace (name identifier byte-address)
267 (unless (zerop (rem byte-address target-space-alignment))
268 (error "The byte address #X~X is not aligned on a #X~X-byte boundary."
270 target-space-alignment))
271 (%make-gspace :name name
272 :identifier identifier
273 :word-address (ash byte-address (- sb!vm:word-shift))))
275 ;;;; representation of descriptors
277 (defstruct (descriptor
278 (:constructor make-descriptor
279 (high low &optional gspace word-offset))
281 ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
282 (gspace nil :type (or gspace null))
283 ;; the offset in words from the start of GSPACE, or NIL if not set yet
284 (word-offset nil :type (or sb!vm:word null))
285 ;; the high and low halves of the descriptor
287 ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL
288 ;; old-rt compiler, this split dates back from a very early version
289 ;; of genesis where 32-bit integers were represented as conses of
290 ;; two 16-bit integers. In any system with nice (UNSIGNED-BYTE 32)
291 ;; structure slots, like CMU CL >= 17 or any version of SBCL, there
292 ;; seems to be no reason to persist in this. -- WHN 19990917
295 (def!method print-object ((des descriptor) stream)
296 (let ((lowtag (descriptor-lowtag des)))
297 (print-unreadable-object (des stream :type t)
298 (cond ((or (= lowtag sb!vm:even-fixnum-lowtag)
299 (= lowtag sb!vm:odd-fixnum-lowtag))
300 (let ((unsigned (logior (ash (descriptor-high des)
301 (1+ (- descriptor-low-bits
302 sb!vm:n-lowtag-bits)))
303 (ash (descriptor-low des)
304 (- 1 sb!vm:n-lowtag-bits)))))
307 (if (> unsigned #x1FFFFFFF)
308 (- unsigned #x40000000)
310 ((or (= lowtag sb!vm:other-immediate-0-lowtag)
311 (= lowtag sb!vm:other-immediate-1-lowtag)
312 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
313 (= lowtag sb!vm:other-immediate-2-lowtag)
314 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
315 (= lowtag sb!vm:other-immediate-3-lowtag))
317 "for other immediate: #X~X, type #b~8,'0B"
318 (ash (descriptor-bits des) (- sb!vm:n-widetag-bits))
319 (logand (descriptor-low des) sb!vm:widetag-mask)))
322 "for pointer: #X~X, lowtag #b~3,'0B, ~A"
323 (logior (ash (descriptor-high des) descriptor-low-bits)
324 (logandc2 (descriptor-low des) sb!vm:lowtag-mask))
326 (let ((gspace (descriptor-gspace des)))
331 ;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The
332 ;;; free word index is boosted as necessary, and if additional memory
333 ;;; is needed, we grow the GSPACE. The descriptor returned is a
334 ;;; pointer of type LOWTAG.
335 (defun allocate-cold-descriptor (gspace length lowtag)
336 (let* ((bytes (round-up length (ash 1 sb!vm:n-lowtag-bits)))
337 (old-free-word-index (gspace-free-word-index gspace))
338 (new-free-word-index (+ old-free-word-index
339 (ash bytes (- sb!vm:word-shift)))))
340 ;; Grow GSPACE as necessary until it's big enough to handle
341 ;; NEW-FREE-WORD-INDEX.
343 ((>= (bvlength (gspace-bytes gspace))
344 (* new-free-word-index sb!vm:n-word-bytes)))
345 (expand-bigvec (gspace-bytes gspace)))
346 ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it.
347 (setf (gspace-free-word-index gspace) new-free-word-index)
348 (let ((ptr (+ (gspace-word-address gspace) old-free-word-index)))
349 (make-descriptor (ash ptr (- sb!vm:word-shift descriptor-low-bits))
350 (logior (ash (logand ptr
352 (- descriptor-low-bits
357 old-free-word-index))))
359 (defun descriptor-lowtag (des)
361 "the lowtag bits for DES"
362 (logand (descriptor-low des) sb!vm:lowtag-mask))
364 (defun descriptor-bits (des)
365 (logior (ash (descriptor-high des) descriptor-low-bits)
366 (descriptor-low des)))
368 (defun descriptor-fixnum (des)
369 (let ((bits (descriptor-bits des)))
370 (if (logbitp (1- sb!vm:n-word-bits) bits)
371 ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to
372 ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS),
373 ;; and although that doesn't make sense for me, or work for me,
374 ;; it's hard to see how it could have been wrong, since CMU CL
375 ;; genesis worked. It would be nice to understand how this came
376 ;; to be.. -- WHN 19990901
377 (logior (ash bits (- 1 sb!vm:n-lowtag-bits))
378 (ash -1 (1+ sb!vm:n-positive-fixnum-bits)))
379 (ash bits (- 1 sb!vm:n-lowtag-bits)))))
381 (defun descriptor-word-sized-integer (des)
382 ;; Extract an (unsigned-byte 32), from either its fixnum or bignum
384 (let ((lowtag (descriptor-lowtag des)))
385 (if (or (= lowtag sb!vm:even-fixnum-lowtag)
386 (= lowtag sb!vm:odd-fixnum-lowtag))
387 (make-random-descriptor (descriptor-fixnum des))
388 (read-wordindexed des 1))))
391 (defun descriptor-bytes (des)
392 (gspace-bytes (descriptor-intuit-gspace des)))
393 (defun descriptor-byte-offset (des)
394 (ash (descriptor-word-offset des) sb!vm:word-shift))
396 ;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise,
397 ;;; figure out a GSPACE which corresponds to DES, set it into
398 ;;; (DESCRIPTOR-GSPACE DES), set a consistent value into
399 ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
400 (declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace))
401 (defun descriptor-intuit-gspace (des)
402 (if (descriptor-gspace des)
403 (descriptor-gspace des)
404 ;; KLUDGE: It's not completely clear to me what's going on here;
405 ;; this is a literal translation from of some rather mysterious
406 ;; code from CMU CL's DESCRIPTOR-SAP function. Some explanation
407 ;; would be nice. -- WHN 19990817
408 (let ((lowtag (descriptor-lowtag des))
409 (high (descriptor-high des))
410 (low (descriptor-low des)))
411 (if (or (eql lowtag sb!vm:fun-pointer-lowtag)
412 (eql lowtag sb!vm:instance-pointer-lowtag)
413 (eql lowtag sb!vm:list-pointer-lowtag)
414 (eql lowtag sb!vm:other-pointer-lowtag))
415 (dolist (gspace (list *dynamic* *static* *read-only*)
416 (error "couldn't find a GSPACE for ~S" des))
417 ;; This code relies on the fact that GSPACEs are aligned
418 ;; such that the descriptor-low-bits low bits are zero.
419 (when (and (>= high (ash (gspace-word-address gspace)
420 (- sb!vm:word-shift descriptor-low-bits)))
421 (<= high (ash (+ (gspace-word-address gspace)
422 (gspace-free-word-index gspace))
423 (- sb!vm:word-shift descriptor-low-bits))))
424 (setf (descriptor-gspace des) gspace)
425 (setf (descriptor-word-offset des)
426 (+ (ash (- high (ash (gspace-word-address gspace)
428 descriptor-low-bits)))
429 (- descriptor-low-bits sb!vm:word-shift))
430 (ash (logandc2 low sb!vm:lowtag-mask)
431 (- sb!vm:word-shift))))
433 (error "don't even know how to look for a GSPACE for ~S" des)))))
435 (defun make-random-descriptor (value)
436 (make-descriptor (logand (ash value (- descriptor-low-bits))
439 descriptor-low-bits))))
440 (logand value (1- (ash 1 descriptor-low-bits)))))
442 (defun make-fixnum-descriptor (num)
443 (when (>= (integer-length num)
444 (1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits)))
445 (error "~W is too big for a fixnum." num))
446 (make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits))))
448 (defun make-other-immediate-descriptor (data type)
449 (make-descriptor (ash data (- sb!vm:n-widetag-bits descriptor-low-bits))
450 (logior (logand (ash data (- descriptor-low-bits
451 sb!vm:n-widetag-bits))
452 (1- (ash 1 descriptor-low-bits)))
455 (defun make-character-descriptor (data)
456 (make-other-immediate-descriptor data sb!vm:character-widetag))
458 (defun descriptor-beyond (des offset type)
459 (let* ((low (logior (+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask)
462 (high (+ (descriptor-high des)
463 (ash low (- descriptor-low-bits)))))
464 (make-descriptor high (logand low (1- (ash 1 descriptor-low-bits))))))
466 ;;;; miscellaneous variables and other noise
468 ;;; a numeric value to be returned for undefined foreign symbols, or NIL if
469 ;;; undefined foreign symbols are to be treated as an error.
470 ;;; (In the first pass of GENESIS, needed to create a header file before
471 ;;; the C runtime can be built, various foreign symbols will necessarily
472 ;;; be undefined, but we don't need actual values for them anyway, and
473 ;;; we can just use 0 or some other placeholder. In the second pass of
474 ;;; GENESIS, all foreign symbols should be defined, so any undefined
475 ;;; foreign symbol is a problem.)
477 ;;; KLUDGE: It would probably be cleaner to rewrite GENESIS so that it
478 ;;; never tries to look up foreign symbols in the first place unless
479 ;;; it's actually creating a core file (as in the second pass) instead
480 ;;; of using this hack to allow it to go through the motions without
481 ;;; causing an error. -- WHN 20000825
482 (defvar *foreign-symbol-placeholder-value*)
484 ;;; a handle on the trap object
485 (defvar *unbound-marker*)
486 ;; was: (make-other-immediate-descriptor 0 sb!vm:unbound-marker-widetag)
488 ;;; a handle on the NIL object
489 (defvar *nil-descriptor*)
491 ;;; the head of a list of TOPLEVEL-THINGs describing stuff to be done
492 ;;; when the target Lisp starts up
494 ;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or
495 ;;; loadtime value, represented by (CONS KEYWORD ..). The FILENAME
496 ;;; tells which fasl file each list element came from, for debugging
498 (defvar *current-reversed-cold-toplevels*)
500 ;;; the name of the object file currently being cold loaded (as a string, not a
501 ;;; pathname), or NIL if we're not currently cold loading any object file
502 (defvar *cold-load-filename* nil)
503 (declaim (type (or string null) *cold-load-filename*))
505 ;;;; miscellaneous stuff to read and write the core memory
507 ;;; FIXME: should be DEFINE-MODIFY-MACRO
508 (defmacro cold-push (thing list)
510 "Push THING onto the given cold-load LIST."
511 `(setq ,list (cold-cons ,thing ,list)))
513 (declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed))
514 (defun read-wordindexed (address index)
516 "Return the value which is displaced by INDEX words from ADDRESS."
517 (let* ((gspace (descriptor-intuit-gspace address))
518 (bytes (gspace-bytes gspace))
519 (byte-index (ash (+ index (descriptor-word-offset address))
521 (value (bvref-word bytes byte-index)))
522 (make-random-descriptor value)))
524 (declaim (ftype (function (descriptor) descriptor) read-memory))
525 (defun read-memory (address)
527 "Return the value at ADDRESS."
528 (read-wordindexed address 0))
530 ;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS
531 ;;; value, instead of the SAP-INT we use here.)
532 (declaim (ftype (function (sb!vm:word descriptor) (values))
533 note-load-time-value-reference))
534 (defun note-load-time-value-reference (address marker)
535 (cold-push (cold-cons
536 (cold-intern :load-time-value-fixup)
537 (cold-cons (sap-int-to-core address)
539 (number-to-core (descriptor-word-offset marker))
541 *current-reversed-cold-toplevels*)
544 (declaim (ftype (function (descriptor sb!vm:word descriptor)) write-wordindexed))
545 (defun write-wordindexed (address index value)
547 "Write VALUE displaced INDEX words from ADDRESS."
548 ;; KLUDGE: There is an algorithm (used in DESCRIPTOR-INTUIT-GSPACE)
549 ;; for calculating the value of the GSPACE slot from scratch. It
550 ;; doesn't work for all values, only some of them, but mightn't it
551 ;; be reasonable to see whether it works on VALUE before we give up
552 ;; because (DESCRIPTOR-GSPACE VALUE) isn't set? (Or failing that,
553 ;; perhaps write a comment somewhere explaining why it's not a good
554 ;; idea?) -- WHN 19990817
555 (if (and (null (descriptor-gspace value))
556 (not (null (descriptor-word-offset value))))
557 (note-load-time-value-reference (+ (logandc2 (descriptor-bits address)
559 (ash index sb!vm:word-shift))
561 (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
562 (byte-index (ash (+ index (descriptor-word-offset address))
564 (setf (bvref-word bytes byte-index)
565 (descriptor-bits value)))))
567 (declaim (ftype (function (descriptor descriptor)) write-memory))
568 (defun write-memory (address value)
570 "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
571 (write-wordindexed address 0 value))
573 ;;;; allocating images of primitive objects in the cold core
575 ;;; There are three kinds of blocks of memory in the type system:
576 ;;; * Boxed objects (cons cells, structures, etc): These objects have no
577 ;;; header as all slots are descriptors.
578 ;;; * Unboxed objects (bignums): There is a single header word that contains
580 ;;; * Vector objects: There is a header word with the type, then a word for
581 ;;; the length, then the data.
582 (defun allocate-boxed-object (gspace length lowtag)
584 "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
586 (allocate-cold-descriptor gspace (ash length sb!vm:word-shift) lowtag))
587 (defun allocate-unboxed-object (gspace element-bits length type)
589 "Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and
590 return an ``other-pointer'' descriptor to them. Initialize the header word
591 with the resultant length and TYPE."
592 (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits))
593 (des (allocate-cold-descriptor gspace
594 (+ bytes sb!vm:n-word-bytes)
595 sb!vm:other-pointer-lowtag)))
597 (make-other-immediate-descriptor (ash bytes
598 (- sb!vm:word-shift))
601 (defun allocate-vector-object (gspace element-bits length type)
603 "Allocate LENGTH units of ELEMENT-BITS size plus a header plus a length slot in
604 GSPACE and return an ``other-pointer'' descriptor to them. Initialize the
605 header word with TYPE and the length slot with LENGTH."
606 ;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using
607 ;; #'/ instead of #'CEILING, which seems wrong.
608 (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits))
609 (des (allocate-cold-descriptor gspace
610 (+ bytes (* 2 sb!vm:n-word-bytes))
611 sb!vm:other-pointer-lowtag)))
612 (write-memory des (make-other-immediate-descriptor 0 type))
613 (write-wordindexed des
614 sb!vm:vector-length-slot
615 (make-fixnum-descriptor length))
618 ;;;; copying simple objects into the cold core
620 (defun base-string-to-core (string &optional (gspace *dynamic*))
622 "Copy STRING (which must only contain STANDARD-CHARs) into the cold
623 core and return a descriptor to it."
624 ;; (Remember that the system convention for storage of strings leaves an
625 ;; extra null byte at the end to aid in call-out to C.)
626 (let* ((length (length string))
627 (des (allocate-vector-object gspace
630 sb!vm:simple-base-string-widetag))
631 (bytes (gspace-bytes gspace))
632 (offset (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
633 (descriptor-byte-offset des))))
634 (write-wordindexed des
635 sb!vm:vector-length-slot
636 (make-fixnum-descriptor length))
638 (setf (bvref bytes (+ offset i))
639 (sb!xc:char-code (aref string i))))
640 (setf (bvref bytes (+ offset length))
641 0) ; null string-termination character for C
644 (defun bignum-to-core (n)
646 "Copy a bignum to the cold core."
647 (let* ((words (ceiling (1+ (integer-length n)) sb!vm:n-word-bits))
648 (handle (allocate-unboxed-object *dynamic*
651 sb!vm:bignum-widetag)))
652 (declare (fixnum words))
653 (do ((index 1 (1+ index))
654 (remainder n (ash remainder (- sb!vm:n-word-bits))))
656 (unless (zerop (integer-length remainder))
657 ;; FIXME: Shouldn't this be a fatal error?
658 (warn "~W words of ~W were written, but ~W bits were left over."
660 (let ((word (ldb (byte sb!vm:n-word-bits 0) remainder)))
661 (write-wordindexed handle index
662 (make-descriptor (ash word (- descriptor-low-bits))
663 (ldb (byte descriptor-low-bits 0)
667 (defun number-pair-to-core (first second type)
669 "Makes a number pair of TYPE (ratio or complex) and fills it in."
670 (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits 2 type)))
671 (write-wordindexed des 1 first)
672 (write-wordindexed des 2 second)
675 (defun write-double-float-bits (address index x)
676 (let ((hi (double-float-high-bits x))
677 (lo (double-float-low-bits x)))
678 (ecase sb!vm::n-word-bits
680 (let ((high-bits (make-random-descriptor hi))
681 (low-bits (make-random-descriptor lo)))
682 (ecase sb!c:*backend-byte-order*
684 (write-wordindexed address index low-bits)
685 (write-wordindexed address (1+ index) high-bits))
687 (write-wordindexed address index high-bits)
688 (write-wordindexed address (1+ index) low-bits)))))
690 (let ((bits (make-random-descriptor
691 (ecase sb!c:*backend-byte-order*
692 (:little-endian (logior lo (ash hi 32)))
694 #+nil (:big-endian (logior (logand hi #xffffffff)
696 (write-wordindexed address index bits))))
699 (defun float-to-core (x)
702 ;; 64-bit platforms have immediate single-floats.
703 #!+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
704 (make-random-descriptor (logior (ash (single-float-bits x) 32)
705 sb!vm::single-float-widetag))
706 #!-#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
707 (let ((des (allocate-unboxed-object *dynamic*
709 (1- sb!vm:single-float-size)
710 sb!vm:single-float-widetag)))
711 (write-wordindexed des
712 sb!vm:single-float-value-slot
713 (make-random-descriptor (single-float-bits x)))
716 (let ((des (allocate-unboxed-object *dynamic*
718 (1- sb!vm:double-float-size)
719 sb!vm:double-float-widetag)))
720 (write-double-float-bits des sb!vm:double-float-value-slot x)))))
722 (defun complex-single-float-to-core (num)
723 (declare (type (complex single-float) num))
724 (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
725 (1- sb!vm:complex-single-float-size)
726 sb!vm:complex-single-float-widetag)))
727 (write-wordindexed des sb!vm:complex-single-float-real-slot
728 (make-random-descriptor (single-float-bits (realpart num))))
729 (write-wordindexed des sb!vm:complex-single-float-imag-slot
730 (make-random-descriptor (single-float-bits (imagpart num))))
733 (defun complex-double-float-to-core (num)
734 (declare (type (complex double-float) num))
735 (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
736 (1- sb!vm:complex-double-float-size)
737 sb!vm:complex-double-float-widetag)))
738 (write-double-float-bits des sb!vm:complex-double-float-real-slot
740 (write-double-float-bits des sb!vm:complex-double-float-imag-slot
743 ;;; Copy the given number to the core.
744 (defun number-to-core (number)
746 (integer (if (< (integer-length number)
747 (- (1+ sb!vm:n-word-bits) sb!vm:n-lowtag-bits))
748 (make-fixnum-descriptor number)
749 (bignum-to-core number)))
750 (ratio (number-pair-to-core (number-to-core (numerator number))
751 (number-to-core (denominator number))
752 sb!vm:ratio-widetag))
753 ((complex single-float) (complex-single-float-to-core number))
754 ((complex double-float) (complex-double-float-to-core number))
756 ((complex long-float)
757 (error "~S isn't a cold-loadable number at all!" number))
758 (complex (number-pair-to-core (number-to-core (realpart number))
759 (number-to-core (imagpart number))
760 sb!vm:complex-widetag))
761 (float (float-to-core number))
762 (t (error "~S isn't a cold-loadable number at all!" number))))
764 (declaim (ftype (function (sb!vm:word) descriptor) sap-int-to-core))
765 (defun sap-int-to-core (sap-int)
766 (let ((des (allocate-unboxed-object *dynamic*
770 (write-wordindexed des
771 sb!vm:sap-pointer-slot
772 (make-random-descriptor sap-int))
775 ;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
776 (defun cold-cons (car cdr &optional (gspace *dynamic*))
777 (let ((dest (allocate-boxed-object gspace 2 sb!vm:list-pointer-lowtag)))
778 (write-memory dest car)
779 (write-wordindexed dest 1 cdr)
782 ;;; Make a simple-vector on the target that holds the specified
783 ;;; OBJECTS, and return its descriptor.
784 (defun vector-in-core (&rest objects)
785 (let* ((size (length objects))
786 (result (allocate-vector-object *dynamic* sb!vm:n-word-bits size
787 sb!vm:simple-vector-widetag)))
788 (dotimes (index size)
789 (write-wordindexed result (+ index sb!vm:vector-data-offset)
795 ;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL.
796 (defvar *cold-symbol-allocation-gspace* nil)
798 ;;; Allocate (and initialize) a symbol.
799 (defun allocate-symbol (name)
800 (declare (simple-string name))
801 (let ((symbol (allocate-unboxed-object (or *cold-symbol-allocation-gspace*
804 (1- sb!vm:symbol-size)
805 sb!vm:symbol-header-widetag)))
806 (write-wordindexed symbol sb!vm:symbol-value-slot *unbound-marker*)
807 (write-wordindexed symbol
808 sb!vm:symbol-hash-slot
809 (make-fixnum-descriptor 0))
810 (write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*)
811 (write-wordindexed symbol sb!vm:symbol-name-slot
812 (base-string-to-core name *dynamic*))
813 (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
816 ;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a
817 ;;; descriptor of a cold symbol or (in an abbreviation for the
818 ;;; most common usage pattern) an ordinary symbol, which will be
819 ;;; automatically cold-interned.
820 (declaim (ftype (function ((or descriptor symbol) descriptor)) cold-set))
821 (defun cold-set (symbol-or-symbol-des value)
822 (let ((symbol-des (etypecase symbol-or-symbol-des
823 (descriptor symbol-or-symbol-des)
824 (symbol (cold-intern symbol-or-symbol-des)))))
825 (write-wordindexed symbol-des sb!vm:symbol-value-slot value)))
827 ;;;; layouts and type system pre-initialization
829 ;;; Since we want to be able to dump structure constants and
830 ;;; predicates with reference layouts, we need to create layouts at
831 ;;; cold-load time. We use the name to intern layouts by, and dump a
832 ;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system
833 ;;; initialization can find them. The only thing that's tricky [sic --
834 ;;; WHN 19990816] is initializing layout's layout, which must point to
837 ;;; a map from class names to lists of
838 ;;; `(,descriptor ,name ,length ,inherits ,depth)
839 ;;; KLUDGE: It would be more understandable and maintainable to use
840 ;;; DEFSTRUCT (:TYPE LIST) here. -- WHN 19990823
841 (defvar *cold-layouts* (make-hash-table :test 'equal))
843 ;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting
845 (defvar *cold-layout-names* (make-hash-table :test 'eql))
847 ;;; FIXME: *COLD-LAYOUTS* and *COLD-LAYOUT-NAMES* should be
848 ;;; initialized by binding in GENESIS.
850 ;;; the descriptor for layout's layout (needed when making layouts)
851 (defvar *layout-layout*)
853 ;;; FIXME: This information should probably be pulled out of the
854 ;;; cross-compiler's tables at genesis time instead of inserted by
855 ;;; hand here as a bare numeric constant.
856 (defconstant target-layout-length 17)
858 ;;; Return a list of names created from the cold layout INHERITS data
860 (defun listify-cold-inherits (x)
861 (let ((len (descriptor-fixnum (read-wordindexed x
862 sb!vm:vector-length-slot))))
865 (let* ((des (read-wordindexed x (+ sb!vm:vector-data-offset index)))
866 (found (gethash (descriptor-bits des) *cold-layout-names*)))
869 (error "unknown descriptor at index ~S (bits = ~8,'0X)"
871 (descriptor-bits des)))))
874 (declaim (ftype (function (symbol descriptor descriptor descriptor descriptor)
877 (defun make-cold-layout (name length inherits depthoid nuntagged)
878 (let ((result (allocate-boxed-object *dynamic*
879 ;; KLUDGE: Why 1+? -- WHN 19990901
880 (1+ target-layout-length)
881 sb!vm:instance-pointer-lowtag)))
883 (make-other-immediate-descriptor
884 target-layout-length sb!vm:instance-header-widetag))
886 ;; KLUDGE: The offsets into LAYOUT below should probably be pulled out
887 ;; of the cross-compiler's tables at genesis time instead of inserted
888 ;; by hand as bare numeric constants. -- WHN ca. 19990901
890 ;; Set slot 0 = the layout of the layout.
891 (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*)
893 ;; Set the immediately following slots = CLOS hash values.
895 ;; Note: CMU CL didn't set these in genesis, but instead arranged
896 ;; for them to be set at cold init time. That resulted in slightly
897 ;; kludgy-looking code, but there were at least two things to be
899 ;; 1. It put the hash values under the control of the target Lisp's
900 ;; RANDOM function, so that CLOS behavior would be nearly
901 ;; deterministic (instead of depending on the implementation of
902 ;; RANDOM in the cross-compilation host, and the state of its
903 ;; RNG when genesis begins).
904 ;; 2. It automatically ensured that all hash values in the target Lisp
905 ;; were part of the same sequence, so that we didn't have to worry
906 ;; about the possibility of the first hash value set in genesis
907 ;; being precisely equal to the some hash value set in cold init time
908 ;; (because the target Lisp RNG has advanced to precisely the same
909 ;; state that the host Lisp RNG was in earlier).
910 ;; Point 1 should not be an issue in practice because of the way we do our
911 ;; build procedure in two steps, so that the SBCL that we end up with has
912 ;; been created by another SBCL (whose RNG is under our control).
913 ;; Point 2 is more of an issue. If ANSI had provided a way to feed
914 ;; entropy into an RNG, we would have no problem: we'd just feed
915 ;; some specialized genesis-time-only pattern into the RNG state
916 ;; before using it. However, they didn't, so we have a slight
917 ;; problem. We address it by generating the hash values using a
918 ;; different algorithm than we use in ordinary operation.
919 (dotimes (i sb!kernel:layout-clos-hash-length)
920 (let (;; The expression here is pretty arbitrary, we just want
921 ;; to make sure that it's not something which is (1)
922 ;; evenly distributed and (2) not foreordained to arise in
923 ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence
924 ;; and show up as the CLOS-HASH value of some other
927 ;; FIXME: This expression here can generate a zero value,
928 ;; and the CMU CL code goes out of its way to generate
929 ;; strictly positive values (even though the field is
930 ;; declared as an INDEX). Check that it's really OK to
931 ;; have zero values in the CLOS-HASH slots.
932 (hash-value (mod (logxor (logand (random-layout-clos-hash) 15253)
933 (logandc2 (random-layout-clos-hash) 15253)
935 ;; (The MOD here is defensive programming
936 ;; to make sure we never write an
937 ;; out-of-range value even if some joker
938 ;; sets LAYOUT-CLOS-HASH-MAX to other
939 ;; than 2^n-1 at some time in the
941 (1+ sb!kernel:layout-clos-hash-max))))
942 (write-wordindexed result
943 (+ i sb!vm:instance-slots-offset 1)
944 (make-fixnum-descriptor hash-value))))
946 ;; Set other slot values.
947 (let ((base (+ sb!vm:instance-slots-offset
948 sb!kernel:layout-clos-hash-length
950 ;; (Offset 0 is CLASS, "the class this is a layout for", which
951 ;; is uninitialized at this point.)
952 (write-wordindexed result (+ base 1) *nil-descriptor*) ; marked invalid
953 (write-wordindexed result (+ base 2) inherits)
954 (write-wordindexed result (+ base 3) depthoid)
955 (write-wordindexed result (+ base 4) length)
956 (write-wordindexed result (+ base 5) *nil-descriptor*) ; info
957 (write-wordindexed result (+ base 6) *nil-descriptor*) ; pure
958 (write-wordindexed result (+ base 7) nuntagged))
960 (setf (gethash name *cold-layouts*)
963 (descriptor-fixnum length)
964 (listify-cold-inherits inherits)
965 (descriptor-fixnum depthoid)
966 (descriptor-fixnum nuntagged)))
967 (setf (gethash (descriptor-bits result) *cold-layout-names*) name)
971 (defun initialize-layouts ()
973 (clrhash *cold-layouts*)
975 ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and
977 (setq *layout-layout* *nil-descriptor*)
978 (setq *layout-layout*
979 (make-cold-layout 'layout
980 (number-to-core target-layout-length)
982 ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT..
984 ;; no raw slots in LAYOUT:
986 (write-wordindexed *layout-layout*
987 sb!vm:instance-slots-offset
990 ;; Then we create the layouts that we'll need to make a correct INHERITS
991 ;; vector for the layout of LAYOUT itself..
993 ;; FIXME: The various LENGTH and DEPTHOID numbers should be taken from
994 ;; the compiler's tables, not set by hand.
1000 (number-to-core 0)))
1002 (make-cold-layout 'instance
1004 (vector-in-core t-layout)
1006 (number-to-core 0)))
1008 (make-cold-layout 'structure-object
1010 (vector-in-core t-layout i-layout)
1012 (number-to-core 0)))
1014 (make-cold-layout 'structure!object
1016 (vector-in-core t-layout i-layout so-layout)
1018 (number-to-core 0)))
1019 (layout-inherits (vector-in-core t-layout
1024 ;; ..and return to backpatch the layout of LAYOUT.
1025 (setf (fourth (gethash 'layout *cold-layouts*))
1026 (listify-cold-inherits layout-inherits))
1027 (write-wordindexed *layout-layout*
1028 ;; FIXME: hardcoded offset into layout struct
1029 (+ sb!vm:instance-slots-offset
1030 layout-clos-hash-length
1035 ;;;; interning symbols in the cold image
1037 ;;; In order to avoid having to know about the package format, we
1038 ;;; build a data structure in *COLD-PACKAGE-SYMBOLS* that holds all
1039 ;;; interned symbols along with info about their packages. The data
1040 ;;; structure is a list of sublists, where the sublists have the
1041 ;;; following format:
1042 ;;; (<make-package-arglist>
1043 ;;; <internal-symbols>
1044 ;;; <external-symbols>
1045 ;;; <imported-internal-symbols>
1046 ;;; <imported-external-symbols>
1047 ;;; <shadowing-symbols>
1048 ;;; <package-documentation>)
1050 ;;; KLUDGE: It would be nice to implement the sublists as instances of
1051 ;;; a DEFSTRUCT (:TYPE LIST). (They'd still be lists, but at least we'd be
1052 ;;; using mnemonically-named operators to access them, instead of trying
1053 ;;; to remember what THIRD and FIFTH mean, and hoping that we never
1054 ;;; need to change the list layout..) -- WHN 19990825
1056 ;;; an alist from packages to lists of that package's symbols to be dumped
1057 (defvar *cold-package-symbols*)
1058 (declaim (type list *cold-package-symbols*))
1060 ;;; a map from descriptors to symbols, so that we can back up. The key
1061 ;;; is the address in the target core.
1062 (defvar *cold-symbols*)
1063 (declaim (type hash-table *cold-symbols*))
1065 ;;; sanity check for a symbol we're about to create on the target
1067 ;;; Make sure that the symbol has an appropriate package. In
1068 ;;; particular, catch the so-easy-to-make error of typing something
1069 ;;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really
1070 ;;; need is SB!KERNEL:%BYTE-BLT.
1071 (defun package-ok-for-target-symbol-p (package)
1072 (let ((package-name (package-name package)))
1074 ;; Cold interning things in these standard packages is OK. (Cold
1075 ;; interning things in the other standard package, CL-USER, isn't
1076 ;; OK. We just use CL-USER to expose symbols whose homes are in
1077 ;; other packages. Thus, trying to cold intern a symbol whose
1078 ;; home package is CL-USER probably means that a coding error has
1079 ;; been made somewhere.)
1080 (find package-name '("COMMON-LISP" "KEYWORD") :test #'string=)
1081 ;; Cold interning something in one of our target-code packages,
1082 ;; which are ever-so-rigorously-and-elegantly distinguished by
1083 ;; this prefix on their names, is OK too.
1084 (string= package-name "SB!" :end1 3 :end2 3)
1085 ;; This one is OK too, since it ends up being COMMON-LISP on the
1087 (string= package-name "SB-XC")
1088 ;; Anything else looks bad. (maybe COMMON-LISP-USER? maybe an extension
1089 ;; package in the xc host? something we can't think of
1090 ;; a valid reason to cold intern, anyway...)
1093 ;;; like SYMBOL-PACKAGE, but safe for symbols which end up on the target
1095 ;;; Most host symbols we dump onto the target are created by SBCL
1096 ;;; itself, so that as long as we avoid gratuitously
1097 ;;; cross-compilation-unfriendly hacks, it just happens that their
1098 ;;; SYMBOL-PACKAGE in the host system corresponds to their
1099 ;;; SYMBOL-PACKAGE in the target system. However, that's not the case
1100 ;;; in the COMMON-LISP package, where we don't get to create the
1101 ;;; symbols but instead have to use the ones that the xc host created.
1102 ;;; In particular, while ANSI specifies which symbols are exported
1103 ;;; from COMMON-LISP, it doesn't specify that their home packages are
1104 ;;; COMMON-LISP, so the xc host can keep them in random packages which
1105 ;;; don't exist on the target (e.g. CLISP keeping some CL-exported
1106 ;;; symbols in the CLOS package).
1107 (defun symbol-package-for-target-symbol (symbol)
1108 ;; We want to catch weird symbols like CLISP's
1109 ;; CL:FIND-METHOD=CLOS::FIND-METHOD, but we don't want to get
1110 ;; sidetracked by ordinary symbols like :CHARACTER which happen to
1111 ;; have the same SYMBOL-NAME as exports from COMMON-LISP.
1112 (multiple-value-bind (cl-symbol cl-status)
1113 (find-symbol (symbol-name symbol) *cl-package*)
1114 (if (and (eq symbol cl-symbol)
1115 (eq cl-status :external))
1116 ;; special case, to work around possible xc host weirdness
1117 ;; in COMMON-LISP package
1120 (let ((result (symbol-package symbol)))
1121 (aver (package-ok-for-target-symbol-p result))
1124 ;;; Return a handle on an interned symbol. If necessary allocate the
1125 ;;; symbol and record which package the symbol was referenced in. When
1126 ;;; we allocate the symbol, make sure we record a reference to the
1127 ;;; symbol in the home package so that the package gets set.
1128 (defun cold-intern (symbol
1130 (package (symbol-package-for-target-symbol symbol)))
1132 (aver (package-ok-for-target-symbol-p package))
1134 ;; Anything on the cross-compilation host which refers to the target
1135 ;; machinery through the host SB-XC package should be translated to
1136 ;; something on the target which refers to the same machinery
1137 ;; through the target COMMON-LISP package.
1138 (let ((p (find-package "SB-XC")))
1139 (when (eq package p)
1140 (setf package *cl-package*))
1141 (when (eq (symbol-package symbol) p)
1142 (setf symbol (intern (symbol-name symbol) *cl-package*))))
1144 (let (;; Information about each cold-interned symbol is stored
1145 ;; in COLD-INTERN-INFO.
1146 ;; (CAR COLD-INTERN-INFO) = descriptor of symbol
1147 ;; (CDR COLD-INTERN-INFO) = list of packages, other than symbol's
1148 ;; own package, referring to symbol
1149 ;; (*COLD-PACKAGE-SYMBOLS* and *COLD-SYMBOLS* store basically the
1150 ;; same information, but with the mapping running the opposite way.)
1151 (cold-intern-info (get symbol 'cold-intern-info)))
1152 (unless cold-intern-info
1153 (cond ((eq (symbol-package-for-target-symbol symbol) package)
1154 (let ((handle (allocate-symbol (symbol-name symbol))))
1155 (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
1156 (when (eq package *keyword-package*)
1157 (cold-set handle handle))
1158 (setq cold-intern-info
1159 (setf (get symbol 'cold-intern-info) (cons handle nil)))))
1161 (cold-intern symbol)
1162 (setq cold-intern-info (get symbol 'cold-intern-info)))))
1163 (unless (or (null package)
1164 (member package (cdr cold-intern-info)))
1165 (push package (cdr cold-intern-info))
1166 (let* ((old-cps-entry (assoc package *cold-package-symbols*))
1167 (cps-entry (or old-cps-entry
1168 (car (push (list package)
1169 *cold-package-symbols*)))))
1170 (unless old-cps-entry
1171 (/show "created *COLD-PACKAGE-SYMBOLS* entry for" package symbol))
1172 (push symbol (rest cps-entry))))
1173 (car cold-intern-info)))
1175 ;;; Construct and return a value for use as *NIL-DESCRIPTOR*.
1176 (defun make-nil-descriptor ()
1177 (let* ((des (allocate-unboxed-object
1182 (result (make-descriptor (descriptor-high des)
1183 (+ (descriptor-low des)
1184 (* 2 sb!vm:n-word-bytes)
1185 (- sb!vm:list-pointer-lowtag
1186 sb!vm:other-pointer-lowtag)))))
1187 (write-wordindexed des
1189 (make-other-immediate-descriptor
1191 sb!vm:symbol-header-widetag))
1192 (write-wordindexed des
1193 (+ 1 sb!vm:symbol-value-slot)
1195 (write-wordindexed des
1196 (+ 2 sb!vm:symbol-value-slot)
1198 (write-wordindexed des
1199 (+ 1 sb!vm:symbol-plist-slot)
1201 (write-wordindexed des
1202 (+ 1 sb!vm:symbol-name-slot)
1203 ;; This is *DYNAMIC*, and DES is *STATIC*,
1204 ;; because that's the way CMU CL did it; I'm
1205 ;; not sure whether there's an underlying
1206 ;; reason. -- WHN 1990826
1207 (base-string-to-core "NIL" *dynamic*))
1208 (write-wordindexed des
1209 (+ 1 sb!vm:symbol-package-slot)
1211 (setf (get nil 'cold-intern-info)
1216 ;;; Since the initial symbols must be allocated before we can intern
1217 ;;; anything else, we intern those here. We also set the value of T.
1218 (defun initialize-non-nil-symbols ()
1220 "Initialize the cold load symbol-hacking data structures."
1221 (let ((*cold-symbol-allocation-gspace* *static*))
1222 ;; Intern the others.
1223 (dolist (symbol sb!vm:*static-symbols*)
1224 (let* ((des (cold-intern symbol))
1225 (offset-wanted (sb!vm:static-symbol-offset symbol))
1226 (offset-found (- (descriptor-low des)
1227 (descriptor-low *nil-descriptor*))))
1228 (unless (= offset-wanted offset-found)
1229 ;; FIXME: should be fatal
1230 (warn "Offset from ~S to ~S is ~W, not ~W"
1235 ;; Establish the value of T.
1236 (let ((t-symbol (cold-intern t)))
1237 (cold-set t-symbol t-symbol))))
1239 ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
1240 ;;; to be stored in *!INITIAL-LAYOUTS*.
1241 (defun cold-list-all-layouts ()
1242 (let ((result *nil-descriptor*))
1243 (maphash (lambda (key stuff)
1244 (cold-push (cold-cons (cold-intern key)
1250 ;;; Establish initial values for magic symbols.
1252 ;;; Scan over all the symbols referenced in each package in
1253 ;;; *COLD-PACKAGE-SYMBOLS* making that for each one there's an
1254 ;;; appropriate entry in the *!INITIAL-SYMBOLS* data structure to
1256 (defun finish-symbols ()
1258 ;; I think the point of setting these functions into SYMBOL-VALUEs
1259 ;; here, instead of using SYMBOL-FUNCTION, is that in CMU CL
1260 ;; SYMBOL-FUNCTION reduces to FDEFINITION, which is a pretty
1261 ;; hairy operation (involving globaldb.lisp etc.) which we don't
1262 ;; want to invoke early in cold init. -- WHN 2001-12-05
1264 ;; FIXME: So OK, that's a reasonable reason to do something weird like
1265 ;; this, but this is still a weird thing to do, and we should change
1266 ;; the names to highlight that something weird is going on. Perhaps
1267 ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
1268 ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...
1269 (macrolet ((frob (symbol)
1271 (cold-fdefinition-object (cold-intern ',symbol)))))
1273 (frob internal-error)
1274 (frob sb!kernel::control-stack-exhausted-error)
1275 (frob sb!kernel::undefined-alien-variable-error)
1276 (frob sb!kernel::undefined-alien-function-error)
1277 (frob sb!kernel::memory-fault-error)
1278 (frob sb!di::handle-breakpoint)
1279 (frob sb!di::handle-fun-end-breakpoint))
1281 (cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0))
1282 (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))
1284 (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0))
1286 (cold-set '*!initial-layouts* (cold-list-all-layouts))
1288 (/show "dumping packages" (mapcar #'car *cold-package-symbols*))
1289 (let ((initial-symbols *nil-descriptor*))
1290 (dolist (cold-package-symbols-entry *cold-package-symbols*)
1291 (let* ((cold-package (car cold-package-symbols-entry))
1292 (symbols (cdr cold-package-symbols-entry))
1293 (shadows (package-shadowing-symbols cold-package))
1294 (documentation (base-string-to-core (documentation cold-package t)))
1295 (internal *nil-descriptor*)
1296 (external *nil-descriptor*)
1297 (imported-internal *nil-descriptor*)
1298 (imported-external *nil-descriptor*)
1299 (shadowing *nil-descriptor*))
1300 (declare (type package cold-package)) ; i.e. not a target descriptor
1301 (/show "dumping" cold-package symbols)
1303 ;; FIXME: Add assertions here to make sure that inappropriate stuff
1304 ;; isn't being dumped:
1305 ;; * the CL-USER package
1306 ;; * the SB-COLD package
1307 ;; * any internal symbols in the CL package
1308 ;; * basically any package other than CL, KEYWORD, or the packages
1309 ;; in package-data-list.lisp-expr
1310 ;; and that the structure of the KEYWORD package (e.g. whether
1311 ;; any symbols are internal to it) matches what we want in the
1314 ;; FIXME: It seems possible that by looking at the contents of
1315 ;; packages in the target SBCL we could find which symbols in
1316 ;; package-data-lisp.lisp-expr are now obsolete. (If I
1317 ;; understand correctly, only symbols which actually have
1318 ;; definitions or which are otherwise referred to actually end
1319 ;; up in the target packages.)
1321 (dolist (symbol symbols)
1322 (let ((handle (car (get symbol 'cold-intern-info)))
1323 (imported-p (not (eq (symbol-package-for-target-symbol symbol)
1325 (multiple-value-bind (found where)
1326 (find-symbol (symbol-name symbol) cold-package)
1327 (unless (and where (eq found symbol))
1328 (error "The symbol ~S is not available in ~S."
1331 (when (memq symbol shadows)
1332 (cold-push handle shadowing))
1334 (:internal (if imported-p
1335 (cold-push handle imported-internal)
1336 (cold-push handle internal)))
1337 (:external (if imported-p
1338 (cold-push handle imported-external)
1339 (cold-push handle external)))))))
1340 (let ((r *nil-descriptor*))
1341 (cold-push documentation r)
1342 (cold-push shadowing r)
1343 (cold-push imported-external r)
1344 (cold-push imported-internal r)
1345 (cold-push external r)
1346 (cold-push internal r)
1347 (cold-push (make-make-package-args cold-package) r)
1348 ;; FIXME: It would be more space-efficient to use vectors
1349 ;; instead of lists here, and space-efficiency here would be
1350 ;; nice, since it would reduce the peak memory usage in
1351 ;; genesis and cold init.
1352 (cold-push r initial-symbols))))
1353 (cold-set '*!initial-symbols* initial-symbols))
1355 (cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
1357 (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
1361 (cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0))
1362 (cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0))
1363 (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0))
1364 (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0))))
1366 ;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order
1367 ;;; to make a package that is similar to PKG.
1368 (defun make-make-package-args (pkg)
1369 (let* ((use *nil-descriptor*)
1370 (cold-nicknames *nil-descriptor*)
1371 (res *nil-descriptor*))
1372 (dolist (u (package-use-list pkg))
1373 (when (assoc u *cold-package-symbols*)
1374 (cold-push (base-string-to-core (package-name u)) use)))
1375 (let* ((pkg-name (package-name pkg))
1376 ;; Make the package nickname lists for the standard packages
1377 ;; be the minimum specified by ANSI, regardless of what value
1378 ;; the cross-compilation host happens to use.
1379 (warm-nicknames (cond ((string= pkg-name "COMMON-LISP")
1381 ((string= pkg-name "COMMON-LISP-USER")
1383 ((string= pkg-name "KEYWORD")
1385 ;; For packages other than the
1386 ;; standard packages, the nickname
1387 ;; list was specified by our package
1388 ;; setup code, not by properties of
1389 ;; what cross-compilation host we
1390 ;; happened to use, and we can just
1391 ;; propagate it into the target.
1393 (package-nicknames pkg)))))
1394 (dolist (warm-nickname warm-nicknames)
1395 (cold-push (base-string-to-core warm-nickname) cold-nicknames)))
1397 (cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
1400 (cold-push (cold-intern :internal-symbols) res)
1401 (cold-push (number-to-core (truncate (package-external-symbol-count pkg)
1404 (cold-push (cold-intern :external-symbols) res)
1406 (cold-push cold-nicknames res)
1407 (cold-push (cold-intern :nicknames) res)
1410 (cold-push (cold-intern :use) res)
1412 (cold-push (base-string-to-core (package-name pkg)) res)
1415 ;;;; functions and fdefinition objects
1417 ;;; a hash table mapping from fdefinition names to descriptors of cold
1420 ;;; Note: Since fdefinition names can be lists like '(SETF FOO), and
1421 ;;; we want to have only one entry per name, this must be an 'EQUAL
1422 ;;; hash table, not the default 'EQL.
1423 (defvar *cold-fdefn-objects*)
1425 (defvar *cold-fdefn-gspace* nil)
1427 ;;; Given a cold representation of a symbol, return a warm
1429 (defun warm-symbol (des)
1430 ;; Note that COLD-INTERN is responsible for keeping the
1431 ;; *COLD-SYMBOLS* table up to date, so if DES happens to refer to an
1432 ;; uninterned symbol, the code below will fail. But as long as we
1433 ;; don't need to look up uninterned symbols during bootstrapping,
1435 (multiple-value-bind (symbol found-p)
1436 (gethash (descriptor-bits des) *cold-symbols*)
1437 (declare (type symbol symbol))
1439 (error "no warm symbol"))
1442 ;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values
1443 (defun cold-car (des)
1444 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
1445 (read-wordindexed des sb!vm:cons-car-slot))
1446 (defun cold-cdr (des)
1447 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
1448 (read-wordindexed des sb!vm:cons-cdr-slot))
1449 (defun cold-null (des)
1450 (= (descriptor-bits des)
1451 (descriptor-bits *nil-descriptor*)))
1453 ;;; Given a cold representation of a function name, return a warm
1455 (declaim (ftype (function (descriptor) (or symbol list)) warm-fun-name))
1456 (defun warm-fun-name (des)
1458 (ecase (descriptor-lowtag des)
1459 (#.sb!vm:list-pointer-lowtag
1460 (aver (not (cold-null des))) ; function named NIL? please no..
1461 ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..).
1462 (let* ((car-des (cold-car des))
1463 (cdr-des (cold-cdr des))
1464 (cadr-des (cold-car cdr-des))
1465 (cddr-des (cold-cdr cdr-des)))
1466 (aver (cold-null cddr-des))
1467 (list (warm-symbol car-des)
1468 (warm-symbol cadr-des))))
1469 (#.sb!vm:other-pointer-lowtag
1470 (warm-symbol des)))))
1471 (legal-fun-name-or-type-error result)
1474 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
1475 (declare (type descriptor cold-name))
1476 (/show0 "/cold-fdefinition-object")
1477 (let ((warm-name (warm-fun-name cold-name)))
1478 (or (gethash warm-name *cold-fdefn-objects*)
1479 (let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace* *dynamic*)
1480 (1- sb!vm:fdefn-size)
1481 sb!vm:other-pointer-lowtag)))
1483 (setf (gethash warm-name *cold-fdefn-objects*) fdefn)
1484 (write-memory fdefn (make-other-immediate-descriptor
1485 (1- sb!vm:fdefn-size) sb!vm:fdefn-widetag))
1486 (write-wordindexed fdefn sb!vm:fdefn-name-slot cold-name)
1487 (unless leave-fn-raw
1488 (write-wordindexed fdefn sb!vm:fdefn-fun-slot
1490 (write-wordindexed fdefn
1491 sb!vm:fdefn-raw-addr-slot
1492 (make-random-descriptor
1493 (cold-foreign-symbol-address-as-integer
1494 "undefined_tramp"))))
1497 ;;; Handle the at-cold-init-time, fset-for-static-linkage operation
1498 ;;; requested by FOP-FSET.
1499 (defun static-fset (cold-name defn)
1500 (declare (type descriptor cold-name))
1501 (let ((fdefn (cold-fdefinition-object cold-name t))
1502 (type (logand (descriptor-low (read-memory defn)) sb!vm:widetag-mask)))
1503 (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn)
1504 (write-wordindexed fdefn
1505 sb!vm:fdefn-raw-addr-slot
1507 (#.sb!vm:simple-fun-header-widetag
1508 (/show0 "static-fset (simple-fun)")
1512 (make-random-descriptor
1513 (+ (logandc2 (descriptor-bits defn)
1515 (ash sb!vm:simple-fun-code-offset
1516 sb!vm:word-shift))))
1517 (#.sb!vm:closure-header-widetag
1518 (/show0 "/static-fset (closure)")
1519 (make-random-descriptor
1520 (cold-foreign-symbol-address-as-integer
1521 "closure_tramp")))))
1524 (defun initialize-static-fns ()
1525 (let ((*cold-fdefn-gspace* *static*))
1526 (dolist (sym sb!vm:*static-funs*)
1527 (let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
1528 (offset (- (+ (- (descriptor-low fdefn)
1529 sb!vm:other-pointer-lowtag)
1530 (* sb!vm:fdefn-raw-addr-slot sb!vm:n-word-bytes))
1531 (descriptor-low *nil-descriptor*)))
1532 (desired (sb!vm:static-fun-offset sym)))
1533 (unless (= offset desired)
1534 ;; FIXME: should be fatal
1535 (error "Offset from FDEFN ~S to ~S is ~W, not ~W."
1536 sym nil offset desired))))))
1538 (defun list-all-fdefn-objects ()
1539 (let ((result *nil-descriptor*))
1540 (maphash (lambda (key value)
1541 (declare (ignore key))
1542 (cold-push value result))
1543 *cold-fdefn-objects*)
1546 ;;;; fixups and related stuff
1548 ;;; an EQUAL hash table
1549 (defvar *cold-foreign-symbol-table*)
1550 (declaim (type hash-table *cold-foreign-symbol-table*))
1552 ;; Read the sbcl.nm file to find the addresses for foreign-symbols in
1554 (defun load-cold-foreign-symbol-table (filename)
1555 (/show "load-cold-foreign-symbol-table" filename)
1556 (with-open-file (file filename)
1557 (loop for line = (read-line file nil nil)
1559 ;; UNIX symbol tables might have tabs in them, and tabs are
1560 ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
1561 ;; nice portable way to deal with them within Lisp, alas.
1562 ;; Fortunately, it's easy to use UNIX command line tools like
1563 ;; sed to remove the problem, so it's not too painful for us
1564 ;; to push responsibility for converting tabs to spaces out to
1567 ;; Other non-STANDARD-CHARs are problematic for the same reason.
1568 ;; Make sure that there aren't any..
1569 (let ((ch (find-if (lambda (char)
1570 (not (typep char 'standard-char)))
1573 (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
1576 (setf line (string-trim '(#\space) line))
1577 (let ((p1 (position #\space line :from-end nil))
1578 (p2 (position #\space line :from-end t)))
1579 (if (not (and p1 p2 (< p1 p2)))
1580 ;; KLUDGE: It's too messy to try to understand all
1581 ;; possible output from nm, so we just punt the lines we
1582 ;; don't recognize. We realize that there's some chance
1583 ;; that might get us in trouble someday, so we warn
1585 (warn "ignoring unrecognized line ~S in ~A" line filename)
1586 (multiple-value-bind (value name)
1587 (if (string= "0x" line :end2 2)
1588 (values (parse-integer line :start 2 :end p1 :radix 16)
1589 (subseq line (1+ p2)))
1590 (values (parse-integer line :end p1 :radix 16)
1591 (subseq line (1+ p2))))
1592 (multiple-value-bind (old-value found)
1593 (gethash name *cold-foreign-symbol-table*)
1595 (not (= old-value value)))
1596 (warn "redefining ~S from #X~X to #X~X"
1597 name old-value value)))
1598 (/show "adding to *cold-foreign-symbol-table*:" name value)
1599 (setf (gethash name *cold-foreign-symbol-table*) value))))))
1602 (defun cold-foreign-symbol-address-as-integer (name)
1603 (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*)
1604 *foreign-symbol-placeholder-value*
1606 (format *error-output* "~&The foreign symbol table is:~%")
1607 (maphash (lambda (k v)
1608 (format *error-output* "~&~S = #X~8X~%" k v))
1609 *cold-foreign-symbol-table*)
1610 (error "The foreign symbol ~S is undefined." name))))
1612 (defvar *cold-assembler-routines*)
1614 (defvar *cold-assembler-fixups*)
1616 (defun record-cold-assembler-routine (name address)
1617 (/xhow "in RECORD-COLD-ASSEMBLER-ROUTINE" name address)
1618 (push (cons name address)
1619 *cold-assembler-routines*))
1621 (defun record-cold-assembler-fixup (routine
1626 (push (list routine code-object offset kind)
1627 *cold-assembler-fixups*))
1629 (defun lookup-assembler-reference (symbol)
1630 (let ((value (cdr (assoc symbol *cold-assembler-routines*))))
1631 ;; FIXME: Should this be ERROR instead of WARN?
1633 (warn "Assembler routine ~S not defined." symbol))
1636 ;;; The x86 port needs to store code fixups along with code objects if
1637 ;;; they are to be moved, so fixups for code objects in the dynamic
1638 ;;; heap need to be noted.
1640 (defvar *load-time-code-fixups*)
1643 (defun note-load-time-code-fixup (code-object offset value kind)
1644 ;; If CODE-OBJECT might be moved
1645 (when (= (gspace-identifier (descriptor-intuit-gspace code-object))
1646 dynamic-core-space-id)
1647 ;; FIXME: pushed thing should be a structure, not just a list
1648 (push (list code-object offset value kind) *load-time-code-fixups*))
1652 (defun output-load-time-code-fixups ()
1653 (dolist (fixups *load-time-code-fixups*)
1654 (let ((code-object (first fixups))
1655 (offset (second fixups))
1656 (value (third fixups))
1657 (kind (fourth fixups)))
1658 (cold-push (cold-cons
1659 (cold-intern :load-time-code-fixup)
1663 (number-to-core offset)
1665 (number-to-core value)
1668 *nil-descriptor*)))))
1669 *current-reversed-cold-toplevels*))))
1671 ;;; Given a pointer to a code object and an offset relative to the
1672 ;;; tail of the code object's header, return an offset relative to the
1673 ;;; (beginning of the) code object.
1675 ;;; FIXME: It might be clearer to reexpress
1676 ;;; (LET ((X (CALC-OFFSET CODE-OBJECT OFFSET0))) ..)
1678 ;;; (LET ((X (+ OFFSET0 (CODE-OBJECT-HEADER-N-BYTES CODE-OBJECT)))) ..).
1679 (declaim (ftype (function (descriptor sb!vm:word)) calc-offset))
1680 (defun calc-offset (code-object offset-from-tail-of-header)
1681 (let* ((header (read-memory code-object))
1682 (header-n-words (ash (descriptor-bits header)
1683 (- sb!vm:n-widetag-bits)))
1684 (header-n-bytes (ash header-n-words sb!vm:word-shift))
1685 (result (+ offset-from-tail-of-header header-n-bytes)))
1688 (declaim (ftype (function (descriptor sb!vm:word sb!vm:word keyword))
1690 (defun do-cold-fixup (code-object after-header value kind)
1691 (let* ((offset-within-code-object (calc-offset code-object after-header))
1692 (gspace-bytes (descriptor-bytes code-object))
1693 (gspace-byte-offset (+ (descriptor-byte-offset code-object)
1694 offset-within-code-object))
1695 (gspace-byte-address (gspace-byte-address
1696 (descriptor-gspace code-object))))
1697 (ecase +backend-fasl-file-implementation+
1698 ;; See CMU CL source for other formerly-supported architectures
1699 ;; (and note that you have to rewrite them to use BVREF-X
1700 ;; instead of SAP-REF).
1704 (assert (zerop (ldb (byte 2 0) value))))
1706 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
1707 (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
1708 (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
1709 (setf (bvref-8 gspace-bytes gspace-byte-offset)
1710 (ldb (byte 8 48) value)
1711 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
1712 (ldb (byte 8 56) value))))
1714 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
1715 (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
1716 (setf (bvref-8 gspace-bytes gspace-byte-offset)
1717 (ldb (byte 8 32) value)
1718 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
1719 (ldb (byte 8 40) value))))
1721 (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
1722 (setf (bvref-8 gspace-bytes gspace-byte-offset)
1723 (ldb (byte 8 16) value)
1724 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
1725 (ldb (byte 8 24) value))))
1727 (setf (bvref-8 gspace-bytes gspace-byte-offset)
1728 (ldb (byte 8 0) value)
1729 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
1730 (ldb (byte 8 8) value)))))
1734 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1735 (logior (ash (ldb (byte 11 0) value) 1)
1736 (logand (bvref-32 gspace-bytes gspace-byte-offset)
1739 (let ((low-bits (ldb (byte 11 0) value)))
1740 (assert (<= 0 low-bits (1- (ash 1 4))))
1741 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1742 (logior (ash low-bits 17)
1743 (logand (bvref-32 gspace-bytes gspace-byte-offset)
1746 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1747 (logior (ash (ldb (byte 5 13) value) 16)
1748 (ash (ldb (byte 2 18) value) 14)
1749 (ash (ldb (byte 2 11) value) 12)
1750 (ash (ldb (byte 11 20) value) 1)
1751 (ldb (byte 1 31) value)
1752 (logand (bvref-32 gspace-bytes gspace-byte-offset)
1755 (let ((bits (ldb (byte 9 2) value)))
1756 (assert (zerop (ldb (byte 2 0) value)))
1757 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1758 (logior (ash bits 3)
1759 (logand (bvref-32 gspace-bytes gspace-byte-offset)
1764 (assert (zerop (ash value -28)))
1765 (setf (ldb (byte 26 0)
1766 (bvref-32 gspace-bytes gspace-byte-offset))
1769 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1770 (logior (mask-field (byte 16 16)
1771 (bvref-32 gspace-bytes gspace-byte-offset))
1773 (if (logbitp 15 value) 1 0)))))
1775 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1776 (logior (mask-field (byte 16 16)
1777 (bvref-32 gspace-bytes gspace-byte-offset))
1778 (ldb (byte 16 0) value))))))
1782 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1783 (dpb (ash value -2) (byte 24 2)
1784 (bvref-32 gspace-bytes gspace-byte-offset))))
1786 (let* ((h (ldb (byte 16 16) value))
1787 (l (ldb (byte 16 0) value)))
1788 (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
1789 (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
1791 (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
1792 (ldb (byte 16 0) value)))))
1796 (error "can't deal with call fixups yet"))
1798 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1799 (dpb (ldb (byte 22 10) value)
1801 (bvref-32 gspace-bytes gspace-byte-offset))))
1803 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1804 (dpb (ldb (byte 10 0) value)
1806 (bvref-32 gspace-bytes gspace-byte-offset))))))
1808 (let* ((un-fixed-up (bvref-word gspace-bytes
1809 gspace-byte-offset))
1810 (code-object-start-addr (logandc2 (descriptor-bits code-object)
1811 sb!vm:lowtag-mask)))
1812 (assert (= code-object-start-addr
1813 (+ gspace-byte-address
1814 (descriptor-byte-offset code-object))))
1817 (let ((fixed-up (+ value un-fixed-up)))
1818 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1820 ;; comment from CMU CL sources:
1822 ;; Note absolute fixups that point within the object.
1823 ;; KLUDGE: There seems to be an implicit assumption in
1824 ;; the old CMU CL code here, that if it doesn't point
1825 ;; before the object, it must point within the object
1826 ;; (not beyond it). It would be good to add an
1827 ;; explanation of why that's true, or an assertion that
1828 ;; it's really true, or both.
1829 (unless (< fixed-up code-object-start-addr)
1830 (note-load-time-code-fixup code-object
1834 (:relative ; (used for arguments to X86 relative CALL instruction)
1835 (let ((fixed-up (- (+ value un-fixed-up)
1838 4))) ; "length of CALL argument"
1839 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1841 ;; Note relative fixups that point outside the code
1842 ;; object, which is to say all relative fixups, since
1843 ;; relative addressing within a code object never needs
1845 (note-load-time-code-fixup code-object
1851 (defun resolve-assembler-fixups ()
1852 (dolist (fixup *cold-assembler-fixups*)
1853 (let* ((routine (car fixup))
1854 (value (lookup-assembler-reference routine)))
1856 (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
1858 ;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in
1859 ;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to
1860 ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
1861 ;;; target-load.lisp refers to.
1862 (defun foreign-symbols-to-core ()
1863 (let ((result *nil-descriptor*))
1864 (maphash (lambda (symbol value)
1865 (cold-push (cold-cons (base-string-to-core symbol)
1866 (number-to-core value))
1868 *cold-foreign-symbol-table*)
1869 (cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result))
1870 (let ((result *nil-descriptor*))
1871 (dolist (rtn *cold-assembler-routines*)
1872 (cold-push (cold-cons (cold-intern (car rtn))
1873 (number-to-core (cdr rtn)))
1875 (cold-set (cold-intern '*!initial-assembler-routines*) result)))
1878 ;;;; general machinery for cold-loading FASL files
1880 ;;; FOP functions for cold loading
1881 (defvar *cold-fop-funs*
1882 ;; We start out with a copy of the ordinary *FOP-FUNS*. The ones
1883 ;; which aren't appropriate for cold load will be destructively
1885 (copy-seq *fop-funs*))
1887 (defvar *normal-fop-funs*)
1889 ;;; Cause a fop to have a special definition for cold load.
1891 ;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version
1892 ;;; (1) looks up the code for this name (created by a previous
1893 ;; DEFINE-FOP) instead of creating a code, and
1894 ;;; (2) stores its definition in the *COLD-FOP-FUNS* vector,
1895 ;;; instead of storing in the *FOP-FUNS* vector.
1896 (defmacro define-cold-fop ((name &key (pushp t) (stackp t)) &rest forms)
1897 (aver (member pushp '(nil t)))
1898 (aver (member stackp '(nil t)))
1899 (let ((code (get name 'fop-code))
1900 (fname (symbolicate "COLD-" name)))
1902 (error "~S is not a defined FOP." name))
1906 `((with-fop-stack ,pushp ,@forms))
1908 (setf (svref *cold-fop-funs* ,code) #',fname))))
1910 (defmacro clone-cold-fop ((name &key (pushp t) (stackp t))
1913 (aver (member pushp '(nil t)))
1914 (aver (member stackp '(nil t)))
1916 (macrolet ((clone-arg () '(read-word-arg)))
1917 (define-cold-fop (,name :pushp ,pushp :stackp ,stackp) ,@forms))
1918 (macrolet ((clone-arg () '(read-byte-arg)))
1919 (define-cold-fop (,small-name :pushp ,pushp :stackp ,stackp) ,@forms))))
1921 ;;; Cause a fop to be undefined in cold load.
1922 (defmacro not-cold-fop (name)
1923 `(define-cold-fop (,name)
1924 (error "The fop ~S is not supported in cold load." ',name)))
1926 ;;; COLD-LOAD loads stuff into the core image being built by calling
1927 ;;; LOAD-AS-FASL with the fop function table rebound to a table of cold
1928 ;;; loading functions.
1929 (defun cold-load (filename)
1931 "Load the file named by FILENAME into the cold load image being built."
1932 (let* ((*normal-fop-funs* *fop-funs*)
1933 (*fop-funs* *cold-fop-funs*)
1934 (*cold-load-filename* (etypecase filename
1936 (pathname (namestring filename)))))
1937 (with-open-file (s filename :element-type '(unsigned-byte 8))
1938 (load-as-fasl s nil nil))))
1940 ;;;; miscellaneous cold fops
1942 (define-cold-fop (fop-misc-trap) *unbound-marker*)
1944 (define-cold-fop (fop-short-character)
1945 (make-character-descriptor (read-byte-arg)))
1947 (define-cold-fop (fop-empty-list) *nil-descriptor*)
1948 (define-cold-fop (fop-truth) (cold-intern t))
1950 (define-cold-fop (fop-normal-load :stackp nil)
1951 (setq *fop-funs* *normal-fop-funs*))
1953 (define-fop (fop-maybe-cold-load 82 :stackp nil)
1954 (when *cold-load-filename*
1955 (setq *fop-funs* *cold-fop-funs*)))
1957 (define-cold-fop (fop-maybe-cold-load :stackp nil))
1959 (clone-cold-fop (fop-struct)
1961 (let* ((size (clone-arg))
1962 (result (allocate-boxed-object *dynamic*
1964 sb!vm:instance-pointer-lowtag))
1965 (layout (pop-stack))
1968 (read-wordindexed layout (+ sb!vm:instance-slots-offset 16))))
1969 (ntagged (- size nuntagged)))
1970 (write-memory result (make-other-immediate-descriptor
1971 size sb!vm:instance-header-widetag))
1972 (write-wordindexed result sb!vm:instance-slots-offset layout)
1973 (do ((index 1 (1+ index)))
1975 (declare (fixnum index))
1976 (write-wordindexed result
1977 (+ index sb!vm:instance-slots-offset)
1978 (if (>= index ntagged)
1979 (descriptor-word-sized-integer (pop-stack))
1983 (define-cold-fop (fop-layout)
1984 (let* ((nuntagged-des (pop-stack))
1985 (length-des (pop-stack))
1986 (depthoid-des (pop-stack))
1987 (cold-inherits (pop-stack))
1989 (old (gethash name *cold-layouts*)))
1990 (declare (type descriptor length-des depthoid-des cold-inherits))
1991 (declare (type symbol name))
1992 ;; If a layout of this name has been defined already
1994 ;; Enforce consistency between the previous definition and the
1995 ;; current definition, then return the previous definition.
1997 ;; FIXME: This would be more maintainable if we used
1998 ;; DEFSTRUCT (:TYPE LIST) to define COLD-LAYOUT. -- WHN 19990825
1999 (old-layout-descriptor
2006 (declare (type descriptor old-layout-descriptor))
2007 (declare (type index old-length old-nuntagged))
2008 (declare (type fixnum old-depthoid))
2009 (declare (type list old-inherits-list))
2010 (aver (eq name old-name))
2011 (let ((length (descriptor-fixnum length-des))
2012 (inherits-list (listify-cold-inherits cold-inherits))
2013 (depthoid (descriptor-fixnum depthoid-des))
2014 (nuntagged (descriptor-fixnum nuntagged-des)))
2015 (unless (= length old-length)
2016 (error "cold loading a reference to class ~S when the compile~%~
2017 time length was ~S and current length is ~S"
2021 (unless (equal inherits-list old-inherits-list)
2022 (error "cold loading a reference to class ~S when the compile~%~
2023 time inherits were ~S~%~
2024 and current inherits are ~S"
2028 (unless (= depthoid old-depthoid)
2029 (error "cold loading a reference to class ~S when the compile~%~
2030 time inheritance depthoid was ~S and current inheritance~%~
2035 (unless (= nuntagged old-nuntagged)
2036 (error "cold loading a reference to class ~S when the compile~%~
2037 time number of untagged slots was ~S and is currently ~S"
2041 old-layout-descriptor)
2042 ;; Make a new definition from scratch.
2043 (make-cold-layout name length-des cold-inherits depthoid-des
2046 ;;;; cold fops for loading symbols
2048 ;;; Load a symbol SIZE characters long from *FASL-INPUT-STREAM* and
2049 ;;; intern that symbol in PACKAGE.
2050 (defun cold-load-symbol (size package)
2051 (let ((string (make-string size)))
2052 (read-string-as-bytes *fasl-input-stream* string)
2053 (cold-intern (intern string package))))
2055 (macrolet ((frob (name pname-len package-len)
2056 `(define-cold-fop (,name)
2057 (let ((index (read-arg ,package-len)))
2059 (cold-load-symbol (read-arg ,pname-len)
2060 (svref *current-fop-table* index)))))))
2061 (frob fop-symbol-in-package-save #.sb!vm:n-word-bytes #.sb!vm:n-word-bytes)
2062 (frob fop-small-symbol-in-package-save 1 #.sb!vm:n-word-bytes)
2063 (frob fop-symbol-in-byte-package-save #.sb!vm:n-word-bytes 1)
2064 (frob fop-small-symbol-in-byte-package-save 1 1))
2066 (clone-cold-fop (fop-lisp-symbol-save)
2067 (fop-lisp-small-symbol-save)
2068 (push-fop-table (cold-load-symbol (clone-arg) *cl-package*)))
2070 (clone-cold-fop (fop-keyword-symbol-save)
2071 (fop-keyword-small-symbol-save)
2072 (push-fop-table (cold-load-symbol (clone-arg) *keyword-package*)))
2074 (clone-cold-fop (fop-uninterned-symbol-save)
2075 (fop-uninterned-small-symbol-save)
2076 (let* ((size (clone-arg))
2077 (name (make-string size)))
2078 (read-string-as-bytes *fasl-input-stream* name)
2079 (let ((symbol-des (allocate-symbol name)))
2080 (push-fop-table symbol-des))))
2082 ;;;; cold fops for loading lists
2084 ;;; Make a list of the top LENGTH things on the fop stack. The last
2085 ;;; cdr of the list is set to LAST.
2086 (defmacro cold-stack-list (length last)
2087 `(do* ((index ,length (1- index))
2088 (result ,last (cold-cons (pop-stack) result)))
2089 ((= index 0) result)
2090 (declare (fixnum index))))
2092 (define-cold-fop (fop-list)
2093 (cold-stack-list (read-byte-arg) *nil-descriptor*))
2094 (define-cold-fop (fop-list*)
2095 (cold-stack-list (read-byte-arg) (pop-stack)))
2096 (define-cold-fop (fop-list-1)
2097 (cold-stack-list 1 *nil-descriptor*))
2098 (define-cold-fop (fop-list-2)
2099 (cold-stack-list 2 *nil-descriptor*))
2100 (define-cold-fop (fop-list-3)
2101 (cold-stack-list 3 *nil-descriptor*))
2102 (define-cold-fop (fop-list-4)
2103 (cold-stack-list 4 *nil-descriptor*))
2104 (define-cold-fop (fop-list-5)
2105 (cold-stack-list 5 *nil-descriptor*))
2106 (define-cold-fop (fop-list-6)
2107 (cold-stack-list 6 *nil-descriptor*))
2108 (define-cold-fop (fop-list-7)
2109 (cold-stack-list 7 *nil-descriptor*))
2110 (define-cold-fop (fop-list-8)
2111 (cold-stack-list 8 *nil-descriptor*))
2112 (define-cold-fop (fop-list*-1)
2113 (cold-stack-list 1 (pop-stack)))
2114 (define-cold-fop (fop-list*-2)
2115 (cold-stack-list 2 (pop-stack)))
2116 (define-cold-fop (fop-list*-3)
2117 (cold-stack-list 3 (pop-stack)))
2118 (define-cold-fop (fop-list*-4)
2119 (cold-stack-list 4 (pop-stack)))
2120 (define-cold-fop (fop-list*-5)
2121 (cold-stack-list 5 (pop-stack)))
2122 (define-cold-fop (fop-list*-6)
2123 (cold-stack-list 6 (pop-stack)))
2124 (define-cold-fop (fop-list*-7)
2125 (cold-stack-list 7 (pop-stack)))
2126 (define-cold-fop (fop-list*-8)
2127 (cold-stack-list 8 (pop-stack)))
2129 ;;;; cold fops for loading vectors
2131 (clone-cold-fop (fop-base-string)
2132 (fop-small-base-string)
2133 (let* ((len (clone-arg))
2134 (string (make-string len)))
2135 (read-string-as-bytes *fasl-input-stream* string)
2136 (base-string-to-core string)))
2139 (clone-cold-fop (fop-character-string)
2140 (fop-small-character-string)
2141 (bug "CHARACTER-STRING dumped by cross-compiler."))
2143 (clone-cold-fop (fop-vector)
2145 (let* ((size (clone-arg))
2146 (result (allocate-vector-object *dynamic*
2149 sb!vm:simple-vector-widetag)))
2150 (do ((index (1- size) (1- index)))
2152 (declare (fixnum index))
2153 (write-wordindexed result
2154 (+ index sb!vm:vector-data-offset)
2158 (define-cold-fop (fop-int-vector)
2159 (let* ((len (read-word-arg))
2160 (sizebits (read-byte-arg))
2161 (type (case sizebits
2162 (0 sb!vm:simple-array-nil-widetag)
2163 (1 sb!vm:simple-bit-vector-widetag)
2164 (2 sb!vm:simple-array-unsigned-byte-2-widetag)
2165 (4 sb!vm:simple-array-unsigned-byte-4-widetag)
2166 (7 (prog1 sb!vm:simple-array-unsigned-byte-7-widetag
2168 (8 sb!vm:simple-array-unsigned-byte-8-widetag)
2169 (15 (prog1 sb!vm:simple-array-unsigned-byte-15-widetag
2170 (setf sizebits 16)))
2171 (16 sb!vm:simple-array-unsigned-byte-16-widetag)
2172 (31 (prog1 sb!vm:simple-array-unsigned-byte-31-widetag
2173 (setf sizebits 32)))
2174 (32 sb!vm:simple-array-unsigned-byte-32-widetag)
2175 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
2176 (63 (prog1 sb!vm:simple-array-unsigned-byte-63-widetag
2177 (setf sizebits 64)))
2178 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
2179 (64 sb!vm:simple-array-unsigned-byte-64-widetag)
2180 (t (error "losing element size: ~W" sizebits))))
2181 (result (allocate-vector-object *dynamic* sizebits len type))
2182 (start (+ (descriptor-byte-offset result)
2183 (ash sb!vm:vector-data-offset sb!vm:word-shift)))
2185 (ceiling (* len sizebits)
2186 sb!vm:n-byte-bits))))
2187 (read-bigvec-as-sequence-or-die (descriptor-bytes result)
2193 (define-cold-fop (fop-single-float-vector)
2194 (let* ((len (read-word-arg))
2195 (result (allocate-vector-object
2199 sb!vm:simple-array-single-float-widetag))
2200 (start (+ (descriptor-byte-offset result)
2201 (ash sb!vm:vector-data-offset sb!vm:word-shift)))
2202 (end (+ start (* len 4))))
2203 (read-bigvec-as-sequence-or-die (descriptor-bytes result)
2209 (not-cold-fop fop-double-float-vector)
2210 #!+long-float (not-cold-fop fop-long-float-vector)
2211 (not-cold-fop fop-complex-single-float-vector)
2212 (not-cold-fop fop-complex-double-float-vector)
2213 #!+long-float (not-cold-fop fop-complex-long-float-vector)
2215 (define-cold-fop (fop-array)
2216 (let* ((rank (read-word-arg))
2217 (data-vector (pop-stack))
2218 (result (allocate-boxed-object *dynamic*
2219 (+ sb!vm:array-dimensions-offset rank)
2220 sb!vm:other-pointer-lowtag)))
2221 (write-memory result
2222 (make-other-immediate-descriptor rank
2223 sb!vm:simple-array-widetag))
2224 (write-wordindexed result sb!vm:array-fill-pointer-slot *nil-descriptor*)
2225 (write-wordindexed result sb!vm:array-data-slot data-vector)
2226 (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
2227 (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)
2228 (let ((total-elements 1))
2229 (dotimes (axis rank)
2230 (let ((dim (pop-stack)))
2231 (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-lowtag)
2232 (= (descriptor-lowtag dim) sb!vm:odd-fixnum-lowtag))
2233 (error "non-fixnum dimension? (~S)" dim))
2234 (setf total-elements
2236 (logior (ash (descriptor-high dim)
2237 (- descriptor-low-bits
2238 (1- sb!vm:n-lowtag-bits)))
2239 (ash (descriptor-low dim)
2240 (- 1 sb!vm:n-lowtag-bits)))))
2241 (write-wordindexed result
2242 (+ sb!vm:array-dimensions-offset axis)
2244 (write-wordindexed result
2245 sb!vm:array-elements-slot
2246 (make-fixnum-descriptor total-elements)))
2250 ;;;; cold fops for loading numbers
2252 (defmacro define-cold-number-fop (fop)
2253 `(define-cold-fop (,fop :stackp nil)
2254 ;; Invoke the ordinary warm version of this fop to push the
2257 ;; Replace the warm fop result with the cold image of the warm
2260 (let ((number (pop-stack)))
2261 (number-to-core number)))))
2263 (define-cold-number-fop fop-single-float)
2264 (define-cold-number-fop fop-double-float)
2265 (define-cold-number-fop fop-integer)
2266 (define-cold-number-fop fop-small-integer)
2267 (define-cold-number-fop fop-word-integer)
2268 (define-cold-number-fop fop-byte-integer)
2269 (define-cold-number-fop fop-complex-single-float)
2270 (define-cold-number-fop fop-complex-double-float)
2272 (define-cold-fop (fop-ratio)
2273 (let ((den (pop-stack)))
2274 (number-pair-to-core (pop-stack) den sb!vm:ratio-widetag)))
2276 (define-cold-fop (fop-complex)
2277 (let ((im (pop-stack)))
2278 (number-pair-to-core (pop-stack) im sb!vm:complex-widetag)))
2280 ;;;; cold fops for calling (or not calling)
2282 (not-cold-fop fop-eval)
2283 (not-cold-fop fop-eval-for-effect)
2285 (defvar *load-time-value-counter*)
2287 (define-cold-fop (fop-funcall)
2288 (unless (= (read-byte-arg) 0)
2289 (error "You can't FOP-FUNCALL arbitrary stuff in cold load."))
2290 (let ((counter *load-time-value-counter*))
2291 (cold-push (cold-cons
2292 (cold-intern :load-time-value)
2296 (number-to-core counter)
2298 *current-reversed-cold-toplevels*)
2299 (setf *load-time-value-counter* (1+ counter))
2300 (make-descriptor 0 0 nil counter)))
2302 (defun finalize-load-time-value-noise ()
2303 (cold-set (cold-intern '*!load-time-values*)
2304 (allocate-vector-object *dynamic*
2306 *load-time-value-counter*
2307 sb!vm:simple-vector-widetag)))
2309 (define-cold-fop (fop-funcall-for-effect :pushp nil)
2310 (if (= (read-byte-arg) 0)
2311 (cold-push (pop-stack)
2312 *current-reversed-cold-toplevels*)
2313 (error "You can't FOP-FUNCALL arbitrary stuff in cold load.")))
2315 ;;;; cold fops for fixing up circularities
2317 (define-cold-fop (fop-rplaca :pushp nil)
2318 (let ((obj (svref *current-fop-table* (read-word-arg)))
2319 (idx (read-word-arg)))
2320 (write-memory (cold-nthcdr idx obj) (pop-stack))))
2322 (define-cold-fop (fop-rplacd :pushp nil)
2323 (let ((obj (svref *current-fop-table* (read-word-arg)))
2324 (idx (read-word-arg)))
2325 (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack))))
2327 (define-cold-fop (fop-svset :pushp nil)
2328 (let ((obj (svref *current-fop-table* (read-word-arg)))
2329 (idx (read-word-arg)))
2330 (write-wordindexed obj
2332 (ecase (descriptor-lowtag obj)
2333 (#.sb!vm:instance-pointer-lowtag 1)
2334 (#.sb!vm:other-pointer-lowtag 2)))
2337 (define-cold-fop (fop-structset :pushp nil)
2338 (let ((obj (svref *current-fop-table* (read-word-arg)))
2339 (idx (read-word-arg)))
2340 (write-wordindexed obj (1+ idx) (pop-stack))))
2342 ;;; In the original CMUCL code, this actually explicitly declared PUSHP
2343 ;;; to be T, even though that's what it defaults to in DEFINE-COLD-FOP.
2344 (define-cold-fop (fop-nthcdr)
2345 (cold-nthcdr (read-word-arg) (pop-stack)))
2347 (defun cold-nthcdr (index obj)
2349 (setq obj (read-wordindexed obj 1)))
2352 ;;;; cold fops for loading code objects and functions
2354 ;;; the names of things which have had COLD-FSET used on them already
2355 ;;; (used to make sure that we don't try to statically link a name to
2356 ;;; more than one definition)
2357 (defparameter *cold-fset-warm-names*
2358 ;; This can't be an EQL hash table because names can be conses, e.g.
2360 (make-hash-table :test 'equal))
2362 (define-cold-fop (fop-fset :pushp nil)
2363 (let* ((fn (pop-stack))
2364 (cold-name (pop-stack))
2365 (warm-name (warm-fun-name cold-name)))
2366 (if (gethash warm-name *cold-fset-warm-names*)
2367 (error "duplicate COLD-FSET for ~S" warm-name)
2368 (setf (gethash warm-name *cold-fset-warm-names*) t))
2369 (static-fset cold-name fn)))
2371 (define-cold-fop (fop-fdefinition)
2372 (cold-fdefinition-object (pop-stack)))
2374 (define-cold-fop (fop-sanctify-for-execution)
2377 ;;; Setting this variable shows what code looks like before any
2378 ;;; fixups (or function headers) are applied.
2379 #!+sb-show (defvar *show-pre-fixup-code-p* nil)
2381 ;;; FIXME: The logic here should be converted into a function
2382 ;;; COLD-CODE-FOP-GUTS (NCONST CODE-SIZE) called by DEFINE-COLD-FOP
2383 ;;; FOP-CODE and DEFINE-COLD-FOP FOP-SMALL-CODE, so that
2384 ;;; variable-capture nastiness like (LET ((NCONST ,NCONST) ..) ..)
2385 ;;; doesn't keep me awake at night.
2386 (defmacro define-cold-code-fop (name nconst code-size)
2387 `(define-cold-fop (,name)
2388 (let* ((nconst ,nconst)
2389 (code-size ,code-size)
2390 (raw-header-n-words (+ sb!vm:code-trace-table-offset-slot nconst))
2392 ;; Note: we round the number of constants up to ensure
2393 ;; that the code vector will be properly aligned.
2394 (round-up raw-header-n-words 2))
2395 (des (allocate-cold-descriptor *dynamic*
2396 (+ (ash header-n-words
2399 sb!vm:other-pointer-lowtag)))
2401 (make-other-immediate-descriptor
2402 header-n-words sb!vm:code-header-widetag))
2403 (write-wordindexed des
2404 sb!vm:code-code-size-slot
2405 (make-fixnum-descriptor
2406 (ash (+ code-size (1- (ash 1 sb!vm:word-shift)))
2407 (- sb!vm:word-shift))))
2408 (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
2409 (write-wordindexed des sb!vm:code-debug-info-slot (pop-stack))
2410 (when (oddp raw-header-n-words)
2411 (write-wordindexed des
2413 (make-random-descriptor 0)))
2414 (do ((index (1- raw-header-n-words) (1- index)))
2415 ((< index sb!vm:code-trace-table-offset-slot))
2416 (write-wordindexed des index (pop-stack)))
2417 (let* ((start (+ (descriptor-byte-offset des)
2418 (ash header-n-words sb!vm:word-shift)))
2419 (end (+ start code-size)))
2420 (read-bigvec-as-sequence-or-die (descriptor-bytes des)
2425 (when *show-pre-fixup-code-p*
2426 (format *trace-output*
2427 "~&/raw code from code-fop ~W ~W:~%"
2430 (do ((i start (+ i sb!vm:n-word-bytes)))
2432 (format *trace-output*
2433 "/#X~8,'0x: #X~8,'0x~%"
2434 (+ i (gspace-byte-address (descriptor-gspace des)))
2435 (bvref-32 (descriptor-bytes des) i)))))
2438 (define-cold-code-fop fop-code (read-word-arg) (read-word-arg))
2440 (define-cold-code-fop fop-small-code (read-byte-arg) (read-halfword-arg))
2442 (clone-cold-fop (fop-alter-code :pushp nil)
2443 (fop-byte-alter-code)
2444 (let ((slot (clone-arg))
2447 (write-wordindexed code slot value)))
2449 (define-cold-fop (fop-fun-entry)
2450 (let* ((type (pop-stack))
2451 (arglist (pop-stack))
2453 (code-object (pop-stack))
2454 (offset (calc-offset code-object (read-word-arg)))
2455 (fn (descriptor-beyond code-object
2457 sb!vm:fun-pointer-lowtag))
2458 (next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
2459 (unless (zerop (logand offset sb!vm:lowtag-mask))
2460 (error "unaligned function entry: ~S at #X~X" name offset))
2461 (write-wordindexed code-object sb!vm:code-entry-points-slot fn)
2463 (make-other-immediate-descriptor
2464 (ash offset (- sb!vm:word-shift))
2465 sb!vm:simple-fun-header-widetag))
2466 (write-wordindexed fn
2467 sb!vm:simple-fun-self-slot
2468 ;; KLUDGE: Wiring decisions like this in at
2469 ;; this level ("if it's an x86") instead of a
2470 ;; higher level of abstraction ("if it has such
2471 ;; and such relocation peculiarities (which
2472 ;; happen to be confined to the x86)") is bad.
2473 ;; It would be nice if the code were instead
2474 ;; conditional on some more descriptive
2475 ;; feature, :STICKY-CODE or
2476 ;; :LOAD-GC-INTERACTION or something.
2478 ;; FIXME: The X86 definition of the function
2479 ;; self slot breaks everything object.tex says
2480 ;; about it. (As far as I can tell, the X86
2481 ;; definition makes it a pointer to the actual
2482 ;; code instead of a pointer back to the object
2483 ;; itself.) Ask on the mailing list whether
2484 ;; this is documented somewhere, and if not,
2485 ;; try to reverse engineer some documentation.
2487 ;; a pointer back to the function object, as
2488 ;; described in CMU CL
2489 ;; src/docs/internals/object.tex
2492 ;; KLUDGE: a pointer to the actual code of the
2493 ;; object, as described nowhere that I can find
2495 (make-random-descriptor
2496 (+ (descriptor-bits fn)
2497 (- (ash sb!vm:simple-fun-code-offset
2499 ;; FIXME: We should mask out the type
2500 ;; bits, not assume we know what they
2501 ;; are and subtract them out this way.
2502 sb!vm:fun-pointer-lowtag))))
2503 (write-wordindexed fn sb!vm:simple-fun-next-slot next)
2504 (write-wordindexed fn sb!vm:simple-fun-name-slot name)
2505 (write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist)
2506 (write-wordindexed fn sb!vm:simple-fun-type-slot type)
2509 (define-cold-fop (fop-foreign-fixup)
2510 (let* ((kind (pop-stack))
2511 (code-object (pop-stack))
2512 (len (read-byte-arg))
2513 (sym (make-string len)))
2514 (read-string-as-bytes *fasl-input-stream* sym)
2515 (let ((offset (read-word-arg))
2516 (value (cold-foreign-symbol-address-as-integer sym)))
2517 (do-cold-fixup code-object offset value kind))
2521 (define-cold-fop (fop-foreign-dataref-fixup)
2522 (let* ((kind (pop-stack))
2523 (code-object (pop-stack))
2524 (len (read-byte-arg))
2525 (sym (make-string len)))
2526 (read-string-as-bytes *fasl-input-stream* sym)
2527 (maphash (lambda (k v)
2528 (format *error-output* "~&~S = #X~8X~%" k v))
2529 *cold-foreign-symbol-table*)
2530 (error "shared foreign symbol in cold load: ~S (~S)" sym kind)))
2532 (define-cold-fop (fop-assembler-code)
2533 (let* ((length (read-word-arg))
2535 ;; Note: we round the number of constants up to ensure that
2536 ;; the code vector will be properly aligned.
2537 (round-up sb!vm:code-constants-offset 2))
2538 (des (allocate-cold-descriptor *read-only*
2539 (+ (ash header-n-words
2542 sb!vm:other-pointer-lowtag)))
2544 (make-other-immediate-descriptor
2545 header-n-words sb!vm:code-header-widetag))
2546 (write-wordindexed des
2547 sb!vm:code-code-size-slot
2548 (make-fixnum-descriptor
2549 (ash (+ length (1- (ash 1 sb!vm:word-shift)))
2550 (- sb!vm:word-shift))))
2551 (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
2552 (write-wordindexed des sb!vm:code-debug-info-slot *nil-descriptor*)
2554 (let* ((start (+ (descriptor-byte-offset des)
2555 (ash header-n-words sb!vm:word-shift)))
2556 (end (+ start length)))
2557 (read-bigvec-as-sequence-or-die (descriptor-bytes des)
2563 (define-cold-fop (fop-assembler-routine)
2564 (let* ((routine (pop-stack))
2566 (offset (calc-offset des (read-word-arg))))
2567 (record-cold-assembler-routine
2569 (+ (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) offset))
2572 (define-cold-fop (fop-assembler-fixup)
2573 (let* ((routine (pop-stack))
2575 (code-object (pop-stack))
2576 (offset (read-word-arg)))
2577 (record-cold-assembler-fixup routine code-object offset kind)
2580 (define-cold-fop (fop-code-object-fixup)
2581 (let* ((kind (pop-stack))
2582 (code-object (pop-stack))
2583 (offset (read-word-arg))
2584 (value (descriptor-bits code-object)))
2585 (do-cold-fixup code-object offset value kind)
2588 ;;;; emitting C header file
2590 (defun tailwise-equal (string tail)
2591 (and (>= (length string) (length tail))
2592 (string= string tail :start1 (- (length string) (length tail)))))
2594 (defun write-boilerplate ()
2597 '("This is a machine-generated file. Please do not edit it by hand."
2598 "(As of sbcl-0.8.14, it came from WRITE-CONFIG-H in genesis.lisp.)"
2600 "This file contains low-level information about the"
2601 "internals of a particular version and configuration"
2602 "of SBCL. It is used by the C compiler to create a runtime"
2603 "support environment, an executable program in the host"
2604 "operating system's native format, which can then be used to"
2605 "load and run 'core' files, which are basically programs"
2606 "in SBCL's own format."))
2607 (format t " * ~A~%" line))
2610 (defun write-config-h ()
2611 ;; propagating *SHEBANG-FEATURES* into C-level #define's
2612 (dolist (shebang-feature-name (sort (mapcar #'symbol-name
2613 sb-cold:*shebang-features*)
2616 "#define LISP_FEATURE_~A~%"
2617 (substitute #\_ #\- shebang-feature-name)))
2619 ;; and miscellaneous constants
2620 (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
2622 "#define SBCL_VERSION_STRING ~S~%"
2623 (sb!xc:lisp-implementation-version))
2624 (format t "#define CORE_MAGIC 0x~X~%" core-magic)
2625 (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
2626 (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
2627 (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
2628 (format t "#define LISPOBJ(thing) thing~2%")
2629 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")
2632 (defun write-constants-h ()
2633 ;; writing entire families of named constants
2634 (let ((constants nil))
2635 (dolist (package-name '(;; Even in CMU CL, constants from VM
2636 ;; were automatically propagated
2637 ;; into the runtime.
2639 ;; In SBCL, we also propagate various
2640 ;; magic numbers related to file format,
2641 ;; which live here instead of SB!VM.
2643 (do-external-symbols (symbol (find-package package-name))
2644 (when (constantp symbol)
2645 (let ((name (symbol-name symbol)))
2646 (labels (;; shared machinery
2647 (record (string priority)
2650 (symbol-value symbol)
2651 (documentation symbol 'variable))
2653 ;; machinery for old-style CMU CL Lisp-to-C
2654 ;; arbitrary renaming, being phased out in favor of
2655 ;; the newer systematic RECORD-WITH-TRANSLATED-NAME
2657 (record-with-munged-name (prefix string priority)
2658 (record (concatenate
2661 (delete #\- (string-capitalize string)))
2663 (maybe-record-with-munged-name (tail prefix priority)
2664 (when (tailwise-equal name tail)
2665 (record-with-munged-name prefix
2670 ;; machinery for new-style SBCL Lisp-to-C naming
2671 (record-with-translated-name (priority)
2672 (record (substitute #\_ #\- name)
2674 (maybe-record-with-translated-name (suffixes priority)
2675 (when (some (lambda (suffix)
2676 (tailwise-equal name suffix))
2678 (record-with-translated-name priority))))
2680 (maybe-record-with-translated-name '("-LOWTAG") 0)
2681 (maybe-record-with-translated-name '("-WIDETAG") 1)
2682 (maybe-record-with-munged-name "-FLAG" "flag_" 2)
2683 (maybe-record-with-munged-name "-TRAP" "trap_" 3)
2684 (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
2685 (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
2686 (maybe-record-with-translated-name '("-START" "-END" "-SIZE") 6)
2687 (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7)
2688 (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8))))))
2689 ;; KLUDGE: these constants are sort of important, but there's no
2690 ;; pleasing way to inform the code above about them. So we fake
2691 ;; it for now. nikodemus on #lisp (2004-08-09) suggested simply
2692 ;; exporting every numeric constant from SB!VM; that would work,
2693 ;; but the C runtime would have to be altered to use Lisp-like names
2694 ;; rather than the munged names currently exported. --njf, 2004-08-09
2695 (dolist (c '(sb!vm:n-word-bits sb!vm:n-word-bytes
2696 sb!vm:n-lowtag-bits sb!vm:lowtag-mask
2697 sb!vm:n-widetag-bits sb!vm:widetag-mask
2698 sb!vm:n-fixnum-tag-bits sb!vm:fixnum-tag-mask))
2699 (push (list (substitute #\_ #\- (symbol-name c))
2700 -1 ; invent a new priority
2707 (lambda (const1 const2)
2708 (if (= (second const1) (second const2))
2709 (< (third const1) (third const2))
2710 (< (second const1) (second const2))))))
2711 (let ((prev-priority (second (car constants))))
2712 (dolist (const constants)
2713 (destructuring-bind (name priority value doc) const
2714 (unless (= prev-priority priority)
2716 (setf prev-priority priority))
2717 (format t "#define ~A " name)
2719 ;; KLUDGE: As of sbcl-0.6.7.14, we're dumping two
2720 ;; different kinds of values here, (1) small codes
2721 ;; and (2) machine addresses. The small codes can be
2722 ;; dumped as bare integer values. The large machine
2723 ;; addresses might cause problems if they're large
2724 ;; and represented as (signed) C integers, so we
2725 ;; want to force them to be unsigned. We do that by
2726 ;; wrapping them in the LISPOBJ macro. (We could do
2727 ;; it with a bare "(unsigned)" cast, except that
2728 ;; this header file is used not only in C files, but
2729 ;; also in assembly files, which don't understand
2730 ;; the cast syntax. The LISPOBJ macro goes away in
2731 ;; assembly files, but that shouldn't matter because
2732 ;; we don't do arithmetic on address constants in
2733 ;; assembly files. See? It really is a kludge..) --
2735 (let (;; cutoff for treatment as a small code
2736 (cutoff (expt 2 16)))
2737 (cond ((minusp value)
2738 (error "stub: negative values unsupported"))
2744 (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc))))
2747 ;; writing information about internal errors
2748 (let ((internal-errors sb!c:*backend-internal-errors*))
2749 (dotimes (i (length internal-errors))
2750 (let ((current-error (aref internal-errors i)))
2751 ;; FIXME: this UNLESS should go away (see also FIXME in
2752 ;; interr.lisp) -- APD, 2002-03-05
2753 (unless (eq nil (car current-error))
2754 (format t "#define ~A ~D~%"
2755 (substitute #\_ #\- (symbol-name (car current-error)))
2759 ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between
2760 ;; platforms. If we export this from the SB!VM package, it gets
2761 ;; written out as #define trap_PseudoAtomic, which is confusing as
2762 ;; the runtime treats trap_ as the prefix for illegal instruction
2763 ;; type things. We therefore don't export it, but instead do
2765 (when (boundp 'sb!vm::pseudo-atomic-trap)
2767 "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%"
2768 sb!vm::pseudo-atomic-trap)
2770 ;; possibly this is another candidate for a rename (to
2771 ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
2772 ;; [possibly applicable to other platforms])
2774 (dolist (symbol '(sb!vm::float-traps-byte
2775 sb!vm::float-exceptions-byte
2776 sb!vm::float-sticky-bits
2777 sb!vm::float-rounding-mode))
2778 (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%"
2779 (substitute #\_ #\- (symbol-name symbol))
2780 (sb!xc:byte-position (symbol-value symbol)))
2781 (format t "#define ~A_MASK 0x~X /* ~:*~A */~%"
2782 (substitute #\_ #\- (symbol-name symbol))
2783 (sb!xc:mask-field (symbol-value symbol) -1))))
2787 (defun write-primitive-object (obj)
2788 ;; writing primitive object layouts
2789 (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
2793 (string-downcase (string (sb!vm:primitive-object-name obj)))))
2794 (when (sb!vm:primitive-object-widetag obj)
2795 (format t " lispobj header;~%"))
2796 (dolist (slot (sb!vm:primitive-object-slots obj))
2797 (format t " ~A ~A~@[[1]~];~%"
2798 (getf (sb!vm:slot-options slot) :c-type "lispobj")
2800 (string-downcase (string (sb!vm:slot-name slot))))
2801 (sb!vm:slot-rest-p slot)))
2803 (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
2804 (let ((name (sb!vm:primitive-object-name obj))
2805 (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
2807 (dolist (slot (sb!vm:primitive-object-slots obj))
2808 (format t "#define ~A_~A_OFFSET ~D~%"
2809 (substitute #\_ #\- (string name))
2810 (substitute #\_ #\- (string (sb!vm:slot-name slot)))
2811 (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
2813 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
2815 (defun write-structure-object (dd)
2816 (flet ((cstring (designator)
2817 (substitute #\_ #\- (string-downcase (string designator)))))
2818 (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
2819 (format t "struct ~A {~%" (cstring (dd-name dd)))
2820 (format t " lispobj header;~%")
2821 (format t " lispobj layout;~%")
2822 (dolist (slot (dd-slots dd))
2823 (when (eq t (dsd-raw-type slot))
2824 (format t " lispobj ~A;~%" (cstring (dsd-name slot)))))
2825 (unless (oddp (+ (dd-length dd) (dd-raw-length dd)))
2826 (format t " long raw_slot_padding;~%"))
2827 (dotimes (n (dd-raw-length dd))
2828 (format t " long raw~D;~%" (- (dd-raw-length dd) n 1)))
2830 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")))
2832 (defun write-static-symbols ()
2833 (dolist (symbol (cons nil sb!vm:*static-symbols*))
2834 ;; FIXME: It would be nice to use longer names than NIL and
2835 ;; (particularly) T in #define statements.
2836 (format t "#define ~A LISPOBJ(0x~X)~%"
2838 (remove-if (lambda (char)
2839 (member char '(#\% #\* #\. #\!)))
2840 (symbol-name symbol)))
2841 (if *static* ; if we ran GENESIS
2842 ;; We actually ran GENESIS, use the real value.
2843 (descriptor-bits (cold-intern symbol))
2844 ;; We didn't run GENESIS, so guess at the address.
2845 (+ sb!vm:static-space-start
2847 sb!vm:other-pointer-lowtag
2848 (if symbol (sb!vm:static-symbol-offset symbol) 0))))))
2851 ;;;; writing map file
2853 ;;; Write a map file describing the cold load. Some of this
2854 ;;; information is subject to change due to relocating GC, but even so
2855 ;;; it can be very handy when attempting to troubleshoot the early
2856 ;;; stages of cold load.
2858 (let ((*print-pretty* nil)
2859 (*print-case* :upcase))
2860 (format t "assembler routines defined in core image:~2%")
2861 (dolist (routine (sort (copy-list *cold-assembler-routines*) #'<
2863 (format t "#X~8,'0X: ~S~%" (cdr routine) (car routine)))
2866 (maphash (lambda (name fdefn)
2867 (let ((fun (read-wordindexed fdefn
2868 sb!vm:fdefn-fun-slot)))
2869 (if (= (descriptor-bits fun)
2870 (descriptor-bits *nil-descriptor*))
2872 (let ((addr (read-wordindexed
2873 fdefn sb!vm:fdefn-raw-addr-slot)))
2874 (push (cons name (descriptor-bits addr))
2876 *cold-fdefn-objects*)
2877 (format t "~%~|~%initially defined functions:~2%")
2878 (setf funs (sort funs #'< :key #'cdr))
2880 (format t "0x~8,'0X: ~S #X~8,'0X~%" (cdr info) (car info)
2881 (- (cdr info) #x17)))
2884 (a note about initially undefined function references: These functions
2885 are referred to by code which is installed by GENESIS, but they are not
2886 installed by GENESIS. This is not necessarily a problem; functions can
2887 be defined later, by cold init toplevel forms, or in files compiled and
2888 loaded at warm init, or elsewhere. As long as they are defined before
2889 they are called, everything should be OK. Things are also OK if the
2890 cross-compiler knew their inline definition and used that everywhere
2891 that they were called before the out-of-line definition is installed,
2892 as is fairly common for structure accessors.)
2893 initially undefined function references:~2%")
2895 (setf undefs (sort undefs #'string< :key #'fun-name-block-name))
2896 (dolist (name undefs)
2897 (format t "~S~%" name)))
2899 (format t "~%~|~%layout names:~2%")
2901 (maphash (lambda (name gorp)
2902 (declare (ignore name))
2903 (stuff (cons (descriptor-bits (car gorp))
2906 (dolist (x (sort (stuff) #'< :key #'car))
2907 (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x))))
2911 ;;;; writing core file
2913 (defvar *core-file*)
2914 (defvar *data-page*)
2916 ;;; magic numbers to identify entries in a core file
2918 ;;; (In case you were wondering: No, AFAIK there's no special magic about
2919 ;;; these which requires them to be in the 38xx range. They're just
2920 ;;; arbitrary words, tested not for being in a particular range but just
2921 ;;; for equality. However, if you ever need to look at a .core file and
2922 ;;; figure out what's going on, it's slightly convenient that they're
2923 ;;; all in an easily recognizable range, and displacing the range away from
2924 ;;; zero seems likely to reduce the chance that random garbage will be
2925 ;;; misinterpreted as a .core file.)
2926 (defconstant version-core-entry-type-code 3860)
2927 (defconstant build-id-core-entry-type-code 3899)
2928 (defconstant new-directory-core-entry-type-code 3861)
2929 (defconstant initial-fun-core-entry-type-code 3863)
2930 (defconstant end-core-entry-type-code 3840)
2932 (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))
2933 (defun write-word (num)
2934 (ecase sb!c:*backend-byte-order*
2936 (dotimes (i sb!vm:n-word-bytes)
2937 (write-byte (ldb (byte 8 (* i 8)) num) *core-file*)))
2939 (dotimes (i sb!vm:n-word-bytes)
2940 (write-byte (ldb (byte 8 (* (- (1- sb!vm:n-word-bytes) i) 8)) num)
2944 (defun advance-to-page ()
2945 (force-output *core-file*)
2946 (file-position *core-file*
2947 (round-up (file-position *core-file*)
2948 sb!c:*backend-page-size*)))
2950 (defun output-gspace (gspace)
2951 (force-output *core-file*)
2952 (let* ((posn (file-position *core-file*))
2953 (bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes))
2954 (pages (ceiling bytes sb!c:*backend-page-size*))
2955 (total-bytes (* pages sb!c:*backend-page-size*)))
2957 (file-position *core-file*
2958 (* sb!c:*backend-page-size* (1+ *data-page*)))
2960 "writing ~S byte~:P [~S page~:P] from ~S~%"
2966 ;; Note: It is assumed that the GSPACE allocation routines always
2967 ;; allocate whole pages (of size *target-page-size*) and that any
2968 ;; empty gspace between the free pointer and the end of page will
2969 ;; be zero-filled. This will always be true under Mach on machines
2970 ;; where the page size is equal. (RT is 4K, PMAX is 4K, Sun 3 is
2972 (write-bigvec-as-sequence (gspace-bytes gspace)
2975 (force-output *core-file*)
2976 (file-position *core-file* posn)
2978 ;; Write part of a (new) directory entry which looks like this:
2979 ;; GSPACE IDENTIFIER
2984 (write-word (gspace-identifier gspace))
2985 (write-word (gspace-free-word-index gspace))
2986 (write-word *data-page*)
2987 (multiple-value-bind (floor rem)
2988 (floor (gspace-byte-address gspace) sb!c:*backend-page-size*)
2993 (incf *data-page* pages)))
2995 ;;; Create a core file created from the cold loaded image. (This is
2996 ;;; the "initial core file" because core files could be created later
2997 ;;; by executing SAVE-LISP in a running system, perhaps after we've
2998 ;;; added some functionality to the system.)
2999 (declaim (ftype (function (string)) write-initial-core-file))
3000 (defun write-initial-core-file (filename)
3002 (let ((filenamestring (namestring filename))
3006 "[building initial core file in ~S: ~%"
3010 (with-open-file (*core-file* filenamestring
3012 :element-type '(unsigned-byte 8)
3013 :if-exists :rename-and-delete)
3015 ;; Write the magic number.
3016 (write-word core-magic)
3018 ;; Write the Version entry.
3019 (write-word version-core-entry-type-code)
3021 (write-word sbcl-core-version-integer)
3023 ;; Write the build ID.
3024 (write-word build-id-core-entry-type-code)
3025 (let ((build-id (with-open-file (s "output/build-id.tmp"
3028 (declare (type simple-string build-id))
3029 (/show build-id (length build-id))
3030 ;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE
3031 ;; word, this length word, and one word for each char of BUILD-ID.
3032 (write-word (+ 2 (length build-id)))
3033 (dovector (char build-id)
3034 ;; (We write each character as a word in order to avoid
3035 ;; having to think about word alignment issues in the
3036 ;; sbcl-0.7.8 version of coreparse.c.)
3037 (write-word (sb!xc:char-code char))))
3039 ;; Write the New Directory entry header.
3040 (write-word new-directory-core-entry-type-code)
3041 (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header.
3043 (output-gspace *read-only*)
3044 (output-gspace *static*)
3045 (output-gspace *dynamic*)
3047 ;; Write the initial function.
3048 (write-word initial-fun-core-entry-type-code)
3050 (let* ((cold-name (cold-intern '!cold-init))
3051 (cold-fdefn (cold-fdefinition-object cold-name))
3052 (initial-fun (read-wordindexed cold-fdefn
3053 sb!vm:fdefn-fun-slot)))
3055 "~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%"
3056 (descriptor-bits initial-fun))
3057 (write-word (descriptor-bits initial-fun)))
3059 ;; Write the End entry.
3060 (write-word end-core-entry-type-code)
3063 (format t "done]~%")
3065 (/show "leaving WRITE-INITIAL-CORE-FILE")
3068 ;;;; the actual GENESIS function
3070 ;;; Read the FASL files in OBJECT-FILE-NAMES and produce a Lisp core,
3071 ;;; and/or information about a Lisp core, therefrom.
3073 ;;; input file arguments:
3074 ;;; SYMBOL-TABLE-FILE-NAME names a UNIX-style .nm file *with* *any*
3075 ;;; *tab* *characters* *converted* *to* *spaces*. (We push
3076 ;;; responsibility for removing tabs out to the caller it's
3077 ;;; trivial to remove them using UNIX command line tools like
3078 ;;; sed, whereas it's a headache to do it portably in Lisp because
3079 ;;; #\TAB is not a STANDARD-CHAR.) If this file is not supplied,
3080 ;;; a core file cannot be built (but a C header file can be).
3082 ;;; output files arguments (any of which may be NIL to suppress output):
3083 ;;; CORE-FILE-NAME gets a Lisp core.
3084 ;;; C-HEADER-FILE-NAME gets a C header file, traditionally called
3085 ;;; internals.h, which is used by the C compiler when constructing
3086 ;;; the executable which will load the core.
3087 ;;; MAP-FILE-NAME gets (?) a map file. (dunno about this -- WHN 19990815)
3089 ;;; FIXME: GENESIS doesn't belong in SB!VM. Perhaps in %KERNEL for now,
3090 ;;; perhaps eventually in SB-LD or SB-BOOT.
3091 (defun sb!vm:genesis (&key
3093 symbol-table-file-name
3099 "~&beginning GENESIS, ~A~%"
3101 ;; Note: This output summarizing what we're doing is
3102 ;; somewhat telegraphic in style, not meant to imply that
3103 ;; we're not e.g. also creating a header file when we
3105 (format nil "creating core ~S" core-file-name)
3106 (format nil "creating headers in ~S" c-header-dir-name)))
3108 (let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
3110 (when core-file-name
3111 (if symbol-table-file-name
3112 (load-cold-foreign-symbol-table symbol-table-file-name)
3113 (error "can't output a core file without symbol table file input")))
3115 ;; Now that we've successfully read our only input file (by
3116 ;; loading the symbol table, if any), it's a good time to ensure
3117 ;; that there'll be someplace for our output files to go when
3119 (flet ((frob (filename)
3121 (ensure-directories-exist filename :verbose t))))
3122 (frob core-file-name)
3123 (frob map-file-name))
3125 ;; (This shouldn't matter in normal use, since GENESIS normally
3126 ;; only runs once in any given Lisp image, but it could reduce
3127 ;; confusion if we ever experiment with running, tweaking, and
3128 ;; rerunning genesis interactively.)
3129 (do-all-symbols (sym)
3130 (remprop sym 'cold-intern-info))
3132 (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0))
3133 (*load-time-value-counter* 0)
3134 (*cold-fdefn-objects* (make-hash-table :test 'equal))
3135 (*cold-symbols* (make-hash-table :test 'equal))
3136 (*cold-package-symbols* nil)
3137 (*read-only* (make-gspace :read-only
3138 read-only-core-space-id
3139 sb!vm:read-only-space-start))
3140 (*static* (make-gspace :static
3141 static-core-space-id
3142 sb!vm:static-space-start))
3143 (*dynamic* (make-gspace :dynamic
3144 dynamic-core-space-id
3145 #!+gencgc sb!vm:dynamic-space-start
3146 #!-gencgc sb!vm:dynamic-0-space-start))
3147 (*nil-descriptor* (make-nil-descriptor))
3148 (*current-reversed-cold-toplevels* *nil-descriptor*)
3149 (*unbound-marker* (make-other-immediate-descriptor
3151 sb!vm:unbound-marker-widetag))
3152 *cold-assembler-fixups*
3153 *cold-assembler-routines*
3154 #!+(or x86 x86-64) *load-time-code-fixups*)
3156 ;; Prepare for cold load.
3157 (initialize-non-nil-symbols)
3158 (initialize-layouts)
3159 (initialize-static-fns)
3161 ;; Initialize the *COLD-SYMBOLS* system with the information
3162 ;; from package-data-list.lisp-expr and
3163 ;; common-lisp-exports.lisp-expr.
3165 ;; Why do things this way? Historically, the *COLD-SYMBOLS*
3166 ;; machinery was designed and implemented in CMU CL long before
3167 ;; I (WHN) ever heard of CMU CL. It dumped symbols and packages
3168 ;; iff they were used in the cold image. When I added the
3169 ;; package-data-list.lisp-expr mechanism, the idea was to
3170 ;; centralize all information about packages and exports. Thus,
3171 ;; it was the natural place for information even about packages
3172 ;; (such as SB!PCL and SB!WALKER) which aren't used much until
3173 ;; after cold load. This didn't quite match the CMU CL approach
3174 ;; of filling *COLD-SYMBOLS* with symbols which appear in the
3175 ;; cold image and then dumping only those symbols. By explicitly
3176 ;; putting all the symbols from package-data-list.lisp-expr and
3177 ;; from common-lisp-exports.lisp-expr into *COLD-SYMBOLS* here,
3178 ;; we feed our centralized symbol information into the old CMU
3179 ;; CL code without having to change the old CMU CL code too
3180 ;; much. (And the old CMU CL code is still useful for making
3181 ;; sure that the appropriate keywords and internal symbols end
3182 ;; up interned in the target Lisp, which is good, e.g. in order
3183 ;; to make &KEY arguments work right and in order to make
3184 ;; BACKTRACEs into target Lisp system code be legible.)
3185 (dolist (exported-name
3186 (sb-cold:read-from-file "common-lisp-exports.lisp-expr"))
3187 (cold-intern (intern exported-name *cl-package*)))
3188 (dolist (pd (sb-cold:read-from-file "package-data-list.lisp-expr"))
3189 (declare (type sb-cold:package-data pd))
3190 (let ((package (find-package (sb-cold:package-data-name pd))))
3191 (labels (;; Call FN on every node of the TREE.
3192 (mapc-on-tree (fn tree)
3193 (declare (type function fn))
3195 (cons (mapc-on-tree fn (car tree))
3196 (mapc-on-tree fn (cdr tree)))
3197 (t (funcall fn tree)
3199 ;; Make sure that information about the association
3200 ;; between PACKAGE and the symbol named NAME gets
3201 ;; recorded in the cold-intern system or (as a
3202 ;; convenience when dealing with the tree structure
3203 ;; allowed in the PACKAGE-DATA-EXPORTS slot) do
3204 ;; nothing if NAME is NIL.
3207 (cold-intern (intern name package) package))))
3208 (mapc-on-tree #'chill (sb-cold:package-data-export pd))
3209 (mapc #'chill (sb-cold:package-data-reexport pd))
3210 (dolist (sublist (sb-cold:package-data-import-from pd))
3211 (destructuring-bind (package-name &rest symbol-names) sublist
3212 (declare (ignore package-name))
3213 (mapc #'chill symbol-names))))))
3216 (dolist (file-name object-file-names)
3217 (write-line (namestring file-name))
3218 (cold-load file-name))
3220 ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
3221 (resolve-assembler-fixups)
3222 #!+(or x86 x86-64) (output-load-time-code-fixups)
3223 (foreign-symbols-to-core)
3225 (/show "back from FINISH-SYMBOLS")
3226 (finalize-load-time-value-noise)
3228 ;; Tell the target Lisp how much stuff we've allocated.
3229 (cold-set 'sb!vm:*read-only-space-free-pointer*
3230 (allocate-cold-descriptor *read-only*
3232 sb!vm:even-fixnum-lowtag))
3233 (cold-set 'sb!vm:*static-space-free-pointer*
3234 (allocate-cold-descriptor *static*
3236 sb!vm:even-fixnum-lowtag))
3237 (cold-set 'sb!vm:*initial-dynamic-space-free-pointer*
3238 (allocate-cold-descriptor *dynamic*
3240 sb!vm:even-fixnum-lowtag))
3241 (/show "done setting free pointers")
3243 ;; Write results to files.
3245 ;; FIXME: I dislike this approach of redefining
3246 ;; *STANDARD-OUTPUT* instead of putting the new stream in a
3247 ;; lexical variable, and it's annoying to have WRITE-MAP (to
3248 ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE
3249 ;; (to a stream explicitly passed as an argument).
3250 (macrolet ((out-to (name &body body)
3251 `(let ((fn (format nil "~A/~A.h" c-header-dir-name ,name)))
3252 (ensure-directories-exist fn)
3253 (with-open-file (*standard-output* fn
3254 :if-exists :supersede :direction :output)
3256 (let ((n (substitute #\_ #\- (string-upcase ,name))))
3259 "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"
3263 "#endif /* SBCL_GENESIS_~A */~%"
3264 (string-upcase ,name))))))
3266 (with-open-file (*standard-output* map-file-name
3268 :if-exists :supersede)
3270 (out-to "config" (write-config-h))
3271 (out-to "constants" (write-constants-h))
3272 (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
3275 (sb!vm:primitive-object-name obj))))))
3276 (dolist (obj structs)
3278 (string-downcase (string (sb!vm:primitive-object-name obj)))
3279 (write-primitive-object obj)))
3280 (out-to "primitive-objects"
3281 (dolist (obj structs)
3282 (format t "~&#include \"~A.h\"~%"
3284 (string (sb!vm:primitive-object-name obj)))))))
3285 (dolist (class '(hash-table layout))
3287 (string-downcase (string class))
3288 (write-structure-object
3289 (sb!kernel:layout-info (sb!kernel:find-layout class)))))
3290 (out-to "static-symbols" (write-static-symbols))
3292 (when core-file-name
3293 (write-initial-core-file core-file-name))))))