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 (char-code #\S) 24)
38 (ash (char-code #\B) 16)
39 (ash (char-code #\C) 8)
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)
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 (aver (= sb!vm:n-word-bits 32))
190 (aver (= sb!vm:n-byte-bits 8))
191 (logior ,@(ecase sb!c:*backend-byte-order*
192 (:little-endian ash-list-le)
193 (:big-endian ash-list-be))))
194 (defun (setf ,name) (new-value bigvec byte-index)
195 (aver (= sb!vm:n-word-bits 32))
196 (aver (= sb!vm:n-byte-bits 8))
197 (setf ,@(ecase sb!c:*backend-byte-order*
198 (:little-endian setf-list-le)
199 (:big-endian setf-list-be))))))))
204 ;;;; representation of spaces in the core
206 ;;; If there is more than one dynamic space in memory (i.e., if a
207 ;;; copying GC is in use), then only the active dynamic space gets
210 (defconstant dynamic-core-space-id 1)
213 (defconstant static-core-space-id 2)
216 (defconstant read-only-core-space-id 3)
218 (defconstant descriptor-low-bits 16
219 "the number of bits in the low half of the descriptor")
220 (defconstant target-space-alignment (ash 1 descriptor-low-bits)
221 "the alignment requirement for spaces in the target.
222 Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)")
224 ;;; a GENESIS-time representation of a memory space (e.g. read-only
225 ;;; space, dynamic space, or static space)
226 (defstruct (gspace (:constructor %make-gspace)
228 ;; name and identifier for this GSPACE
229 (name (missing-arg) :type symbol :read-only t)
230 (identifier (missing-arg) :type fixnum :read-only t)
231 ;; the word address where the data will be loaded
232 (word-address (missing-arg) :type unsigned-byte :read-only t)
233 ;; the data themselves. (Note that in CMU CL this was a pair of
234 ;; fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
235 ;; (And then in SBCL this was a VECTOR, but turned out to be
236 ;; unportable too, since ANSI doesn't think that arrays longer than
237 ;; 1024 (!) should needed by portable CL code...)
238 (bytes (make-bigvec) :read-only t)
239 ;; the index of the next unwritten word (i.e. chunk of
240 ;; SB!VM:N-WORD-BYTES bytes) in BYTES, or equivalently the number of
241 ;; words actually written in BYTES. In order to convert to an actual
242 ;; index into BYTES, thus must be multiplied by SB!VM:N-WORD-BYTES.
245 (defun gspace-byte-address (gspace)
246 (ash (gspace-word-address gspace) sb!vm:word-shift))
248 (def!method print-object ((gspace gspace) stream)
249 (print-unreadable-object (gspace stream :type t)
250 (format stream "~S" (gspace-name gspace))))
252 (defun make-gspace (name identifier byte-address)
253 (unless (zerop (rem byte-address target-space-alignment))
254 (error "The byte address #X~X is not aligned on a #X~X-byte boundary."
256 target-space-alignment))
257 (%make-gspace :name name
258 :identifier identifier
259 :word-address (ash byte-address (- sb!vm:word-shift))))
261 ;;;; representation of descriptors
263 (defstruct (descriptor
264 (:constructor make-descriptor
265 (high low &optional gspace word-offset))
267 ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
268 (gspace nil :type (or gspace null))
269 ;; the offset in words from the start of GSPACE, or NIL if not set yet
270 (word-offset nil :type (or (unsigned-byte #.sb!vm:n-word-bits) null))
271 ;; the high and low halves of the descriptor
273 ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL
274 ;; old-rt compiler, this split dates back from a very early version
275 ;; of genesis where 32-bit integers were represented as conses of
276 ;; two 16-bit integers. In any system with nice (UNSIGNED-BYTE 32)
277 ;; structure slots, like CMU CL >= 17 or any version of SBCL, there
278 ;; seems to be no reason to persist in this. -- WHN 19990917
281 (def!method print-object ((des descriptor) stream)
282 (let ((lowtag (descriptor-lowtag des)))
283 (print-unreadable-object (des stream :type t)
284 (cond ((or (= lowtag sb!vm:even-fixnum-lowtag)
285 (= lowtag sb!vm:odd-fixnum-lowtag))
286 (let ((unsigned (logior (ash (descriptor-high des)
287 (1+ (- descriptor-low-bits
288 sb!vm:n-lowtag-bits)))
289 (ash (descriptor-low des)
290 (- 1 sb!vm:n-lowtag-bits)))))
293 (if (> unsigned #x1FFFFFFF)
294 (- unsigned #x40000000)
296 ((or (= lowtag sb!vm:other-immediate-0-lowtag)
297 (= lowtag sb!vm:other-immediate-1-lowtag))
299 "for other immediate: #X~X, type #b~8,'0B"
300 (ash (descriptor-bits des) (- sb!vm:n-widetag-bits))
301 (logand (descriptor-low des) sb!vm:widetag-mask)))
304 "for pointer: #X~X, lowtag #b~3,'0B, ~A"
305 (logior (ash (descriptor-high des) descriptor-low-bits)
306 (logandc2 (descriptor-low des) sb!vm:lowtag-mask))
308 (let ((gspace (descriptor-gspace des)))
313 ;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The
314 ;;; free word index is boosted as necessary, and if additional memory
315 ;;; is needed, we grow the GSPACE. The descriptor returned is a
316 ;;; pointer of type LOWTAG.
317 (defun allocate-cold-descriptor (gspace length lowtag)
318 (let* ((bytes (round-up length (ash 1 sb!vm:n-lowtag-bits)))
319 (old-free-word-index (gspace-free-word-index gspace))
320 (new-free-word-index (+ old-free-word-index
321 (ash bytes (- sb!vm:word-shift)))))
322 ;; Grow GSPACE as necessary until it's big enough to handle
323 ;; NEW-FREE-WORD-INDEX.
325 ((>= (bvlength (gspace-bytes gspace))
326 (* new-free-word-index sb!vm:n-word-bytes)))
327 (expand-bigvec (gspace-bytes gspace)))
328 ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it.
329 (setf (gspace-free-word-index gspace) new-free-word-index)
330 (let ((ptr (+ (gspace-word-address gspace) old-free-word-index)))
331 (make-descriptor (ash ptr (- sb!vm:word-shift descriptor-low-bits))
332 (logior (ash (logand ptr
334 (- descriptor-low-bits
339 old-free-word-index))))
341 (defun descriptor-lowtag (des)
343 "the lowtag bits for DES"
344 (logand (descriptor-low des) sb!vm:lowtag-mask))
346 (defun descriptor-bits (des)
347 (logior (ash (descriptor-high des) descriptor-low-bits)
348 (descriptor-low des)))
350 (defun descriptor-fixnum (des)
351 (let ((bits (descriptor-bits des)))
352 (if (logbitp (1- sb!vm:n-word-bits) bits)
353 ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to
354 ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS),
355 ;; and although that doesn't make sense for me, or work for me,
356 ;; it's hard to see how it could have been wrong, since CMU CL
357 ;; genesis worked. It would be nice to understand how this came
358 ;; to be.. -- WHN 19990901
359 (logior (ash bits -2) (ash -1 (- sb!vm:n-word-bits 2)))
363 (defun descriptor-bytes (des)
364 (gspace-bytes (descriptor-intuit-gspace des)))
365 (defun descriptor-byte-offset (des)
366 (ash (descriptor-word-offset des) sb!vm:word-shift))
368 ;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise,
369 ;;; figure out a GSPACE which corresponds to DES, set it into
370 ;;; (DESCRIPTOR-GSPACE DES), set a consistent value into
371 ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
372 (declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace))
373 (defun descriptor-intuit-gspace (des)
374 (if (descriptor-gspace des)
375 (descriptor-gspace des)
376 ;; KLUDGE: It's not completely clear to me what's going on here;
377 ;; this is a literal translation from of some rather mysterious
378 ;; code from CMU CL's DESCRIPTOR-SAP function. Some explanation
379 ;; would be nice. -- WHN 19990817
380 (let ((lowtag (descriptor-lowtag des))
381 (high (descriptor-high des))
382 (low (descriptor-low des)))
383 (if (or (eql lowtag sb!vm:fun-pointer-lowtag)
384 (eql lowtag sb!vm:instance-pointer-lowtag)
385 (eql lowtag sb!vm:list-pointer-lowtag)
386 (eql lowtag sb!vm:other-pointer-lowtag))
387 (dolist (gspace (list *dynamic* *static* *read-only*)
388 (error "couldn't find a GSPACE for ~S" des))
389 ;; This code relies on the fact that GSPACEs are aligned
390 ;; such that the descriptor-low-bits low bits are zero.
391 (when (and (>= high (ash (gspace-word-address gspace)
392 (- sb!vm:word-shift descriptor-low-bits)))
393 (<= high (ash (+ (gspace-word-address gspace)
394 (gspace-free-word-index gspace))
395 (- sb!vm:word-shift descriptor-low-bits))))
396 (setf (descriptor-gspace des) gspace)
397 (setf (descriptor-word-offset des)
398 (+ (ash (- high (ash (gspace-word-address gspace)
400 descriptor-low-bits)))
401 (- descriptor-low-bits sb!vm:word-shift))
402 (ash (logandc2 low sb!vm:lowtag-mask)
403 (- sb!vm:word-shift))))
405 (error "don't even know how to look for a GSPACE for ~S" des)))))
407 (defun make-random-descriptor (value)
408 (make-descriptor (logand (ash value (- descriptor-low-bits))
411 descriptor-low-bits))))
412 (logand value (1- (ash 1 descriptor-low-bits)))))
414 (defun make-fixnum-descriptor (num)
415 (when (>= (integer-length num)
416 (1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits)))
417 (error "~W is too big for a fixnum." num))
418 (make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits))))
420 (defun make-other-immediate-descriptor (data type)
421 (make-descriptor (ash data (- sb!vm:n-widetag-bits descriptor-low-bits))
422 (logior (logand (ash data (- descriptor-low-bits
423 sb!vm:n-widetag-bits))
424 (1- (ash 1 descriptor-low-bits)))
427 (defun make-character-descriptor (data)
428 (make-other-immediate-descriptor data sb!vm:base-char-widetag))
430 (defun descriptor-beyond (des offset type)
431 (let* ((low (logior (+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask)
434 (high (+ (descriptor-high des)
435 (ash low (- descriptor-low-bits)))))
436 (make-descriptor high (logand low (1- (ash 1 descriptor-low-bits))))))
438 ;;;; miscellaneous variables and other noise
440 ;;; a numeric value to be returned for undefined foreign symbols, or NIL if
441 ;;; undefined foreign symbols are to be treated as an error.
442 ;;; (In the first pass of GENESIS, needed to create a header file before
443 ;;; the C runtime can be built, various foreign symbols will necessarily
444 ;;; be undefined, but we don't need actual values for them anyway, and
445 ;;; we can just use 0 or some other placeholder. In the second pass of
446 ;;; GENESIS, all foreign symbols should be defined, so any undefined
447 ;;; foreign symbol is a problem.)
449 ;;; KLUDGE: It would probably be cleaner to rewrite GENESIS so that it
450 ;;; never tries to look up foreign symbols in the first place unless
451 ;;; it's actually creating a core file (as in the second pass) instead
452 ;;; of using this hack to allow it to go through the motions without
453 ;;; causing an error. -- WHN 20000825
454 (defvar *foreign-symbol-placeholder-value*)
456 ;;; a handle on the trap object
457 (defvar *unbound-marker*)
458 ;; was: (make-other-immediate-descriptor 0 sb!vm:unbound-marker-widetag)
460 ;;; a handle on the NIL object
461 (defvar *nil-descriptor*)
463 ;;; the head of a list of TOPLEVEL-THINGs describing stuff to be done
464 ;;; when the target Lisp starts up
466 ;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or
467 ;;; loadtime value, represented by (CONS KEYWORD ..). The FILENAME
468 ;;; tells which fasl file each list element came from, for debugging
470 (defvar *current-reversed-cold-toplevels*)
472 ;;; the name of the object file currently being cold loaded (as a string, not a
473 ;;; pathname), or NIL if we're not currently cold loading any object file
474 (defvar *cold-load-filename* nil)
475 (declaim (type (or string null) *cold-load-filename*))
477 ;;;; miscellaneous stuff to read and write the core memory
479 ;;; FIXME: should be DEFINE-MODIFY-MACRO
480 (defmacro cold-push (thing list)
482 "Push THING onto the given cold-load LIST."
483 `(setq ,list (cold-cons ,thing ,list)))
485 (declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed))
486 (defun read-wordindexed (address index)
488 "Return the value which is displaced by INDEX words from ADDRESS."
489 (let* ((gspace (descriptor-intuit-gspace address))
490 (bytes (gspace-bytes gspace))
491 (byte-index (ash (+ index (descriptor-word-offset address))
493 (value (bvref-32 bytes byte-index)))
494 (make-random-descriptor value)))
496 (declaim (ftype (function (descriptor) descriptor) read-memory))
497 (defun read-memory (address)
499 "Return the value at ADDRESS."
500 (read-wordindexed address 0))
502 ;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS
503 ;;; value, instead of the SAP-INT we use here.)
504 (declaim (ftype (function (sb!vm:word descriptor) (values))
505 note-load-time-value-reference))
506 (defun note-load-time-value-reference (address marker)
507 (cold-push (cold-cons
508 (cold-intern :load-time-value-fixup)
509 (cold-cons (sap-int-to-core address)
511 (number-to-core (descriptor-word-offset marker))
513 *current-reversed-cold-toplevels*)
516 (declaim (ftype (function (descriptor sb!vm:word descriptor)) write-wordindexed))
517 (defun write-wordindexed (address index value)
519 "Write VALUE displaced INDEX words from ADDRESS."
520 ;; KLUDGE: There is an algorithm (used in DESCRIPTOR-INTUIT-GSPACE)
521 ;; for calculating the value of the GSPACE slot from scratch. It
522 ;; doesn't work for all values, only some of them, but mightn't it
523 ;; be reasonable to see whether it works on VALUE before we give up
524 ;; because (DESCRIPTOR-GSPACE VALUE) isn't set? (Or failing that,
525 ;; perhaps write a comment somewhere explaining why it's not a good
526 ;; idea?) -- WHN 19990817
527 (if (and (null (descriptor-gspace value))
528 (not (null (descriptor-word-offset value))))
529 (note-load-time-value-reference (+ (logandc2 (descriptor-bits address)
531 (ash index sb!vm:word-shift))
533 (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
534 (byte-index (ash (+ index (descriptor-word-offset address))
536 (setf (bvref-32 bytes byte-index)
537 (descriptor-bits value)))))
539 (declaim (ftype (function (descriptor descriptor)) write-memory))
540 (defun write-memory (address value)
542 "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
543 (write-wordindexed address 0 value))
545 ;;;; allocating images of primitive objects in the cold core
547 ;;; There are three kinds of blocks of memory in the type system:
548 ;;; * Boxed objects (cons cells, structures, etc): These objects have no
549 ;;; header as all slots are descriptors.
550 ;;; * Unboxed objects (bignums): There is a single header word that contains
552 ;;; * Vector objects: There is a header word with the type, then a word for
553 ;;; the length, then the data.
554 (defun allocate-boxed-object (gspace length lowtag)
556 "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
558 (allocate-cold-descriptor gspace (ash length sb!vm:word-shift) lowtag))
559 (defun allocate-unboxed-object (gspace element-bits length type)
561 "Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and
562 return an ``other-pointer'' descriptor to them. Initialize the header word
563 with the resultant length and TYPE."
564 (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits))
565 (des (allocate-cold-descriptor gspace
566 (+ bytes sb!vm:n-word-bytes)
567 sb!vm:other-pointer-lowtag)))
569 (make-other-immediate-descriptor (ash bytes
570 (- sb!vm:word-shift))
573 (defun allocate-vector-object (gspace element-bits length type)
575 "Allocate LENGTH units of ELEMENT-BITS size plus a header plus a length slot in
576 GSPACE and return an ``other-pointer'' descriptor to them. Initialize the
577 header word with TYPE and the length slot with LENGTH."
578 ;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using
579 ;; #'/ instead of #'CEILING, which seems wrong.
580 (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits))
581 (des (allocate-cold-descriptor gspace
582 (+ bytes (* 2 sb!vm:n-word-bytes))
583 sb!vm:other-pointer-lowtag)))
584 (write-memory des (make-other-immediate-descriptor 0 type))
585 (write-wordindexed des
586 sb!vm:vector-length-slot
587 (make-fixnum-descriptor length))
590 ;;;; copying simple objects into the cold core
592 (defun string-to-core (string &optional (gspace *dynamic*))
594 "Copy string into the cold core and return a descriptor to it."
595 ;; (Remember that the system convention for storage of strings leaves an
596 ;; extra null byte at the end to aid in call-out to C.)
597 (let* ((length (length string))
598 (des (allocate-vector-object gspace
601 sb!vm:simple-base-string-widetag))
602 (bytes (gspace-bytes gspace))
603 (offset (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
604 (descriptor-byte-offset des))))
605 (write-wordindexed des
606 sb!vm:vector-length-slot
607 (make-fixnum-descriptor length))
609 (setf (bvref bytes (+ offset i))
610 ;; KLUDGE: There's no guarantee that the character
611 ;; encoding here will be the same as the character
612 ;; encoding on the target machine, so using CHAR-CODE as
613 ;; we do, or a bitwise copy as CMU CL code did, is sleazy.
614 ;; (To make this more portable, perhaps we could use
615 ;; indices into the sequence which is used to test whether
616 ;; a character is a STANDARD-CHAR?) -- WHN 19990817
617 (char-code (aref string i))))
618 (setf (bvref bytes (+ offset length))
619 0) ; null string-termination character for C
622 (defun bignum-to-core (n)
624 "Copy a bignum to the cold core."
625 (let* ((words (ceiling (1+ (integer-length n)) sb!vm:n-word-bits))
626 (handle (allocate-unboxed-object *dynamic*
629 sb!vm:bignum-widetag)))
630 (declare (fixnum words))
631 (do ((index 1 (1+ index))
632 (remainder n (ash remainder (- sb!vm:n-word-bits))))
634 (unless (zerop (integer-length remainder))
635 ;; FIXME: Shouldn't this be a fatal error?
636 (warn "~W words of ~W were written, but ~W bits were left over."
638 (let ((word (ldb (byte sb!vm:n-word-bits 0) remainder)))
639 (write-wordindexed handle index
640 (make-descriptor (ash word (- descriptor-low-bits))
641 (ldb (byte descriptor-low-bits 0)
645 (defun number-pair-to-core (first second type)
647 "Makes a number pair of TYPE (ratio or complex) and fills it in."
648 (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits 2 type)))
649 (write-wordindexed des 1 first)
650 (write-wordindexed des 2 second)
653 (defun float-to-core (x)
656 (let ((des (allocate-unboxed-object *dynamic*
658 (1- sb!vm:single-float-size)
659 sb!vm:single-float-widetag)))
660 (write-wordindexed des
661 sb!vm:single-float-value-slot
662 (make-random-descriptor (single-float-bits x)))
665 (let ((des (allocate-unboxed-object *dynamic*
667 (1- sb!vm:double-float-size)
668 sb!vm:double-float-widetag))
669 (high-bits (make-random-descriptor (double-float-high-bits x)))
670 (low-bits (make-random-descriptor (double-float-low-bits x))))
671 (ecase sb!c:*backend-byte-order*
673 (write-wordindexed des sb!vm:double-float-value-slot low-bits)
674 (write-wordindexed des (1+ sb!vm:double-float-value-slot) high-bits))
676 (write-wordindexed des sb!vm:double-float-value-slot high-bits)
677 (write-wordindexed des (1+ sb!vm:double-float-value-slot) low-bits)))
679 #!+(and long-float x86)
681 (let ((des (allocate-unboxed-object *dynamic*
683 (1- sb!vm:long-float-size)
684 sb!vm:long-float-widetag))
685 (exp-bits (make-random-descriptor (long-float-exp-bits x)))
686 (high-bits (make-random-descriptor (long-float-high-bits x)))
687 (low-bits (make-random-descriptor (long-float-low-bits x))))
688 (ecase sb!c:*backend-byte-order*
690 (write-wordindexed des sb!vm:long-float-value-slot low-bits)
691 (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits)
692 (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits))
694 (error "LONG-FLOAT is not supported for big-endian byte order.")))
697 (defun complex-single-float-to-core (num)
698 (declare (type (complex single-float) num))
699 (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
700 (1- sb!vm:complex-single-float-size)
701 sb!vm:complex-single-float-widetag)))
702 (write-wordindexed des sb!vm:complex-single-float-real-slot
703 (make-random-descriptor (single-float-bits (realpart num))))
704 (write-wordindexed des sb!vm:complex-single-float-imag-slot
705 (make-random-descriptor (single-float-bits (imagpart num))))
708 (defun complex-double-float-to-core (num)
709 (declare (type (complex double-float) num))
710 (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
711 (1- sb!vm:complex-double-float-size)
712 sb!vm:complex-double-float-widetag)))
713 (let* ((real (realpart num))
714 (high-bits (make-random-descriptor (double-float-high-bits real)))
715 (low-bits (make-random-descriptor (double-float-low-bits real))))
716 (ecase sb!c:*backend-byte-order*
718 (write-wordindexed des sb!vm:complex-double-float-real-slot low-bits)
719 (write-wordindexed des
720 (1+ sb!vm:complex-double-float-real-slot)
723 (write-wordindexed des sb!vm:complex-double-float-real-slot high-bits)
724 (write-wordindexed des
725 (1+ sb!vm:complex-double-float-real-slot)
727 (let* ((imag (imagpart num))
728 (high-bits (make-random-descriptor (double-float-high-bits imag)))
729 (low-bits (make-random-descriptor (double-float-low-bits imag))))
730 (ecase sb!c:*backend-byte-order*
732 (write-wordindexed des
733 sb!vm:complex-double-float-imag-slot
735 (write-wordindexed des
736 (1+ sb!vm:complex-double-float-imag-slot)
739 (write-wordindexed des
740 sb!vm:complex-double-float-imag-slot
742 (write-wordindexed des
743 (1+ sb!vm:complex-double-float-imag-slot)
747 ;;; Copy the given number to the core.
748 (defun number-to-core (number)
750 (integer (if (< (integer-length number) 30)
751 (make-fixnum-descriptor number)
752 (bignum-to-core number)))
753 (ratio (number-pair-to-core (number-to-core (numerator number))
754 (number-to-core (denominator number))
755 sb!vm:ratio-widetag))
756 ((complex single-float) (complex-single-float-to-core number))
757 ((complex double-float) (complex-double-float-to-core number))
759 ((complex long-float)
760 (error "~S isn't a cold-loadable number at all!" number))
761 (complex (number-pair-to-core (number-to-core (realpart number))
762 (number-to-core (imagpart number))
763 sb!vm:complex-widetag))
764 (float (float-to-core number))
765 (t (error "~S isn't a cold-loadable number at all!" number))))
767 (declaim (ftype (function (sb!vm:word) descriptor) sap-int-to-core))
768 (defun sap-int-to-core (sap-int)
769 (let ((des (allocate-unboxed-object *dynamic*
773 (write-wordindexed des
774 sb!vm:sap-pointer-slot
775 (make-random-descriptor sap-int))
778 ;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
779 (defun cold-cons (car cdr &optional (gspace *dynamic*))
780 (let ((dest (allocate-boxed-object gspace 2 sb!vm:list-pointer-lowtag)))
781 (write-memory dest car)
782 (write-wordindexed dest 1 cdr)
785 ;;; Make a simple-vector on the target that holds the specified
786 ;;; OBJECTS, and return its descriptor.
787 (defun vector-in-core (&rest objects)
788 (let* ((size (length objects))
789 (result (allocate-vector-object *dynamic* sb!vm:n-word-bits size
790 sb!vm:simple-vector-widetag)))
791 (dotimes (index size)
792 (write-wordindexed result (+ index sb!vm:vector-data-offset)
798 ;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL.
799 (defvar *cold-symbol-allocation-gspace* nil)
801 ;;; Allocate (and initialize) a symbol.
802 (defun allocate-symbol (name)
803 (declare (simple-string name))
804 (let ((symbol (allocate-unboxed-object (or *cold-symbol-allocation-gspace*
807 (1- sb!vm:symbol-size)
808 sb!vm:symbol-header-widetag)))
809 (write-wordindexed symbol sb!vm:symbol-value-slot *unbound-marker*)
811 (write-wordindexed symbol
812 sb!vm:symbol-hash-slot
813 (make-fixnum-descriptor
814 (1+ (random sb!xc:most-positive-fixnum))))
815 (write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*)
816 (write-wordindexed symbol sb!vm:symbol-name-slot
817 (string-to-core name *dynamic*))
818 (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
821 ;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a
822 ;;; descriptor of a cold symbol or (in an abbreviation for the
823 ;;; most common usage pattern) an ordinary symbol, which will be
824 ;;; automatically cold-interned.
825 (declaim (ftype (function ((or descriptor symbol) descriptor)) cold-set))
826 (defun cold-set (symbol-or-symbol-des value)
827 (let ((symbol-des (etypecase symbol-or-symbol-des
828 (descriptor symbol-or-symbol-des)
829 (symbol (cold-intern symbol-or-symbol-des)))))
830 (write-wordindexed symbol-des sb!vm:symbol-value-slot value)))
832 ;;;; layouts and type system pre-initialization
834 ;;; Since we want to be able to dump structure constants and
835 ;;; predicates with reference layouts, we need to create layouts at
836 ;;; cold-load time. We use the name to intern layouts by, and dump a
837 ;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system
838 ;;; initialization can find them. The only thing that's tricky [sic --
839 ;;; WHN 19990816] is initializing layout's layout, which must point to
842 ;;; a map from class names to lists of
843 ;;; `(,descriptor ,name ,length ,inherits ,depth)
844 ;;; KLUDGE: It would be more understandable and maintainable to use
845 ;;; DEFSTRUCT (:TYPE LIST) here. -- WHN 19990823
846 (defvar *cold-layouts* (make-hash-table :test 'equal))
848 ;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting
850 (defvar *cold-layout-names* (make-hash-table :test 'eql))
852 ;;; FIXME: *COLD-LAYOUTS* and *COLD-LAYOUT-NAMES* should be
853 ;;; initialized by binding in GENESIS.
855 ;;; the descriptor for layout's layout (needed when making layouts)
856 (defvar *layout-layout*)
858 ;;; FIXME: This information should probably be pulled out of the
859 ;;; cross-compiler's tables at genesis time instead of inserted by
860 ;;; hand here as a bare numeric constant.
861 (defconstant target-layout-length 16)
863 ;;; Return a list of names created from the cold layout INHERITS data
865 (defun listify-cold-inherits (x)
866 (let ((len (descriptor-fixnum (read-wordindexed x
867 sb!vm:vector-length-slot))))
870 (let* ((des (read-wordindexed x (+ sb!vm:vector-data-offset index)))
871 (found (gethash (descriptor-bits des) *cold-layout-names*)))
874 (error "unknown descriptor at index ~S (bits = ~8,'0X)"
876 (descriptor-bits des)))))
879 (declaim (ftype (function (symbol descriptor descriptor descriptor) descriptor)
881 (defun make-cold-layout (name length inherits depthoid)
882 (let ((result (allocate-boxed-object *dynamic*
883 ;; KLUDGE: Why 1+? -- WHN 19990901
884 (1+ target-layout-length)
885 sb!vm:instance-pointer-lowtag)))
887 (make-other-immediate-descriptor
888 target-layout-length sb!vm:instance-header-widetag))
890 ;; KLUDGE: The offsets into LAYOUT below should probably be pulled out
891 ;; of the cross-compiler's tables at genesis time instead of inserted
892 ;; by hand as bare numeric constants. -- WHN ca. 19990901
894 ;; Set slot 0 = the layout of the layout.
895 (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*)
897 ;; Set the immediately following slots = CLOS hash values.
899 ;; Note: CMU CL didn't set these in genesis, but instead arranged
900 ;; for them to be set at cold init time. That resulted in slightly
901 ;; kludgy-looking code, but there were at least two things to be
903 ;; 1. It put the hash values under the control of the target Lisp's
904 ;; RANDOM function, so that CLOS behavior would be nearly
905 ;; deterministic (instead of depending on the implementation of
906 ;; RANDOM in the cross-compilation host, and the state of its
907 ;; RNG when genesis begins).
908 ;; 2. It automatically ensured that all hash values in the target Lisp
909 ;; were part of the same sequence, so that we didn't have to worry
910 ;; about the possibility of the first hash value set in genesis
911 ;; being precisely equal to the some hash value set in cold init time
912 ;; (because the target Lisp RNG has advanced to precisely the same
913 ;; state that the host Lisp RNG was in earlier).
914 ;; Point 1 should not be an issue in practice because of the way we do our
915 ;; build procedure in two steps, so that the SBCL that we end up with has
916 ;; been created by another SBCL (whose RNG is under our control).
917 ;; Point 2 is more of an issue. If ANSI had provided a way to feed
918 ;; entropy into an RNG, we would have no problem: we'd just feed
919 ;; some specialized genesis-time-only pattern into the RNG state
920 ;; before using it. However, they didn't, so we have a slight
921 ;; problem. We address it by generating the hash values using a
922 ;; different algorithm than we use in ordinary operation.
923 (dotimes (i sb!kernel:layout-clos-hash-length)
924 (let (;; The expression here is pretty arbitrary, we just want
925 ;; to make sure that it's not something which is (1)
926 ;; evenly distributed and (2) not foreordained to arise in
927 ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence
928 ;; and show up as the CLOS-HASH value of some other
931 ;; FIXME: This expression here can generate a zero value,
932 ;; and the CMU CL code goes out of its way to generate
933 ;; strictly positive values (even though the field is
934 ;; declared as an INDEX). Check that it's really OK to
935 ;; have zero values in the CLOS-HASH slots.
936 (hash-value (mod (logxor (logand (random-layout-clos-hash) 15253)
937 (logandc2 (random-layout-clos-hash) 15253)
939 ;; (The MOD here is defensive programming
940 ;; to make sure we never write an
941 ;; out-of-range value even if some joker
942 ;; sets LAYOUT-CLOS-HASH-MAX to other
943 ;; than 2^n-1 at some time in the
945 (1+ sb!kernel:layout-clos-hash-max))))
946 (write-wordindexed result
947 (+ i sb!vm:instance-slots-offset 1)
948 (make-fixnum-descriptor hash-value))))
950 ;; Set other slot values.
951 (let ((base (+ sb!vm:instance-slots-offset
952 sb!kernel:layout-clos-hash-length
954 ;; (Offset 0 is CLASS, "the class this is a layout for", which
955 ;; is uninitialized at this point.)
956 (write-wordindexed result (+ base 1) *nil-descriptor*) ; marked invalid
957 (write-wordindexed result (+ base 2) inherits)
958 (write-wordindexed result (+ base 3) depthoid)
959 (write-wordindexed result (+ base 4) length)
960 (write-wordindexed result (+ base 5) *nil-descriptor*) ; info
961 (write-wordindexed result (+ base 6) *nil-descriptor*)) ; pure
963 (setf (gethash name *cold-layouts*)
966 (descriptor-fixnum length)
967 (listify-cold-inherits inherits)
968 (descriptor-fixnum depthoid)))
969 (setf (gethash (descriptor-bits result) *cold-layout-names*) name)
973 (defun initialize-layouts ()
975 (clrhash *cold-layouts*)
977 ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and
979 (setq *layout-layout* *nil-descriptor*)
980 (setq *layout-layout*
981 (make-cold-layout 'layout
982 (number-to-core target-layout-length)
984 ;; FIXME: hard-coded LAYOUT-DEPTHOID of 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.
1001 (make-cold-layout 'instance
1003 (vector-in-core t-layout)
1004 (number-to-core 1)))
1006 (make-cold-layout 'structure-object
1008 (vector-in-core t-layout i-layout)
1009 (number-to-core 2)))
1011 (make-cold-layout 'structure!object
1013 (vector-in-core t-layout i-layout so-layout)
1014 (number-to-core 3)))
1015 (layout-inherits (vector-in-core t-layout
1020 ;; ..and return to backpatch the layout of LAYOUT.
1021 (setf (fourth (gethash 'layout *cold-layouts*))
1022 (listify-cold-inherits layout-inherits))
1023 (write-wordindexed *layout-layout*
1024 ;; FIXME: hardcoded offset into layout struct
1025 (+ sb!vm:instance-slots-offset
1026 layout-clos-hash-length
1031 ;;;; interning symbols in the cold image
1033 ;;; In order to avoid having to know about the package format, we
1034 ;;; build a data structure in *COLD-PACKAGE-SYMBOLS* that holds all
1035 ;;; interned symbols along with info about their packages. The data
1036 ;;; structure is a list of sublists, where the sublists have the
1037 ;;; following format:
1038 ;;; (<make-package-arglist>
1039 ;;; <internal-symbols>
1040 ;;; <external-symbols>
1041 ;;; <imported-internal-symbols>
1042 ;;; <imported-external-symbols>
1043 ;;; <shadowing-symbols>
1044 ;;; <package-documentation>)
1046 ;;; KLUDGE: It would be nice to implement the sublists as instances of
1047 ;;; a DEFSTRUCT (:TYPE LIST). (They'd still be lists, but at least we'd be
1048 ;;; using mnemonically-named operators to access them, instead of trying
1049 ;;; to remember what THIRD and FIFTH mean, and hoping that we never
1050 ;;; need to change the list layout..) -- WHN 19990825
1052 ;;; an alist from packages to lists of that package's symbols to be dumped
1053 (defvar *cold-package-symbols*)
1054 (declaim (type list *cold-package-symbols*))
1056 ;;; a map from descriptors to symbols, so that we can back up. The key
1057 ;;; is the address in the target core.
1058 (defvar *cold-symbols*)
1059 (declaim (type hash-table *cold-symbols*))
1061 ;;; sanity check for a symbol we're about to create on the target
1063 ;;; Make sure that the symbol has an appropriate package. In
1064 ;;; particular, catch the so-easy-to-make error of typing something
1065 ;;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really
1066 ;;; need is SB!KERNEL:%BYTE-BLT.
1067 (defun package-ok-for-target-symbol-p (package)
1068 (let ((package-name (package-name package)))
1070 ;; Cold interning things in these standard packages is OK. (Cold
1071 ;; interning things in the other standard package, CL-USER, isn't
1072 ;; OK. We just use CL-USER to expose symbols whose homes are in
1073 ;; other packages. Thus, trying to cold intern a symbol whose
1074 ;; home package is CL-USER probably means that a coding error has
1075 ;; been made somewhere.)
1076 (find package-name '("COMMON-LISP" "KEYWORD") :test #'string=)
1077 ;; Cold interning something in one of our target-code packages,
1078 ;; which are ever-so-rigorously-and-elegantly distinguished by
1079 ;; this prefix on their names, is OK too.
1080 (string= package-name "SB!" :end1 3 :end2 3)
1081 ;; This one is OK too, since it ends up being COMMON-LISP on the
1083 (string= package-name "SB-XC")
1084 ;; Anything else looks bad. (maybe COMMON-LISP-USER? maybe an extension
1085 ;; package in the xc host? something we can't think of
1086 ;; a valid reason to cold intern, anyway...)
1089 ;;; like SYMBOL-PACKAGE, but safe for symbols which end up on the target
1091 ;;; Most host symbols we dump onto the target are created by SBCL
1092 ;;; itself, so that as long as we avoid gratuitously
1093 ;;; cross-compilation-unfriendly hacks, it just happens that their
1094 ;;; SYMBOL-PACKAGE in the host system corresponds to their
1095 ;;; SYMBOL-PACKAGE in the target system. However, that's not the case
1096 ;;; in the COMMON-LISP package, where we don't get to create the
1097 ;;; symbols but instead have to use the ones that the xc host created.
1098 ;;; In particular, while ANSI specifies which symbols are exported
1099 ;;; from COMMON-LISP, it doesn't specify that their home packages are
1100 ;;; COMMON-LISP, so the xc host can keep them in random packages which
1101 ;;; don't exist on the target (e.g. CLISP keeping some CL-exported
1102 ;;; symbols in the CLOS package).
1103 (defun symbol-package-for-target-symbol (symbol)
1104 ;; We want to catch weird symbols like CLISP's
1105 ;; CL:FIND-METHOD=CLOS::FIND-METHOD, but we don't want to get
1106 ;; sidetracked by ordinary symbols like :CHARACTER which happen to
1107 ;; have the same SYMBOL-NAME as exports from COMMON-LISP.
1108 (multiple-value-bind (cl-symbol cl-status)
1109 (find-symbol (symbol-name symbol) *cl-package*)
1110 (if (and (eq symbol cl-symbol)
1111 (eq cl-status :external))
1112 ;; special case, to work around possible xc host weirdness
1113 ;; in COMMON-LISP package
1116 (let ((result (symbol-package symbol)))
1117 (aver (package-ok-for-target-symbol-p result))
1120 ;;; Return a handle on an interned symbol. If necessary allocate the
1121 ;;; symbol and record which package the symbol was referenced in. When
1122 ;;; we allocate the symbol, make sure we record a reference to the
1123 ;;; symbol in the home package so that the package gets set.
1124 (defun cold-intern (symbol
1126 (package (symbol-package-for-target-symbol symbol)))
1128 (aver (package-ok-for-target-symbol-p package))
1130 ;; Anything on the cross-compilation host which refers to the target
1131 ;; machinery through the host SB-XC package should be translated to
1132 ;; something on the target which refers to the same machinery
1133 ;; through the target COMMON-LISP package.
1134 (let ((p (find-package "SB-XC")))
1135 (when (eq package p)
1136 (setf package *cl-package*))
1137 (when (eq (symbol-package symbol) p)
1138 (setf symbol (intern (symbol-name symbol) *cl-package*))))
1140 (let (;; Information about each cold-interned symbol is stored
1141 ;; in COLD-INTERN-INFO.
1142 ;; (CAR COLD-INTERN-INFO) = descriptor of symbol
1143 ;; (CDR COLD-INTERN-INFO) = list of packages, other than symbol's
1144 ;; own package, referring to symbol
1145 ;; (*COLD-PACKAGE-SYMBOLS* and *COLD-SYMBOLS* store basically the
1146 ;; same information, but with the mapping running the opposite way.)
1147 (cold-intern-info (get symbol 'cold-intern-info)))
1148 (unless cold-intern-info
1149 (cond ((eq (symbol-package-for-target-symbol symbol) package)
1150 (let ((handle (allocate-symbol (symbol-name symbol))))
1151 (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
1152 (when (eq package *keyword-package*)
1153 (cold-set handle handle))
1154 (setq cold-intern-info
1155 (setf (get symbol 'cold-intern-info) (cons handle nil)))))
1157 (cold-intern symbol)
1158 (setq cold-intern-info (get symbol 'cold-intern-info)))))
1159 (unless (or (null package)
1160 (member package (cdr cold-intern-info)))
1161 (push package (cdr cold-intern-info))
1162 (let* ((old-cps-entry (assoc package *cold-package-symbols*))
1163 (cps-entry (or old-cps-entry
1164 (car (push (list package)
1165 *cold-package-symbols*)))))
1166 (unless old-cps-entry
1167 (/show "created *COLD-PACKAGE-SYMBOLS* entry for" package symbol))
1168 (push symbol (rest cps-entry))))
1169 (car cold-intern-info)))
1171 ;;; Construct and return a value for use as *NIL-DESCRIPTOR*.
1172 (defun make-nil-descriptor ()
1173 (let* ((des (allocate-unboxed-object
1178 (result (make-descriptor (descriptor-high des)
1179 (+ (descriptor-low des)
1180 (* 2 sb!vm:n-word-bytes)
1181 (- sb!vm:list-pointer-lowtag
1182 sb!vm:other-pointer-lowtag)))))
1183 (write-wordindexed des
1185 (make-other-immediate-descriptor
1187 sb!vm:symbol-header-widetag))
1188 (write-wordindexed des
1189 (+ 1 sb!vm:symbol-value-slot)
1191 (write-wordindexed des
1192 (+ 2 sb!vm:symbol-value-slot)
1194 (write-wordindexed des
1195 (+ 1 sb!vm:symbol-plist-slot)
1197 (write-wordindexed des
1198 (+ 1 sb!vm:symbol-name-slot)
1199 ;; This is *DYNAMIC*, and DES is *STATIC*,
1200 ;; because that's the way CMU CL did it; I'm
1201 ;; not sure whether there's an underlying
1202 ;; reason. -- WHN 1990826
1203 (string-to-core "NIL" *dynamic*))
1204 (write-wordindexed des
1205 (+ 1 sb!vm:symbol-package-slot)
1207 (setf (get nil 'cold-intern-info)
1212 ;;; Since the initial symbols must be allocated before we can intern
1213 ;;; anything else, we intern those here. We also set the value of T.
1214 (defun initialize-non-nil-symbols ()
1216 "Initialize the cold load symbol-hacking data structures."
1217 (let ((*cold-symbol-allocation-gspace* *static*))
1218 ;; Intern the others.
1219 (dolist (symbol sb!vm:*static-symbols*)
1220 (let* ((des (cold-intern symbol))
1221 (offset-wanted (sb!vm:static-symbol-offset symbol))
1222 (offset-found (- (descriptor-low des)
1223 (descriptor-low *nil-descriptor*))))
1224 (unless (= offset-wanted offset-found)
1225 ;; FIXME: should be fatal
1226 (warn "Offset from ~S to ~S is ~W, not ~W"
1231 ;; Establish the value of T.
1232 (let ((t-symbol (cold-intern t)))
1233 (cold-set t-symbol t-symbol))))
1235 ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
1236 ;;; to be stored in *!INITIAL-LAYOUTS*.
1237 (defun cold-list-all-layouts ()
1238 (let ((result *nil-descriptor*))
1239 (maphash (lambda (key stuff)
1240 (cold-push (cold-cons (cold-intern key)
1246 ;;; Establish initial values for magic symbols.
1248 ;;; Scan over all the symbols referenced in each package in
1249 ;;; *COLD-PACKAGE-SYMBOLS* making that for each one there's an
1250 ;;; appropriate entry in the *!INITIAL-SYMBOLS* data structure to
1252 (defun finish-symbols ()
1254 ;; I think the point of setting these functions into SYMBOL-VALUEs
1255 ;; here, instead of using SYMBOL-FUNCTION, is that in CMU CL
1256 ;; SYMBOL-FUNCTION reduces to FDEFINITION, which is a pretty
1257 ;; hairy operation (involving globaldb.lisp etc.) which we don't
1258 ;; want to invoke early in cold init. -- WHN 2001-12-05
1260 ;; FIXME: So OK, that's a reasonable reason to do something weird like
1261 ;; this, but this is still a weird thing to do, and we should change
1262 ;; the names to highlight that something weird is going on. Perhaps
1263 ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
1264 ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...
1265 (macrolet ((frob (symbol)
1267 (cold-fdefinition-object (cold-intern ',symbol)))))
1269 (frob internal-error)
1270 (frob sb!kernel::control-stack-exhausted-error)
1271 (frob sb!di::handle-breakpoint)
1272 (frob sb!di::handle-fun-end-breakpoint)
1273 (frob sb!thread::handle-thread-exit))
1275 (cold-set '*current-catch-block* (make-fixnum-descriptor 0))
1276 (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0))
1278 (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0))
1280 (cold-set '*!initial-layouts* (cold-list-all-layouts))
1282 (/show "dumping packages" (mapcar #'car *cold-package-symbols*))
1283 (let ((initial-symbols *nil-descriptor*))
1284 (dolist (cold-package-symbols-entry *cold-package-symbols*)
1285 (let* ((cold-package (car cold-package-symbols-entry))
1286 (symbols (cdr cold-package-symbols-entry))
1287 (shadows (package-shadowing-symbols cold-package))
1288 (documentation (string-to-core (documentation cold-package t)))
1289 (internal *nil-descriptor*)
1290 (external *nil-descriptor*)
1291 (imported-internal *nil-descriptor*)
1292 (imported-external *nil-descriptor*)
1293 (shadowing *nil-descriptor*))
1294 (declare (type package cold-package)) ; i.e. not a target descriptor
1295 (/show "dumping" cold-package symbols)
1297 ;; FIXME: Add assertions here to make sure that inappropriate stuff
1298 ;; isn't being dumped:
1299 ;; * the CL-USER package
1300 ;; * the SB-COLD package
1301 ;; * any internal symbols in the CL package
1302 ;; * basically any package other than CL, KEYWORD, or the packages
1303 ;; in package-data-list.lisp-expr
1304 ;; and that the structure of the KEYWORD package (e.g. whether
1305 ;; any symbols are internal to it) matches what we want in the
1308 ;; FIXME: It seems possible that by looking at the contents of
1309 ;; packages in the target SBCL we could find which symbols in
1310 ;; package-data-lisp.lisp-expr are now obsolete. (If I
1311 ;; understand correctly, only symbols which actually have
1312 ;; definitions or which are otherwise referred to actually end
1313 ;; up in the target packages.)
1315 (dolist (symbol symbols)
1316 (let ((handle (car (get symbol 'cold-intern-info)))
1317 (imported-p (not (eq (symbol-package-for-target-symbol symbol)
1319 (multiple-value-bind (found where)
1320 (find-symbol (symbol-name symbol) cold-package)
1321 (unless (and where (eq found symbol))
1322 (error "The symbol ~S is not available in ~S."
1325 (when (memq symbol shadows)
1326 (cold-push handle shadowing))
1328 (:internal (if imported-p
1329 (cold-push handle imported-internal)
1330 (cold-push handle internal)))
1331 (:external (if imported-p
1332 (cold-push handle imported-external)
1333 (cold-push handle external)))))))
1334 (let ((r *nil-descriptor*))
1335 (cold-push documentation r)
1336 (cold-push shadowing r)
1337 (cold-push imported-external r)
1338 (cold-push imported-internal r)
1339 (cold-push external r)
1340 (cold-push internal r)
1341 (cold-push (make-make-package-args cold-package) r)
1342 ;; FIXME: It would be more space-efficient to use vectors
1343 ;; instead of lists here, and space-efficiency here would be
1344 ;; nice, since it would reduce the peak memory usage in
1345 ;; genesis and cold init.
1346 (cold-push r initial-symbols))))
1347 (cold-set '*!initial-symbols* initial-symbols))
1349 (cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
1351 (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
1355 (cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0))
1356 (cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0))
1357 (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0))
1358 (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0))
1361 (cold-set 'sb!vm::*fp-constant-0l0* (number-to-core 0L0))
1362 (cold-set 'sb!vm::*fp-constant-1l0* (number-to-core 1L0))
1363 ;; FIXME: Why is initialization of PI conditional on LONG-FLOAT?
1364 ;; (ditto LG2, LN2, L2E, etc.)
1365 (cold-set 'sb!vm::*fp-constant-pi* (number-to-core pi))
1366 (cold-set 'sb!vm::*fp-constant-l2t* (number-to-core (log 10L0 2L0)))
1367 (cold-set 'sb!vm::*fp-constant-l2e*
1368 (number-to-core (log 2.718281828459045235360287471352662L0 2L0)))
1369 (cold-set 'sb!vm::*fp-constant-lg2* (number-to-core (log 2L0 10L0)))
1370 (cold-set 'sb!vm::*fp-constant-ln2*
1372 (log 2L0 2.718281828459045235360287471352662L0))))))
1374 ;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order
1375 ;;; to make a package that is similar to PKG.
1376 (defun make-make-package-args (pkg)
1377 (let* ((use *nil-descriptor*)
1378 (cold-nicknames *nil-descriptor*)
1379 (res *nil-descriptor*))
1380 (dolist (u (package-use-list pkg))
1381 (when (assoc u *cold-package-symbols*)
1382 (cold-push (string-to-core (package-name u)) use)))
1383 (let* ((pkg-name (package-name pkg))
1384 ;; Make the package nickname lists for the standard packages
1385 ;; be the minimum specified by ANSI, regardless of what value
1386 ;; the cross-compilation host happens to use.
1387 (warm-nicknames (cond ((string= pkg-name "COMMON-LISP")
1389 ((string= pkg-name "COMMON-LISP-USER")
1391 ((string= pkg-name "KEYWORD")
1393 ;; For packages other than the
1394 ;; standard packages, the nickname
1395 ;; list was specified by our package
1396 ;; setup code, not by properties of
1397 ;; what cross-compilation host we
1398 ;; happened to use, and we can just
1399 ;; propagate it into the target.
1401 (package-nicknames pkg)))))
1402 (dolist (warm-nickname warm-nicknames)
1403 (cold-push (string-to-core warm-nickname) cold-nicknames)))
1405 (cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
1408 (cold-push (cold-intern :internal-symbols) res)
1409 (cold-push (number-to-core (truncate (package-external-symbol-count pkg)
1412 (cold-push (cold-intern :external-symbols) res)
1414 (cold-push cold-nicknames res)
1415 (cold-push (cold-intern :nicknames) res)
1418 (cold-push (cold-intern :use) res)
1420 (cold-push (string-to-core (package-name pkg)) res)
1423 ;;;; functions and fdefinition objects
1425 ;;; a hash table mapping from fdefinition names to descriptors of cold
1428 ;;; Note: Since fdefinition names can be lists like '(SETF FOO), and
1429 ;;; we want to have only one entry per name, this must be an 'EQUAL
1430 ;;; hash table, not the default 'EQL.
1431 (defvar *cold-fdefn-objects*)
1433 (defvar *cold-fdefn-gspace* nil)
1435 ;;; Given a cold representation of a symbol, return a warm
1437 (defun warm-symbol (des)
1438 ;; Note that COLD-INTERN is responsible for keeping the
1439 ;; *COLD-SYMBOLS* table up to date, so if DES happens to refer to an
1440 ;; uninterned symbol, the code below will fail. But as long as we
1441 ;; don't need to look up uninterned symbols during bootstrapping,
1443 (multiple-value-bind (symbol found-p)
1444 (gethash (descriptor-bits des) *cold-symbols*)
1445 (declare (type symbol symbol))
1447 (error "no warm symbol"))
1450 ;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values
1451 (defun cold-car (des)
1452 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
1453 (read-wordindexed des sb!vm:cons-car-slot))
1454 (defun cold-cdr (des)
1455 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
1456 (read-wordindexed des sb!vm:cons-cdr-slot))
1457 (defun cold-null (des)
1458 (= (descriptor-bits des)
1459 (descriptor-bits *nil-descriptor*)))
1461 ;;; Given a cold representation of a function name, return a warm
1463 (declaim (ftype (function (descriptor) (or symbol list)) warm-fun-name))
1464 (defun warm-fun-name (des)
1466 (ecase (descriptor-lowtag des)
1467 (#.sb!vm:list-pointer-lowtag
1468 (aver (not (cold-null des))) ; function named NIL? please no..
1469 ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..).
1470 (let* ((car-des (cold-car des))
1471 (cdr-des (cold-cdr des))
1472 (cadr-des (cold-car cdr-des))
1473 (cddr-des (cold-cdr cdr-des)))
1474 (aver (cold-null cddr-des))
1475 (list (warm-symbol car-des)
1476 (warm-symbol cadr-des))))
1477 (#.sb!vm:other-pointer-lowtag
1478 (warm-symbol des)))))
1479 (legal-fun-name-or-type-error result)
1482 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
1483 (declare (type descriptor cold-name))
1484 (let ((warm-name (warm-fun-name cold-name)))
1485 (or (gethash warm-name *cold-fdefn-objects*)
1486 (let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace* *dynamic*)
1487 (1- sb!vm:fdefn-size)
1488 sb!vm:other-pointer-lowtag)))
1490 (setf (gethash warm-name *cold-fdefn-objects*) fdefn)
1491 (write-memory fdefn (make-other-immediate-descriptor
1492 (1- sb!vm:fdefn-size) sb!vm:fdefn-widetag))
1493 (write-wordindexed fdefn sb!vm:fdefn-name-slot cold-name)
1494 (unless leave-fn-raw
1495 (write-wordindexed fdefn sb!vm:fdefn-fun-slot
1497 (write-wordindexed fdefn
1498 sb!vm:fdefn-raw-addr-slot
1499 (make-random-descriptor
1500 (cold-foreign-symbol-address-as-integer
1501 (sb!vm:extern-alien-name "undefined_tramp")))))
1504 ;;; Handle the at-cold-init-time, fset-for-static-linkage operation
1505 ;;; requested by FOP-FSET.
1506 (defun static-fset (cold-name defn)
1507 (declare (type descriptor cold-name))
1508 (let ((fdefn (cold-fdefinition-object cold-name t))
1509 (type (logand (descriptor-low (read-memory defn)) sb!vm:widetag-mask)))
1510 (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn)
1511 (write-wordindexed fdefn
1512 sb!vm:fdefn-raw-addr-slot
1514 (#.sb!vm:simple-fun-header-widetag
1518 (make-random-descriptor
1519 (+ (logandc2 (descriptor-bits defn)
1521 (ash sb!vm:simple-fun-code-offset
1522 sb!vm:word-shift))))
1523 (#.sb!vm:closure-header-widetag
1524 (make-random-descriptor
1525 (cold-foreign-symbol-address-as-integer
1526 (sb!vm:extern-alien-name "closure_tramp"))))))
1529 (defun initialize-static-fns ()
1530 (let ((*cold-fdefn-gspace* *static*))
1531 (dolist (sym sb!vm:*static-funs*)
1532 (let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
1533 (offset (- (+ (- (descriptor-low fdefn)
1534 sb!vm:other-pointer-lowtag)
1535 (* sb!vm:fdefn-raw-addr-slot sb!vm:n-word-bytes))
1536 (descriptor-low *nil-descriptor*)))
1537 (desired (sb!vm:static-fun-offset sym)))
1538 (unless (= offset desired)
1539 ;; FIXME: should be fatal
1540 (warn "Offset from FDEFN ~S to ~S is ~W, not ~W."
1541 sym nil offset desired))))))
1543 (defun list-all-fdefn-objects ()
1544 (let ((result *nil-descriptor*))
1545 (maphash (lambda (key value)
1546 (declare (ignore key))
1547 (cold-push value result))
1548 *cold-fdefn-objects*)
1551 ;;;; fixups and related stuff
1553 ;;; an EQUAL hash table
1554 (defvar *cold-foreign-symbol-table*)
1555 (declaim (type hash-table *cold-foreign-symbol-table*))
1557 ;;; Read the sbcl.nm file to find the addresses for foreign-symbols in
1559 (defun load-cold-foreign-symbol-table (filename)
1560 (with-open-file (file filename)
1562 (let ((line (read-line file nil nil)))
1565 ;; UNIX symbol tables might have tabs in them, and tabs are
1566 ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
1567 ;; nice portable way to deal with them within Lisp, alas.
1568 ;; Fortunately, it's easy to use UNIX command line tools like
1569 ;; sed to remove the problem, so it's not too painful for us
1570 ;; to push responsibility for converting tabs to spaces out to
1573 ;; Other non-STANDARD-CHARs are problematic for the same reason.
1574 ;; Make sure that there aren't any..
1575 (let ((ch (find-if (lambda (char)
1576 (not (typep char 'standard-char)))
1579 (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
1582 (setf line (string-trim '(#\space) line))
1583 (let ((p1 (position #\space line :from-end nil))
1584 (p2 (position #\space line :from-end t)))
1585 (if (not (and p1 p2 (< p1 p2)))
1586 ;; KLUDGE: It's too messy to try to understand all
1587 ;; possible output from nm, so we just punt the lines we
1588 ;; don't recognize. We realize that there's some chance
1589 ;; that might get us in trouble someday, so we warn
1591 (warn "ignoring unrecognized line ~S in ~A" line filename)
1592 (multiple-value-bind (value name)
1593 (if (string= "0x" line :end2 2)
1594 (values (parse-integer line :start 2 :end p1 :radix 16)
1595 (subseq line (1+ p2)))
1596 (values (parse-integer line :end p1 :radix 16)
1597 (subseq line (1+ p2))))
1598 (multiple-value-bind (old-value found)
1599 (gethash name *cold-foreign-symbol-table*)
1601 (not (= old-value value)))
1602 (warn "redefining ~S from #X~X to #X~X"
1603 name old-value value)))
1604 (setf (gethash name *cold-foreign-symbol-table*) value))))))
1607 (defun cold-foreign-symbol-address-as-integer (name)
1608 (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*)
1609 *foreign-symbol-placeholder-value*
1611 (format *error-output* "~&The foreign symbol table is:~%")
1612 (maphash (lambda (k v)
1613 (format *error-output* "~&~S = #X~8X~%" k v))
1614 *cold-foreign-symbol-table*)
1615 (error "The foreign symbol ~S is undefined." name))))
1617 (defvar *cold-assembler-routines*)
1619 (defvar *cold-assembler-fixups*)
1621 (defun record-cold-assembler-routine (name address)
1622 (/xhow "in RECORD-COLD-ASSEMBLER-ROUTINE" name address)
1623 (push (cons name address)
1624 *cold-assembler-routines*))
1626 (defun record-cold-assembler-fixup (routine
1631 (push (list routine code-object offset kind)
1632 *cold-assembler-fixups*))
1634 (defun lookup-assembler-reference (symbol)
1635 (let ((value (cdr (assoc symbol *cold-assembler-routines*))))
1636 ;; FIXME: Should this be ERROR instead of WARN?
1638 (warn "Assembler routine ~S not defined." symbol))
1641 ;;; The x86 port needs to store code fixups along with code objects if
1642 ;;; they are to be moved, so fixups for code objects in the dynamic
1643 ;;; heap need to be noted.
1645 (defvar *load-time-code-fixups*)
1648 (defun note-load-time-code-fixup (code-object offset value kind)
1649 ;; If CODE-OBJECT might be moved
1650 (when (= (gspace-identifier (descriptor-intuit-gspace code-object))
1651 dynamic-core-space-id)
1652 ;; FIXME: pushed thing should be a structure, not just a list
1653 (push (list code-object offset value kind) *load-time-code-fixups*))
1657 (defun output-load-time-code-fixups ()
1658 (dolist (fixups *load-time-code-fixups*)
1659 (let ((code-object (first fixups))
1660 (offset (second fixups))
1661 (value (third fixups))
1662 (kind (fourth fixups)))
1663 (cold-push (cold-cons
1664 (cold-intern :load-time-code-fixup)
1668 (number-to-core offset)
1670 (number-to-core value)
1673 *nil-descriptor*)))))
1674 *current-reversed-cold-toplevels*))))
1676 ;;; Given a pointer to a code object and an offset relative to the
1677 ;;; tail of the code object's header, return an offset relative to the
1678 ;;; (beginning of the) code object.
1680 ;;; FIXME: It might be clearer to reexpress
1681 ;;; (LET ((X (CALC-OFFSET CODE-OBJECT OFFSET0))) ..)
1683 ;;; (LET ((X (+ OFFSET0 (CODE-OBJECT-HEADER-N-BYTES CODE-OBJECT)))) ..).
1684 (declaim (ftype (function (descriptor sb!vm:word)) calc-offset))
1685 (defun calc-offset (code-object offset-from-tail-of-header)
1686 (let* ((header (read-memory code-object))
1687 (header-n-words (ash (descriptor-bits header)
1688 (- sb!vm:n-widetag-bits)))
1689 (header-n-bytes (ash header-n-words sb!vm:word-shift))
1690 (result (+ offset-from-tail-of-header header-n-bytes)))
1693 (declaim (ftype (function (descriptor sb!vm:word sb!vm:word keyword))
1695 (defun do-cold-fixup (code-object after-header value kind)
1696 (let* ((offset-within-code-object (calc-offset code-object after-header))
1697 (gspace-bytes (descriptor-bytes code-object))
1698 (gspace-byte-offset (+ (descriptor-byte-offset code-object)
1699 offset-within-code-object))
1700 (gspace-byte-address (gspace-byte-address
1701 (descriptor-gspace code-object))))
1702 (ecase +backend-fasl-file-implementation+
1703 ;; See CMU CL source for other formerly-supported architectures
1704 ;; (and note that you have to rewrite them to use BVREF-X
1705 ;; instead of SAP-REF).
1709 (assert (zerop (ldb (byte 2 0) value))))
1711 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
1712 (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
1713 (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
1714 (setf (bvref-8 gspace-bytes gspace-byte-offset)
1715 (ldb (byte 8 48) value)
1716 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
1717 (ldb (byte 8 56) value))))
1719 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
1720 (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
1721 (setf (bvref-8 gspace-bytes gspace-byte-offset)
1722 (ldb (byte 8 32) value)
1723 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
1724 (ldb (byte 8 40) value))))
1726 (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
1727 (setf (bvref-8 gspace-bytes gspace-byte-offset)
1728 (ldb (byte 8 16) value)
1729 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
1730 (ldb (byte 8 24) value))))
1732 (setf (bvref-8 gspace-bytes gspace-byte-offset)
1733 (ldb (byte 8 0) value)
1734 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
1735 (ldb (byte 8 8) value)))))
1739 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1740 (logior (ash (ldb (byte 11 0) value) 1)
1741 (logand (bvref-32 gspace-bytes gspace-byte-offset)
1744 (let ((low-bits (ldb (byte 11 0) value)))
1745 (assert (<= 0 low-bits (1- (ash 1 4))))
1746 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1747 (logior (ash low-bits 17)
1748 (logand (bvref-32 gspace-bytes gspace-byte-offset)
1751 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1752 (logior (ash (ldb (byte 5 13) value) 16)
1753 (ash (ldb (byte 2 18) value) 14)
1754 (ash (ldb (byte 2 11) value) 12)
1755 (ash (ldb (byte 11 20) value) 1)
1756 (ldb (byte 1 31) value)
1757 (logand (bvref-32 gspace-bytes gspace-byte-offset)
1760 (let ((bits (ldb (byte 9 2) value)))
1761 (assert (zerop (ldb (byte 2 0) value)))
1762 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1763 (logior (ash bits 3)
1764 (logand (bvref-32 gspace-bytes gspace-byte-offset)
1769 (assert (zerop (ash value -28)))
1770 (setf (ldb (byte 26 0)
1771 (bvref-32 gspace-bytes gspace-byte-offset))
1774 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1775 (logior (mask-field (byte 16 16)
1776 (bvref-32 gspace-bytes gspace-byte-offset))
1778 (if (logbitp 15 value) 1 0)))))
1780 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1781 (logior (mask-field (byte 16 16)
1782 (bvref-32 gspace-bytes gspace-byte-offset))
1783 (ldb (byte 16 0) value))))))
1787 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1788 (dpb (ash value -2) (byte 24 2)
1789 (bvref-32 gspace-bytes gspace-byte-offset))))
1791 (let* ((h (ldb (byte 16 16) value))
1792 (l (ldb (byte 16 0) value)))
1793 (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
1794 (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
1796 (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
1797 (ldb (byte 16 0) value)))))
1801 (error "can't deal with call fixups yet"))
1803 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1804 (dpb (ldb (byte 22 10) value)
1806 (bvref-32 gspace-bytes gspace-byte-offset))))
1808 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1809 (dpb (ldb (byte 10 0) value)
1811 (bvref-32 gspace-bytes gspace-byte-offset))))))
1813 (let* ((un-fixed-up (bvref-32 gspace-bytes
1814 gspace-byte-offset))
1815 (code-object-start-addr (logandc2 (descriptor-bits code-object)
1816 sb!vm:lowtag-mask)))
1817 (assert (= code-object-start-addr
1818 (+ gspace-byte-address
1819 (descriptor-byte-offset code-object))))
1822 (let ((fixed-up (+ value un-fixed-up)))
1823 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1825 ;; comment from CMU CL sources:
1827 ;; Note absolute fixups that point within the object.
1828 ;; KLUDGE: There seems to be an implicit assumption in
1829 ;; the old CMU CL code here, that if it doesn't point
1830 ;; before the object, it must point within the object
1831 ;; (not beyond it). It would be good to add an
1832 ;; explanation of why that's true, or an assertion that
1833 ;; it's really true, or both.
1834 (unless (< fixed-up code-object-start-addr)
1835 (note-load-time-code-fixup code-object
1839 (:relative ; (used for arguments to X86 relative CALL instruction)
1840 (let ((fixed-up (- (+ value un-fixed-up)
1843 sb!vm:n-word-bytes))) ; length of CALL argument
1844 (setf (bvref-32 gspace-bytes gspace-byte-offset)
1846 ;; Note relative fixups that point outside the code
1847 ;; object, which is to say all relative fixups, since
1848 ;; relative addressing within a code object never needs
1850 (note-load-time-code-fixup code-object
1856 (defun resolve-assembler-fixups ()
1857 (dolist (fixup *cold-assembler-fixups*)
1858 (let* ((routine (car fixup))
1859 (value (lookup-assembler-reference routine)))
1861 (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
1863 ;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in
1864 ;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to
1865 ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
1866 ;;; target-load.lisp refers to.
1867 (defun linkage-info-to-core ()
1868 (let ((result *nil-descriptor*))
1869 (maphash (lambda (symbol value)
1870 (cold-push (cold-cons (string-to-core symbol)
1871 (number-to-core value))
1873 *cold-foreign-symbol-table*)
1874 (cold-set (cold-intern '*!initial-foreign-symbols*) result))
1875 (let ((result *nil-descriptor*))
1876 (dolist (rtn *cold-assembler-routines*)
1877 (cold-push (cold-cons (cold-intern (car rtn))
1878 (number-to-core (cdr rtn)))
1880 (cold-set (cold-intern '*!initial-assembler-routines*) result)))
1882 ;;;; general machinery for cold-loading FASL files
1884 ;;; FOP functions for cold loading
1885 (defvar *cold-fop-funs*
1886 ;; We start out with a copy of the ordinary *FOP-FUNS*. The ones
1887 ;; which aren't appropriate for cold load will be destructively
1889 (copy-seq *fop-funs*))
1891 (defvar *normal-fop-funs*)
1893 ;;; Cause a fop to have a special definition for cold load.
1895 ;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version
1896 ;;; (1) looks up the code for this name (created by a previous
1897 ;; DEFINE-FOP) instead of creating a code, and
1898 ;;; (2) stores its definition in the *COLD-FOP-FUNS* vector,
1899 ;;; instead of storing in the *FOP-FUNS* vector.
1900 (defmacro define-cold-fop ((name &key (pushp t) (stackp t)) &rest forms)
1901 (aver (member pushp '(nil t)))
1902 (aver (member stackp '(nil t)))
1903 (let ((code (get name 'fop-code))
1904 (fname (symbolicate "COLD-" name)))
1906 (error "~S is not a defined FOP." name))
1910 `((with-fop-stack ,pushp ,@forms))
1912 (setf (svref *cold-fop-funs* ,code) #',fname))))
1914 (defmacro clone-cold-fop ((name &key (pushp t) (stackp t))
1917 (aver (member pushp '(nil t)))
1918 (aver (member stackp '(nil t)))
1920 (macrolet ((clone-arg () '(read-arg 4)))
1921 (define-cold-fop (,name :pushp ,pushp :stackp ,stackp) ,@forms))
1922 (macrolet ((clone-arg () '(read-arg 1)))
1923 (define-cold-fop (,small-name :pushp ,pushp :stackp ,stackp) ,@forms))))
1925 ;;; Cause a fop to be undefined in cold load.
1926 (defmacro not-cold-fop (name)
1927 `(define-cold-fop (,name)
1928 (error "The fop ~S is not supported in cold load." ',name)))
1930 ;;; COLD-LOAD loads stuff into the core image being built by calling
1931 ;;; LOAD-AS-FASL with the fop function table rebound to a table of cold
1932 ;;; loading functions.
1933 (defun cold-load (filename)
1935 "Load the file named by FILENAME into the cold load image being built."
1936 (let* ((*normal-fop-funs* *fop-funs*)
1937 (*fop-funs* *cold-fop-funs*)
1938 (*cold-load-filename* (etypecase filename
1940 (pathname (namestring filename)))))
1941 (with-open-file (s filename :element-type '(unsigned-byte 8))
1942 (load-as-fasl s nil nil))))
1944 ;;;; miscellaneous cold fops
1946 (define-cold-fop (fop-misc-trap) *unbound-marker*)
1948 (define-cold-fop (fop-short-character)
1949 (make-character-descriptor (read-arg 1)))
1951 (define-cold-fop (fop-empty-list) *nil-descriptor*)
1952 (define-cold-fop (fop-truth) (cold-intern t))
1954 (define-cold-fop (fop-normal-load :stackp nil)
1955 (setq *fop-funs* *normal-fop-funs*))
1957 (define-fop (fop-maybe-cold-load 82 :stackp nil)
1958 (when *cold-load-filename*
1959 (setq *fop-funs* *cold-fop-funs*)))
1961 (define-cold-fop (fop-maybe-cold-load :stackp nil))
1963 (clone-cold-fop (fop-struct)
1965 (let* ((size (clone-arg))
1966 (result (allocate-boxed-object *dynamic*
1968 sb!vm:instance-pointer-lowtag)))
1969 (write-memory result (make-other-immediate-descriptor
1970 size sb!vm:instance-header-widetag))
1971 (do ((index (1- size) (1- index)))
1973 (declare (fixnum index))
1974 (write-wordindexed result
1975 (+ index sb!vm:instance-slots-offset)
1979 (define-cold-fop (fop-layout)
1980 (let* ((length-des (pop-stack))
1981 (depthoid-des (pop-stack))
1982 (cold-inherits (pop-stack))
1984 (old (gethash name *cold-layouts*)))
1985 (declare (type descriptor length-des depthoid-des cold-inherits))
1986 (declare (type symbol name))
1987 ;; If a layout of this name has been defined already
1989 ;; Enforce consistency between the previous definition and the
1990 ;; current definition, then return the previous definition.
1992 ;; FIXME: This would be more maintainable if we used
1993 ;; DEFSTRUCT (:TYPE LIST) to define COLD-LAYOUT. -- WHN 19990825
1994 (old-layout-descriptor
2000 (declare (type descriptor old-layout-descriptor))
2001 (declare (type index old-length))
2002 (declare (type fixnum old-depthoid))
2003 (declare (type list old-inherits-list))
2004 (aver (eq name old-name))
2005 (let ((length (descriptor-fixnum length-des))
2006 (inherits-list (listify-cold-inherits cold-inherits))
2007 (depthoid (descriptor-fixnum depthoid-des)))
2008 (unless (= length old-length)
2009 (error "cold loading a reference to class ~S when the compile~%~
2010 time length was ~S and current length is ~S"
2014 (unless (equal inherits-list old-inherits-list)
2015 (error "cold loading a reference to class ~S when the compile~%~
2016 time inherits were ~S~%~
2017 and current inherits are ~S"
2021 (unless (= depthoid old-depthoid)
2022 (error "cold loading a reference to class ~S when the compile~%~
2023 time inheritance depthoid was ~S and current inheritance~%~
2028 old-layout-descriptor)
2029 ;; Make a new definition from scratch.
2030 (make-cold-layout name length-des cold-inherits depthoid-des))))
2032 ;;;; cold fops for loading symbols
2034 ;;; Load a symbol SIZE characters long from *FASL-INPUT-STREAM* and
2035 ;;; intern that symbol in PACKAGE.
2036 (defun cold-load-symbol (size package)
2037 (let ((string (make-string size)))
2038 (read-string-as-bytes *fasl-input-stream* string)
2039 (cold-intern (intern string package))))
2041 (macrolet ((frob (name pname-len package-len)
2042 `(define-cold-fop (,name)
2043 (let ((index (read-arg ,package-len)))
2045 (cold-load-symbol (read-arg ,pname-len)
2046 (svref *current-fop-table* index)))))))
2047 (frob fop-symbol-in-package-save 4 4)
2048 (frob fop-small-symbol-in-package-save 1 4)
2049 (frob fop-symbol-in-byte-package-save 4 1)
2050 (frob fop-small-symbol-in-byte-package-save 1 1))
2052 (clone-cold-fop (fop-lisp-symbol-save)
2053 (fop-lisp-small-symbol-save)
2054 (push-fop-table (cold-load-symbol (clone-arg) *cl-package*)))
2056 (clone-cold-fop (fop-keyword-symbol-save)
2057 (fop-keyword-small-symbol-save)
2058 (push-fop-table (cold-load-symbol (clone-arg) *keyword-package*)))
2060 (clone-cold-fop (fop-uninterned-symbol-save)
2061 (fop-uninterned-small-symbol-save)
2062 (let* ((size (clone-arg))
2063 (name (make-string size)))
2064 (read-string-as-bytes *fasl-input-stream* name)
2065 (let ((symbol-des (allocate-symbol name)))
2066 (push-fop-table symbol-des))))
2068 ;;;; cold fops for loading lists
2070 ;;; Make a list of the top LENGTH things on the fop stack. The last
2071 ;;; cdr of the list is set to LAST.
2072 (defmacro cold-stack-list (length last)
2073 `(do* ((index ,length (1- index))
2074 (result ,last (cold-cons (pop-stack) result)))
2075 ((= index 0) result)
2076 (declare (fixnum index))))
2078 (define-cold-fop (fop-list)
2079 (cold-stack-list (read-arg 1) *nil-descriptor*))
2080 (define-cold-fop (fop-list*)
2081 (cold-stack-list (read-arg 1) (pop-stack)))
2082 (define-cold-fop (fop-list-1)
2083 (cold-stack-list 1 *nil-descriptor*))
2084 (define-cold-fop (fop-list-2)
2085 (cold-stack-list 2 *nil-descriptor*))
2086 (define-cold-fop (fop-list-3)
2087 (cold-stack-list 3 *nil-descriptor*))
2088 (define-cold-fop (fop-list-4)
2089 (cold-stack-list 4 *nil-descriptor*))
2090 (define-cold-fop (fop-list-5)
2091 (cold-stack-list 5 *nil-descriptor*))
2092 (define-cold-fop (fop-list-6)
2093 (cold-stack-list 6 *nil-descriptor*))
2094 (define-cold-fop (fop-list-7)
2095 (cold-stack-list 7 *nil-descriptor*))
2096 (define-cold-fop (fop-list-8)
2097 (cold-stack-list 8 *nil-descriptor*))
2098 (define-cold-fop (fop-list*-1)
2099 (cold-stack-list 1 (pop-stack)))
2100 (define-cold-fop (fop-list*-2)
2101 (cold-stack-list 2 (pop-stack)))
2102 (define-cold-fop (fop-list*-3)
2103 (cold-stack-list 3 (pop-stack)))
2104 (define-cold-fop (fop-list*-4)
2105 (cold-stack-list 4 (pop-stack)))
2106 (define-cold-fop (fop-list*-5)
2107 (cold-stack-list 5 (pop-stack)))
2108 (define-cold-fop (fop-list*-6)
2109 (cold-stack-list 6 (pop-stack)))
2110 (define-cold-fop (fop-list*-7)
2111 (cold-stack-list 7 (pop-stack)))
2112 (define-cold-fop (fop-list*-8)
2113 (cold-stack-list 8 (pop-stack)))
2115 ;;;; cold fops for loading vectors
2117 (clone-cold-fop (fop-string)
2119 (let* ((len (clone-arg))
2120 (string (make-string len)))
2121 (read-string-as-bytes *fasl-input-stream* string)
2122 (string-to-core string)))
2124 (clone-cold-fop (fop-vector)
2126 (let* ((size (clone-arg))
2127 (result (allocate-vector-object *dynamic*
2130 sb!vm:simple-vector-widetag)))
2131 (do ((index (1- size) (1- index)))
2133 (declare (fixnum index))
2134 (write-wordindexed result
2135 (+ index sb!vm:vector-data-offset)
2139 (define-cold-fop (fop-int-vector)
2140 (let* ((len (read-arg 4))
2141 (sizebits (read-arg 1))
2142 (type (case sizebits
2143 (0 sb!vm:simple-array-nil-widetag)
2144 (1 sb!vm:simple-bit-vector-widetag)
2145 (2 sb!vm:simple-array-unsigned-byte-2-widetag)
2146 (4 sb!vm:simple-array-unsigned-byte-4-widetag)
2147 (7 (prog1 sb!vm:simple-array-unsigned-byte-7-widetag
2149 (8 sb!vm:simple-array-unsigned-byte-8-widetag)
2150 (15 (prog1 sb!vm:simple-array-unsigned-byte-15-widetag
2151 (setf sizebits 16)))
2152 (16 sb!vm:simple-array-unsigned-byte-16-widetag)
2153 (31 (prog1 sb!vm:simple-array-unsigned-byte-31-widetag
2154 (setf sizebits 32)))
2155 (32 sb!vm:simple-array-unsigned-byte-32-widetag)
2156 (t (error "losing element size: ~W" sizebits))))
2157 (result (allocate-vector-object *dynamic* sizebits len type))
2158 (start (+ (descriptor-byte-offset result)
2159 (ash sb!vm:vector-data-offset sb!vm:word-shift)))
2161 (ceiling (* len sizebits)
2162 sb!vm:n-byte-bits))))
2163 (read-bigvec-as-sequence-or-die (descriptor-bytes result)
2169 (define-cold-fop (fop-single-float-vector)
2170 (let* ((len (read-arg 4))
2171 (result (allocate-vector-object
2175 sb!vm:simple-array-single-float-widetag))
2176 (start (+ (descriptor-byte-offset result)
2177 (ash sb!vm:vector-data-offset sb!vm:word-shift)))
2178 (end (+ start (* len sb!vm:n-word-bytes))))
2179 (read-bigvec-as-sequence-or-die (descriptor-bytes result)
2185 (not-cold-fop fop-double-float-vector)
2186 #!+long-float (not-cold-fop fop-long-float-vector)
2187 (not-cold-fop fop-complex-single-float-vector)
2188 (not-cold-fop fop-complex-double-float-vector)
2189 #!+long-float (not-cold-fop fop-complex-long-float-vector)
2191 (define-cold-fop (fop-array)
2192 (let* ((rank (read-arg 4))
2193 (data-vector (pop-stack))
2194 (result (allocate-boxed-object *dynamic*
2195 (+ sb!vm:array-dimensions-offset rank)
2196 sb!vm:other-pointer-lowtag)))
2197 (write-memory result
2198 (make-other-immediate-descriptor rank
2199 sb!vm:simple-array-widetag))
2200 (write-wordindexed result sb!vm:array-fill-pointer-slot *nil-descriptor*)
2201 (write-wordindexed result sb!vm:array-data-slot data-vector)
2202 (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
2203 (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)
2204 (let ((total-elements 1))
2205 (dotimes (axis rank)
2206 (let ((dim (pop-stack)))
2207 (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-lowtag)
2208 (= (descriptor-lowtag dim) sb!vm:odd-fixnum-lowtag))
2209 (error "non-fixnum dimension? (~S)" dim))
2210 (setf total-elements
2212 (logior (ash (descriptor-high dim)
2213 (- descriptor-low-bits
2214 (1- sb!vm:n-lowtag-bits)))
2215 (ash (descriptor-low dim)
2216 (- 1 sb!vm:n-lowtag-bits)))))
2217 (write-wordindexed result
2218 (+ sb!vm:array-dimensions-offset axis)
2220 (write-wordindexed result
2221 sb!vm:array-elements-slot
2222 (make-fixnum-descriptor total-elements)))
2225 ;;;; cold fops for loading numbers
2227 (defmacro define-cold-number-fop (fop)
2228 `(define-cold-fop (,fop :stackp nil)
2229 ;; Invoke the ordinary warm version of this fop to push the
2232 ;; Replace the warm fop result with the cold image of the warm
2235 (let ((number (pop-stack)))
2236 (number-to-core number)))))
2238 (define-cold-number-fop fop-single-float)
2239 (define-cold-number-fop fop-double-float)
2240 (define-cold-number-fop fop-integer)
2241 (define-cold-number-fop fop-small-integer)
2242 (define-cold-number-fop fop-word-integer)
2243 (define-cold-number-fop fop-byte-integer)
2244 (define-cold-number-fop fop-complex-single-float)
2245 (define-cold-number-fop fop-complex-double-float)
2248 (define-cold-fop (fop-long-float)
2249 (ecase +backend-fasl-file-implementation+
2250 (:x86 ; (which has 80-bit long-float format)
2251 (prepare-for-fast-read-byte *fasl-input-stream*
2252 (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
2253 (1- sb!vm:long-float-size)
2254 sb!vm:long-float-widetag))
2255 (low-bits (make-random-descriptor (fast-read-u-integer 4)))
2256 (high-bits (make-random-descriptor (fast-read-u-integer 4)))
2257 (exp-bits (make-random-descriptor (fast-read-s-integer 2))))
2258 (done-with-fast-read-byte)
2259 (write-wordindexed des sb!vm:long-float-value-slot low-bits)
2260 (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits)
2261 (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits)
2263 ;; This was supported in CMU CL, but isn't currently supported in
2266 (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format
2267 (prepare-for-fast-read-byte *fasl-input-stream*
2268 (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
2269 (1- sb!vm:long-float-size)
2270 sb!vm:long-float-widetag))
2271 (low-bits (make-random-descriptor (fast-read-u-integer 4)))
2272 (mid-bits (make-random-descriptor (fast-read-u-integer 4)))
2273 (high-bits (make-random-descriptor (fast-read-u-integer 4)))
2274 (exp-bits (make-random-descriptor (fast-read-s-integer 4))))
2275 (done-with-fast-read-byte)
2276 (write-wordindexed des sb!vm:long-float-value-slot exp-bits)
2277 (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits)
2278 (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) mid-bits)
2279 (write-wordindexed des (+ 3 sb!vm:long-float-value-slot) low-bits)
2283 (define-cold-fop (fop-complex-long-float)
2284 (ecase +backend-fasl-file-implementation+
2285 (:x86 ; (which has 80-bit long-float format)
2286 (prepare-for-fast-read-byte *fasl-input-stream*
2287 (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
2288 (1- sb!vm:complex-long-float-size)
2289 sb!vm:complex-long-float-widetag))
2290 (real-low-bits (make-random-descriptor (fast-read-u-integer 4)))
2291 (real-high-bits (make-random-descriptor (fast-read-u-integer 4)))
2292 (real-exp-bits (make-random-descriptor (fast-read-s-integer 2)))
2293 (imag-low-bits (make-random-descriptor (fast-read-u-integer 4)))
2294 (imag-high-bits (make-random-descriptor (fast-read-u-integer 4)))
2295 (imag-exp-bits (make-random-descriptor (fast-read-s-integer 2))))
2296 (done-with-fast-read-byte)
2297 (write-wordindexed des
2298 sb!vm:complex-long-float-real-slot
2300 (write-wordindexed des
2301 (1+ sb!vm:complex-long-float-real-slot)
2303 (write-wordindexed des
2304 (+ 2 sb!vm:complex-long-float-real-slot)
2306 (write-wordindexed des
2307 sb!vm:complex-long-float-imag-slot
2309 (write-wordindexed des
2310 (1+ sb!vm:complex-long-float-imag-slot)
2312 (write-wordindexed des
2313 (+ 2 sb!vm:complex-long-float-imag-slot)
2316 ;; This was supported in CMU CL, but isn't currently supported in SBCL.
2318 (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format
2319 (prepare-for-fast-read-byte *fasl-input-stream*
2320 (let* ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
2321 (1- sb!vm:complex-long-float-size)
2322 sb!vm:complex-long-float-widetag))
2323 (real-low-bits (make-random-descriptor (fast-read-u-integer 4)))
2324 (real-mid-bits (make-random-descriptor (fast-read-u-integer 4)))
2325 (real-high-bits (make-random-descriptor (fast-read-u-integer 4)))
2326 (real-exp-bits (make-random-descriptor (fast-read-s-integer 4)))
2327 (imag-low-bits (make-random-descriptor (fast-read-u-integer 4)))
2328 (imag-mid-bits (make-random-descriptor (fast-read-u-integer 4)))
2329 (imag-high-bits (make-random-descriptor (fast-read-u-integer 4)))
2330 (imag-exp-bits (make-random-descriptor (fast-read-s-integer 4))))
2331 (done-with-fast-read-byte)
2332 (write-wordindexed des
2333 sb!vm:complex-long-float-real-slot
2335 (write-wordindexed des
2336 (1+ sb!vm:complex-long-float-real-slot)
2338 (write-wordindexed des
2339 (+ 2 sb!vm:complex-long-float-real-slot)
2341 (write-wordindexed des
2342 (+ 3 sb!vm:complex-long-float-real-slot)
2344 (write-wordindexed des
2345 sb!vm:complex-long-float-real-slot
2347 (write-wordindexed des
2348 (1+ sb!vm:complex-long-float-real-slot)
2350 (write-wordindexed des
2351 (+ 2 sb!vm:complex-long-float-real-slot)
2353 (write-wordindexed des
2354 (+ 3 sb!vm:complex-long-float-real-slot)
2358 (define-cold-fop (fop-ratio)
2359 (let ((den (pop-stack)))
2360 (number-pair-to-core (pop-stack) den sb!vm:ratio-widetag)))
2362 (define-cold-fop (fop-complex)
2363 (let ((im (pop-stack)))
2364 (number-pair-to-core (pop-stack) im sb!vm:complex-widetag)))
2366 ;;;; cold fops for calling (or not calling)
2368 (not-cold-fop fop-eval)
2369 (not-cold-fop fop-eval-for-effect)
2371 (defvar *load-time-value-counter*)
2373 (define-cold-fop (fop-funcall)
2374 (unless (= (read-arg 1) 0)
2375 (error "You can't FOP-FUNCALL arbitrary stuff in cold load."))
2376 (let ((counter *load-time-value-counter*))
2377 (cold-push (cold-cons
2378 (cold-intern :load-time-value)
2382 (number-to-core counter)
2384 *current-reversed-cold-toplevels*)
2385 (setf *load-time-value-counter* (1+ counter))
2386 (make-descriptor 0 0 nil counter)))
2388 (defun finalize-load-time-value-noise ()
2389 (cold-set (cold-intern '*!load-time-values*)
2390 (allocate-vector-object *dynamic*
2392 *load-time-value-counter*
2393 sb!vm:simple-vector-widetag)))
2395 (define-cold-fop (fop-funcall-for-effect :pushp nil)
2396 (if (= (read-arg 1) 0)
2397 (cold-push (pop-stack)
2398 *current-reversed-cold-toplevels*)
2399 (error "You can't FOP-FUNCALL arbitrary stuff in cold load.")))
2401 ;;;; cold fops for fixing up circularities
2403 (define-cold-fop (fop-rplaca :pushp nil)
2404 (let ((obj (svref *current-fop-table* (read-arg 4)))
2406 (write-memory (cold-nthcdr idx obj) (pop-stack))))
2408 (define-cold-fop (fop-rplacd :pushp nil)
2409 (let ((obj (svref *current-fop-table* (read-arg 4)))
2411 (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack))))
2413 (define-cold-fop (fop-svset :pushp nil)
2414 (let ((obj (svref *current-fop-table* (read-arg 4)))
2416 (write-wordindexed obj
2418 (ecase (descriptor-lowtag obj)
2419 (#.sb!vm:instance-pointer-lowtag 1)
2420 (#.sb!vm:other-pointer-lowtag 2)))
2423 (define-cold-fop (fop-structset :pushp nil)
2424 (let ((obj (svref *current-fop-table* (read-arg 4)))
2426 (write-wordindexed obj (1+ idx) (pop-stack))))
2428 ;;; In the original CMUCL code, this actually explicitly declared PUSHP
2429 ;;; to be T, even though that's what it defaults to in DEFINE-COLD-FOP.
2430 (define-cold-fop (fop-nthcdr)
2431 (cold-nthcdr (read-arg 4) (pop-stack)))
2433 (defun cold-nthcdr (index obj)
2435 (setq obj (read-wordindexed obj 1)))
2438 ;;;; cold fops for loading code objects and functions
2440 ;;; the names of things which have had COLD-FSET used on them already
2441 ;;; (used to make sure that we don't try to statically link a name to
2442 ;;; more than one definition)
2443 (defparameter *cold-fset-warm-names*
2444 ;; This can't be an EQL hash table because names can be conses, e.g.
2446 (make-hash-table :test 'equal))
2448 (define-cold-fop (fop-fset :pushp nil)
2449 (let* ((fn (pop-stack))
2450 (cold-name (pop-stack))
2451 (warm-name (warm-fun-name cold-name)))
2452 (if (gethash warm-name *cold-fset-warm-names*)
2453 (error "duplicate COLD-FSET for ~S" warm-name)
2454 (setf (gethash warm-name *cold-fset-warm-names*) t))
2455 (static-fset cold-name fn)))
2457 (define-cold-fop (fop-fdefinition)
2458 (cold-fdefinition-object (pop-stack)))
2460 (define-cold-fop (fop-sanctify-for-execution)
2463 ;;; Setting this variable shows what code looks like before any
2464 ;;; fixups (or function headers) are applied.
2465 #!+sb-show (defvar *show-pre-fixup-code-p* nil)
2467 ;;; FIXME: The logic here should be converted into a function
2468 ;;; COLD-CODE-FOP-GUTS (NCONST CODE-SIZE) called by DEFINE-COLD-FOP
2469 ;;; FOP-CODE and DEFINE-COLD-FOP FOP-SMALL-CODE, so that
2470 ;;; variable-capture nastiness like (LET ((NCONST ,NCONST) ..) ..)
2471 ;;; doesn't keep me awake at night.
2472 (defmacro define-cold-code-fop (name nconst code-size)
2473 `(define-cold-fop (,name)
2474 (let* ((nconst ,nconst)
2475 (code-size ,code-size)
2476 (raw-header-n-words (+ sb!vm:code-trace-table-offset-slot nconst))
2478 ;; Note: we round the number of constants up to ensure
2479 ;; that the code vector will be properly aligned.
2480 (round-up raw-header-n-words 2))
2481 (des (allocate-cold-descriptor *dynamic*
2482 (+ (ash header-n-words
2485 sb!vm:other-pointer-lowtag)))
2487 (make-other-immediate-descriptor
2488 header-n-words sb!vm:code-header-widetag))
2489 (write-wordindexed des
2490 sb!vm:code-code-size-slot
2491 (make-fixnum-descriptor
2492 (ash (+ code-size (1- (ash 1 sb!vm:word-shift)))
2493 (- sb!vm:word-shift))))
2494 (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
2495 (write-wordindexed des sb!vm:code-debug-info-slot (pop-stack))
2496 (when (oddp raw-header-n-words)
2497 (write-wordindexed des
2499 (make-random-descriptor 0)))
2500 (do ((index (1- raw-header-n-words) (1- index)))
2501 ((< index sb!vm:code-trace-table-offset-slot))
2502 (write-wordindexed des index (pop-stack)))
2503 (let* ((start (+ (descriptor-byte-offset des)
2504 (ash header-n-words sb!vm:word-shift)))
2505 (end (+ start code-size)))
2506 (read-bigvec-as-sequence-or-die (descriptor-bytes des)
2511 (when *show-pre-fixup-code-p*
2512 (format *trace-output*
2513 "~&/raw code from code-fop ~W ~W:~%"
2516 (do ((i start (+ i sb!vm:n-word-bytes)))
2518 (format *trace-output*
2519 "/#X~8,'0x: #X~8,'0x~%"
2520 (+ i (gspace-byte-address (descriptor-gspace des)))
2521 (bvref-32 (descriptor-bytes des) i)))))
2524 (define-cold-code-fop fop-code (read-arg 4) (read-arg 4))
2526 (define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2))
2528 (clone-cold-fop (fop-alter-code :pushp nil)
2529 (fop-byte-alter-code)
2530 (let ((slot (clone-arg))
2533 (write-wordindexed code slot value)))
2535 (define-cold-fop (fop-fun-entry)
2536 (let* ((type (pop-stack))
2537 (arglist (pop-stack))
2539 (code-object (pop-stack))
2540 (offset (calc-offset code-object (read-arg 4)))
2541 (fn (descriptor-beyond code-object
2543 sb!vm:fun-pointer-lowtag))
2544 (next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
2545 (unless (zerop (logand offset sb!vm:lowtag-mask))
2546 (error "unaligned function entry: ~S at #X~X" name offset))
2547 (write-wordindexed code-object sb!vm:code-entry-points-slot fn)
2549 (make-other-immediate-descriptor
2550 (ash offset (- sb!vm:word-shift))
2551 sb!vm:simple-fun-header-widetag))
2552 (write-wordindexed fn
2553 sb!vm:simple-fun-self-slot
2554 ;; KLUDGE: Wiring decisions like this in at
2555 ;; this level ("if it's an x86") instead of a
2556 ;; higher level of abstraction ("if it has such
2557 ;; and such relocation peculiarities (which
2558 ;; happen to be confined to the x86)") is bad.
2559 ;; It would be nice if the code were instead
2560 ;; conditional on some more descriptive
2561 ;; feature, :STICKY-CODE or
2562 ;; :LOAD-GC-INTERACTION or something.
2564 ;; FIXME: The X86 definition of the function
2565 ;; self slot breaks everything object.tex says
2566 ;; about it. (As far as I can tell, the X86
2567 ;; definition makes it a pointer to the actual
2568 ;; code instead of a pointer back to the object
2569 ;; itself.) Ask on the mailing list whether
2570 ;; this is documented somewhere, and if not,
2571 ;; try to reverse engineer some documentation.
2573 ;; a pointer back to the function object, as
2574 ;; described in CMU CL
2575 ;; src/docs/internals/object.tex
2578 ;; KLUDGE: a pointer to the actual code of the
2579 ;; object, as described nowhere that I can find
2581 (make-random-descriptor
2582 (+ (descriptor-bits fn)
2583 (- (ash sb!vm:simple-fun-code-offset
2585 ;; FIXME: We should mask out the type
2586 ;; bits, not assume we know what they
2587 ;; are and subtract them out this way.
2588 sb!vm:fun-pointer-lowtag))))
2589 (write-wordindexed fn sb!vm:simple-fun-next-slot next)
2590 (write-wordindexed fn sb!vm:simple-fun-name-slot name)
2591 (write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist)
2592 (write-wordindexed fn sb!vm:simple-fun-type-slot type)
2595 (define-cold-fop (fop-foreign-fixup)
2596 (let* ((kind (pop-stack))
2597 (code-object (pop-stack))
2599 (sym (make-string len)))
2600 (read-string-as-bytes *fasl-input-stream* sym)
2601 (let ((offset (read-arg 4))
2602 (value (cold-foreign-symbol-address-as-integer sym)))
2603 (do-cold-fixup code-object offset value kind))
2606 (define-cold-fop (fop-assembler-code)
2607 (let* ((length (read-arg 4))
2609 ;; Note: we round the number of constants up to ensure that
2610 ;; the code vector will be properly aligned.
2611 (round-up sb!vm:code-constants-offset 2))
2612 (des (allocate-cold-descriptor *read-only*
2613 (+ (ash header-n-words
2616 sb!vm:other-pointer-lowtag)))
2618 (make-other-immediate-descriptor
2619 header-n-words sb!vm:code-header-widetag))
2620 (write-wordindexed des
2621 sb!vm:code-code-size-slot
2622 (make-fixnum-descriptor
2623 (ash (+ length (1- (ash 1 sb!vm:word-shift)))
2624 (- sb!vm:word-shift))))
2625 (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
2626 (write-wordindexed des sb!vm:code-debug-info-slot *nil-descriptor*)
2628 (let* ((start (+ (descriptor-byte-offset des)
2629 (ash header-n-words sb!vm:word-shift)))
2630 (end (+ start length)))
2631 (read-bigvec-as-sequence-or-die (descriptor-bytes des)
2637 (define-cold-fop (fop-assembler-routine)
2638 (let* ((routine (pop-stack))
2640 (offset (calc-offset des (read-arg 4))))
2641 (record-cold-assembler-routine
2643 (+ (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) offset))
2646 (define-cold-fop (fop-assembler-fixup)
2647 (let* ((routine (pop-stack))
2649 (code-object (pop-stack))
2650 (offset (read-arg 4)))
2651 (record-cold-assembler-fixup routine code-object offset kind)
2654 (define-cold-fop (fop-code-object-fixup)
2655 (let* ((kind (pop-stack))
2656 (code-object (pop-stack))
2657 (offset (read-arg 4))
2658 (value (descriptor-bits code-object)))
2659 (do-cold-fixup code-object offset value kind)
2662 ;;;; emitting C header file
2664 (defun tailwise-equal (string tail)
2665 (and (>= (length string) (length tail))
2666 (string= string tail :start1 (- (length string) (length tail)))))
2668 (defun write-boilerplate ()
2671 '("This is a machine-generated file. Please do not edit it by hand."
2673 "This file contains low-level information about the"
2674 "internals of a particular version and configuration"
2675 "of SBCL. It is used by the C compiler to create a runtime"
2676 "support environment, an executable program in the host"
2677 "operating system's native format, which can then be used to"
2678 "load and run 'core' files, which are basically programs"
2679 "in SBCL's own format."))
2680 (format t " * ~A~%" line))
2683 (defun write-config-h ()
2684 ;; propagating *SHEBANG-FEATURES* into C-level #define's
2685 (dolist (shebang-feature-name (sort (mapcar #'symbol-name
2686 sb-cold:*shebang-features*)
2689 "#define LISP_FEATURE_~A~%"
2690 (substitute #\_ #\- shebang-feature-name)))
2692 ;; and miscellaneous constants
2693 (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
2695 "#define SBCL_VERSION_STRING ~S~%"
2696 (sb!xc:lisp-implementation-version))
2697 (format t "#define CORE_MAGIC 0x~X~%" core-magic)
2698 (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
2699 (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
2700 (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
2701 (format t "#define LISPOBJ(thing) thing~2%")
2702 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")
2705 (defun write-constants-h ()
2706 ;; writing entire families of named constants
2707 (let ((constants nil))
2708 (dolist (package-name '(;; Even in CMU CL, constants from VM
2709 ;; were automatically propagated
2710 ;; into the runtime.
2712 ;; In SBCL, we also propagate various
2713 ;; magic numbers related to file format,
2714 ;; which live here instead of SB!VM.
2716 (do-external-symbols (symbol (find-package package-name))
2717 (when (constantp symbol)
2718 (let ((name (symbol-name symbol)))
2719 (labels (;; shared machinery
2720 (record (string priority)
2723 (symbol-value symbol)
2724 (documentation symbol 'variable))
2726 ;; machinery for old-style CMU CL Lisp-to-C
2727 ;; arbitrary renaming, being phased out in favor of
2728 ;; the newer systematic RECORD-WITH-TRANSLATED-NAME
2730 (record-with-munged-name (prefix string priority)
2731 (record (concatenate
2734 (delete #\- (string-capitalize string)))
2736 (maybe-record-with-munged-name (tail prefix priority)
2737 (when (tailwise-equal name tail)
2738 (record-with-munged-name prefix
2743 ;; machinery for new-style SBCL Lisp-to-C naming
2744 (record-with-translated-name (priority)
2745 (record (substitute #\_ #\- name)
2747 (maybe-record-with-translated-name (suffixes priority)
2748 (when (some (lambda (suffix)
2749 (tailwise-equal name suffix))
2751 (record-with-translated-name priority))))
2753 (maybe-record-with-translated-name '("-LOWTAG") 0)
2754 (maybe-record-with-translated-name '("-WIDETAG") 1)
2755 (maybe-record-with-munged-name "-FLAG" "flag_" 2)
2756 (maybe-record-with-munged-name "-TRAP" "trap_" 3)
2757 (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
2758 (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
2759 (maybe-record-with-translated-name '("-START" "-END") 6)
2760 (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7)
2761 (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8))))))
2764 (lambda (const1 const2)
2765 (if (= (second const1) (second const2))
2766 (< (third const1) (third const2))
2767 (< (second const1) (second const2))))))
2768 (let ((prev-priority (second (car constants))))
2769 (dolist (const constants)
2770 (destructuring-bind (name priority value doc) const
2771 (unless (= prev-priority priority)
2773 (setf prev-priority priority))
2774 (format t "#define ~A " name)
2776 ;; KLUDGE: As of sbcl-0.6.7.14, we're dumping two
2777 ;; different kinds of values here, (1) small codes
2778 ;; and (2) machine addresses. The small codes can be
2779 ;; dumped as bare integer values. The large machine
2780 ;; addresses might cause problems if they're large
2781 ;; and represented as (signed) C integers, so we
2782 ;; want to force them to be unsigned. We do that by
2783 ;; wrapping them in the LISPOBJ macro. (We could do
2784 ;; it with a bare "(unsigned)" cast, except that
2785 ;; this header file is used not only in C files, but
2786 ;; also in assembly files, which don't understand
2787 ;; the cast syntax. The LISPOBJ macro goes away in
2788 ;; assembly files, but that shouldn't matter because
2789 ;; we don't do arithmetic on address constants in
2790 ;; assembly files. See? It really is a kludge..) --
2792 (let (;; cutoff for treatment as a small code
2793 (cutoff (expt 2 16)))
2794 (cond ((minusp value)
2795 (error "stub: negative values unsupported"))
2801 (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc))))
2804 ;; writing information about internal errors
2805 (let ((internal-errors sb!c:*backend-internal-errors*))
2806 (dotimes (i (length internal-errors))
2807 (let ((current-error (aref internal-errors i)))
2808 ;; FIXME: this UNLESS should go away (see also FIXME in
2809 ;; interr.lisp) -- APD, 2002-03-05
2810 (unless (eq nil (car current-error))
2811 (format t "#define ~A ~D~%"
2812 (substitute #\_ #\- (symbol-name (car current-error)))
2816 ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between
2817 ;; platforms. If we export this from the SB!VM package, it gets
2818 ;; written out as #define trap_PseudoAtomic, which is confusing as
2819 ;; the runtime treats trap_ as the prefix for illegal instruction
2820 ;; type things. We therefore don't export it, but instead do
2822 (when (boundp 'sb!vm::pseudo-atomic-trap)
2824 "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%"
2825 sb!vm::pseudo-atomic-trap)
2827 ;; possibly this is another candidate for a rename (to
2828 ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
2829 ;; [possibly applicable to other platforms])
2831 (dolist (symbol '(sb!vm::float-traps-byte
2832 sb!vm::float-exceptions-byte
2833 sb!vm::float-sticky-bits
2834 sb!vm::float-rounding-mode))
2835 (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%"
2836 (substitute #\_ #\- (symbol-name symbol))
2837 (sb!xc:byte-position (symbol-value symbol)))
2838 (format t "#define ~A_MASK 0x~X /* ~:*~A */~%"
2839 (substitute #\_ #\- (symbol-name symbol))
2840 (sb!xc:mask-field (symbol-value symbol) -1))))
2844 (defun write-primitive-object (obj)
2845 ;; writing primitive object layouts
2846 (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
2850 (string-downcase (string (sb!vm:primitive-object-name obj)))))
2851 (when (sb!vm:primitive-object-widetag obj)
2852 (format t " lispobj header;~%"))
2853 (dolist (slot (sb!vm:primitive-object-slots obj))
2854 (format t " ~A ~A~@[[1]~];~%"
2855 (getf (sb!vm:slot-options slot) :c-type "lispobj")
2857 (string-downcase (string (sb!vm:slot-name slot))))
2858 (sb!vm:slot-rest-p slot)))
2860 (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
2861 (let ((name (sb!vm:primitive-object-name obj))
2862 (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
2864 (dolist (slot (sb!vm:primitive-object-slots obj))
2865 (format t "#define ~A_~A_OFFSET ~D~%"
2866 (substitute #\_ #\- (string name))
2867 (substitute #\_ #\- (string (sb!vm:slot-name slot)))
2868 (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
2870 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
2872 (defun write-static-symbols ()
2873 (dolist (symbol (cons nil sb!vm:*static-symbols*))
2874 ;; FIXME: It would be nice to use longer names than NIL and
2875 ;; (particularly) T in #define statements.
2876 (format t "#define ~A LISPOBJ(0x~X)~%"
2878 (remove-if (lambda (char)
2879 (member char '(#\% #\* #\. #\!)))
2880 (symbol-name symbol)))
2881 (if *static* ; if we ran GENESIS
2882 ;; We actually ran GENESIS, use the real value.
2883 (descriptor-bits (cold-intern symbol))
2884 ;; We didn't run GENESIS, so guess at the address.
2885 (+ sb!vm:static-space-start
2887 sb!vm:other-pointer-lowtag
2888 (if symbol (sb!vm:static-symbol-offset symbol) 0))))))
2891 ;;;; writing map file
2893 ;;; Write a map file describing the cold load. Some of this
2894 ;;; information is subject to change due to relocating GC, but even so
2895 ;;; it can be very handy when attempting to troubleshoot the early
2896 ;;; stages of cold load.
2898 (let ((*print-pretty* nil)
2899 (*print-case* :upcase))
2900 (format t "assembler routines defined in core image:~2%")
2901 (dolist (routine (sort (copy-list *cold-assembler-routines*) #'<
2903 (format t "#X~8,'0X: ~S~%" (cdr routine) (car routine)))
2906 (maphash (lambda (name fdefn)
2907 (let ((fun (read-wordindexed fdefn
2908 sb!vm:fdefn-fun-slot)))
2909 (if (= (descriptor-bits fun)
2910 (descriptor-bits *nil-descriptor*))
2912 (let ((addr (read-wordindexed
2913 fdefn sb!vm:fdefn-raw-addr-slot)))
2914 (push (cons name (descriptor-bits addr))
2916 *cold-fdefn-objects*)
2917 (format t "~%~|~%initially defined functions:~2%")
2918 (setf funs (sort funs #'< :key #'cdr))
2920 (format t "0x~8,'0X: ~S #X~8,'0X~%" (cdr info) (car info)
2921 (- (cdr info) #x17)))
2924 (a note about initially undefined function references: These functions
2925 are referred to by code which is installed by GENESIS, but they are not
2926 installed by GENESIS. This is not necessarily a problem; functions can
2927 be defined later, by cold init toplevel forms, or in files compiled and
2928 loaded at warm init, or elsewhere. As long as they are defined before
2929 they are called, everything should be OK. Things are also OK if the
2930 cross-compiler knew their inline definition and used that everywhere
2931 that they were called before the out-of-line definition is installed,
2932 as is fairly common for structure accessors.)
2933 initially undefined function references:~2%")
2935 (setf undefs (sort undefs #'string< :key #'fun-name-block-name))
2936 (dolist (name undefs)
2937 (format t "~S~%" name)))
2939 (format t "~%~|~%layout names:~2%")
2941 (maphash (lambda (name gorp)
2942 (declare (ignore name))
2943 (stuff (cons (descriptor-bits (car gorp))
2946 (dolist (x (sort (stuff) #'< :key #'car))
2947 (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x))))
2951 ;;;; writing core file
2953 (defvar *core-file*)
2954 (defvar *data-page*)
2956 ;;; magic numbers to identify entries in a core file
2958 ;;; (In case you were wondering: No, AFAIK there's no special magic about
2959 ;;; these which requires them to be in the 38xx range. They're just
2960 ;;; arbitrary words, tested not for being in a particular range but just
2961 ;;; for equality. However, if you ever need to look at a .core file and
2962 ;;; figure out what's going on, it's slightly convenient that they're
2963 ;;; all in an easily recognizable range, and displacing the range away from
2964 ;;; zero seems likely to reduce the chance that random garbage will be
2965 ;;; misinterpreted as a .core file.)
2966 (defconstant version-core-entry-type-code 3860)
2967 (defconstant build-id-core-entry-type-code 3899)
2968 (defconstant new-directory-core-entry-type-code 3861)
2969 (defconstant initial-fun-core-entry-type-code 3863)
2970 (defconstant end-core-entry-type-code 3840)
2972 (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))
2973 (defun write-word (num)
2974 (ecase sb!c:*backend-byte-order*
2977 (write-byte (ldb (byte 8 (* i 8)) num) *core-file*)))
2980 (write-byte (ldb (byte 8 (* (- 3 i) 8)) num) *core-file*))))
2983 (defun advance-to-page ()
2984 (force-output *core-file*)
2985 (file-position *core-file*
2986 (round-up (file-position *core-file*)
2987 sb!c:*backend-page-size*)))
2989 (defun output-gspace (gspace)
2990 (force-output *core-file*)
2991 (let* ((posn (file-position *core-file*))
2992 (bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes))
2993 (pages (ceiling bytes sb!c:*backend-page-size*))
2994 (total-bytes (* pages sb!c:*backend-page-size*)))
2996 (file-position *core-file*
2997 (* sb!c:*backend-page-size* (1+ *data-page*)))
2999 "writing ~S byte~:P [~S page~:P] from ~S~%"
3005 ;; Note: It is assumed that the GSPACE allocation routines always
3006 ;; allocate whole pages (of size *target-page-size*) and that any
3007 ;; empty gspace between the free pointer and the end of page will
3008 ;; be zero-filled. This will always be true under Mach on machines
3009 ;; where the page size is equal. (RT is 4K, PMAX is 4K, Sun 3 is
3011 (write-bigvec-as-sequence (gspace-bytes gspace)
3014 (force-output *core-file*)
3015 (file-position *core-file* posn)
3017 ;; Write part of a (new) directory entry which looks like this:
3018 ;; GSPACE IDENTIFIER
3023 (write-word (gspace-identifier gspace))
3024 (write-word (gspace-free-word-index gspace))
3025 (write-word *data-page*)
3026 (multiple-value-bind (floor rem)
3027 (floor (gspace-byte-address gspace) sb!c:*backend-page-size*)
3032 (incf *data-page* pages)))
3034 ;;; Create a core file created from the cold loaded image. (This is
3035 ;;; the "initial core file" because core files could be created later
3036 ;;; by executing SAVE-LISP in a running system, perhaps after we've
3037 ;;; added some functionality to the system.)
3038 (declaim (ftype (function (string)) write-initial-core-file))
3039 (defun write-initial-core-file (filename)
3041 (let ((filenamestring (namestring filename))
3045 "[building initial core file in ~S: ~%"
3049 (with-open-file (*core-file* filenamestring
3051 :element-type '(unsigned-byte 8)
3052 :if-exists :rename-and-delete)
3054 ;; Write the magic number.
3055 (write-word core-magic)
3057 ;; Write the Version entry.
3058 (write-word version-core-entry-type-code)
3060 (write-word sbcl-core-version-integer)
3062 ;; Write the build ID.
3063 (write-word build-id-core-entry-type-code)
3064 (let ((build-id (with-open-file (s "output/build-id.tmp"
3067 (declare (type simple-string build-id))
3068 (/show build-id (length build-id))
3069 ;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE
3070 ;; word, this length word, and one word for each char of BUILD-ID.
3071 (write-word (+ 2 (length build-id)))
3072 (dovector (char build-id)
3073 ;; (We write each character as a word in order to avoid
3074 ;; having to think about word alignment issues in the
3075 ;; sbcl-0.7.8 version of coreparse.c.)
3076 (write-word (char-code char))))
3078 ;; Write the New Directory entry header.
3079 (write-word new-directory-core-entry-type-code)
3080 (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header.
3082 (output-gspace *read-only*)
3083 (output-gspace *static*)
3084 (output-gspace *dynamic*)
3086 ;; Write the initial function.
3087 (write-word initial-fun-core-entry-type-code)
3089 (let* ((cold-name (cold-intern '!cold-init))
3090 (cold-fdefn (cold-fdefinition-object cold-name))
3091 (initial-fun (read-wordindexed cold-fdefn
3092 sb!vm:fdefn-fun-slot)))
3094 "~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%"
3095 (descriptor-bits initial-fun))
3096 (write-word (descriptor-bits initial-fun)))
3098 ;; Write the End entry.
3099 (write-word end-core-entry-type-code)
3102 (format t "done]~%")
3104 (/show "leaving WRITE-INITIAL-CORE-FILE")
3107 ;;;; the actual GENESIS function
3109 ;;; Read the FASL files in OBJECT-FILE-NAMES and produce a Lisp core,
3110 ;;; and/or information about a Lisp core, therefrom.
3112 ;;; input file arguments:
3113 ;;; SYMBOL-TABLE-FILE-NAME names a UNIX-style .nm file *with* *any*
3114 ;;; *tab* *characters* *converted* *to* *spaces*. (We push
3115 ;;; responsibility for removing tabs out to the caller it's
3116 ;;; trivial to remove them using UNIX command line tools like
3117 ;;; sed, whereas it's a headache to do it portably in Lisp because
3118 ;;; #\TAB is not a STANDARD-CHAR.) If this file is not supplied,
3119 ;;; a core file cannot be built (but a C header file can be).
3121 ;;; output files arguments (any of which may be NIL to suppress output):
3122 ;;; CORE-FILE-NAME gets a Lisp core.
3123 ;;; C-HEADER-FILE-NAME gets a C header file, traditionally called
3124 ;;; internals.h, which is used by the C compiler when constructing
3125 ;;; the executable which will load the core.
3126 ;;; MAP-FILE-NAME gets (?) a map file. (dunno about this -- WHN 19990815)
3128 ;;; FIXME: GENESIS doesn't belong in SB!VM. Perhaps in %KERNEL for now,
3129 ;;; perhaps eventually in SB-LD or SB-BOOT.
3130 (defun sb!vm:genesis (&key
3132 symbol-table-file-name
3137 (when (and core-file-name
3138 (not symbol-table-file-name))
3139 (error "can't output a core file without symbol table file input"))
3142 "~&beginning GENESIS, ~A~%"
3144 ;; Note: This output summarizing what we're doing is
3145 ;; somewhat telegraphic in style, not meant to imply that
3146 ;; we're not e.g. also creating a header file when we
3148 (format nil "creating core ~S" core-file-name)
3149 (format nil "creating headers in ~S" c-header-dir-name)))
3150 (let* ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
3152 ;; Read symbol table, if any.
3153 (when symbol-table-file-name
3154 (load-cold-foreign-symbol-table symbol-table-file-name))
3156 ;; Now that we've successfully read our only input file (by
3157 ;; loading the symbol table, if any), it's a good time to ensure
3158 ;; that there'll be someplace for our output files to go when
3160 (flet ((frob (filename)
3162 (ensure-directories-exist filename :verbose t))))
3163 (frob core-file-name)
3164 (frob map-file-name))
3166 ;; (This shouldn't matter in normal use, since GENESIS normally
3167 ;; only runs once in any given Lisp image, but it could reduce
3168 ;; confusion if we ever experiment with running, tweaking, and
3169 ;; rerunning genesis interactively.)
3170 (do-all-symbols (sym)
3171 (remprop sym 'cold-intern-info))
3173 (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0))
3174 (*load-time-value-counter* 0)
3175 (*cold-fdefn-objects* (make-hash-table :test 'equal))
3176 (*cold-symbols* (make-hash-table :test 'equal))
3177 (*cold-package-symbols* nil)
3178 (*read-only* (make-gspace :read-only
3179 read-only-core-space-id
3180 sb!vm:read-only-space-start))
3181 (*static* (make-gspace :static
3182 static-core-space-id
3183 sb!vm:static-space-start))
3184 (*dynamic* (make-gspace :dynamic
3185 dynamic-core-space-id
3186 #!+gencgc sb!vm:dynamic-space-start
3187 #!-gencgc sb!vm:dynamic-0-space-start))
3188 (*nil-descriptor* (make-nil-descriptor))
3189 (*current-reversed-cold-toplevels* *nil-descriptor*)
3190 (*unbound-marker* (make-other-immediate-descriptor
3192 sb!vm:unbound-marker-widetag))
3193 *cold-assembler-fixups*
3194 *cold-assembler-routines*
3195 #!+x86 *load-time-code-fixups*)
3197 ;; Prepare for cold load.
3198 (initialize-non-nil-symbols)
3199 (initialize-layouts)
3200 (initialize-static-fns)
3202 ;; Initialize the *COLD-SYMBOLS* system with the information
3203 ;; from package-data-list.lisp-expr and
3204 ;; common-lisp-exports.lisp-expr.
3206 ;; Why do things this way? Historically, the *COLD-SYMBOLS*
3207 ;; machinery was designed and implemented in CMU CL long before
3208 ;; I (WHN) ever heard of CMU CL. It dumped symbols and packages
3209 ;; iff they were used in the cold image. When I added the
3210 ;; package-data-list.lisp-expr mechanism, the idea was to
3211 ;; centralize all information about packages and exports. Thus,
3212 ;; it was the natural place for information even about packages
3213 ;; (such as SB!PCL and SB!WALKER) which aren't used much until
3214 ;; after cold load. This didn't quite match the CMU CL approach
3215 ;; of filling *COLD-SYMBOLS* with symbols which appear in the
3216 ;; cold image and then dumping only those symbols. By explicitly
3217 ;; putting all the symbols from package-data-list.lisp-expr and
3218 ;; from common-lisp-exports.lisp-expr into *COLD-SYMBOLS* here,
3219 ;; we feed our centralized symbol information into the old CMU
3220 ;; CL code without having to change the old CMU CL code too
3221 ;; much. (And the old CMU CL code is still useful for making
3222 ;; sure that the appropriate keywords and internal symbols end
3223 ;; up interned in the target Lisp, which is good, e.g. in order
3224 ;; to make &KEY arguments work right and in order to make
3225 ;; BACKTRACEs into target Lisp system code be legible.)
3226 (dolist (exported-name
3227 (sb-cold:read-from-file "common-lisp-exports.lisp-expr"))
3228 (cold-intern (intern exported-name *cl-package*)))
3229 (dolist (pd (sb-cold:read-from-file "package-data-list.lisp-expr"))
3230 (declare (type sb-cold:package-data pd))
3231 (let ((package (find-package (sb-cold:package-data-name pd))))
3232 (labels (;; Call FN on every node of the TREE.
3233 (mapc-on-tree (fn tree)
3234 (declare (type function fn))
3236 (cons (mapc-on-tree fn (car tree))
3237 (mapc-on-tree fn (cdr tree)))
3238 (t (funcall fn tree)
3240 ;; Make sure that information about the association
3241 ;; between PACKAGE and the symbol named NAME gets
3242 ;; recorded in the cold-intern system or (as a
3243 ;; convenience when dealing with the tree structure
3244 ;; allowed in the PACKAGE-DATA-EXPORTS slot) do
3245 ;; nothing if NAME is NIL.
3248 (cold-intern (intern name package) package))))
3249 (mapc-on-tree #'chill (sb-cold:package-data-export pd))
3250 (mapc #'chill (sb-cold:package-data-reexport pd))
3251 (dolist (sublist (sb-cold:package-data-import-from pd))
3252 (destructuring-bind (package-name &rest symbol-names) sublist
3253 (declare (ignore package-name))
3254 (mapc #'chill symbol-names))))))
3257 (dolist (file-name object-file-names)
3258 (write-line (namestring file-name))
3259 (cold-load file-name))
3261 ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
3262 (resolve-assembler-fixups)
3263 #!+x86 (output-load-time-code-fixups)
3264 (linkage-info-to-core)
3266 (/show "back from FINISH-SYMBOLS")
3267 (finalize-load-time-value-noise)
3269 ;; Tell the target Lisp how much stuff we've allocated.
3270 (cold-set 'sb!vm:*read-only-space-free-pointer*
3271 (allocate-cold-descriptor *read-only*
3273 sb!vm:even-fixnum-lowtag))
3274 (cold-set 'sb!vm:*static-space-free-pointer*
3275 (allocate-cold-descriptor *static*
3277 sb!vm:even-fixnum-lowtag))
3278 (cold-set 'sb!vm:*initial-dynamic-space-free-pointer*
3279 (allocate-cold-descriptor *dynamic*
3281 sb!vm:even-fixnum-lowtag))
3282 (/show "done setting free pointers")
3284 ;; Write results to files.
3286 ;; FIXME: I dislike this approach of redefining
3287 ;; *STANDARD-OUTPUT* instead of putting the new stream in a
3288 ;; lexical variable, and it's annoying to have WRITE-MAP (to
3289 ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE
3290 ;; (to a stream explicitly passed as an argument).
3291 (macrolet ((out-to (name &body body)
3292 `(let ((fn (format nil "~A/~A.h" c-header-dir-name ,name)))
3293 (ensure-directories-exist fn)
3294 (with-open-file (*standard-output* fn
3295 :if-exists :supersede :direction :output)
3297 (let ((n (substitute #\_ #\- (string-upcase ,name))))
3300 "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"
3304 "#endif /* SBCL_GENESIS_~A */~%"
3305 (string-upcase ,name))))))
3307 (with-open-file (*standard-output* map-file-name
3309 :if-exists :supersede)
3311 (out-to "config" (write-config-h))
3312 (out-to "constants" (write-constants-h))
3313 (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
3316 (sb!vm:primitive-object-name obj))))))
3317 (dolist (obj structs)
3319 (string-downcase (string (sb!vm:primitive-object-name obj)))
3320 (write-primitive-object obj)))
3321 (out-to "primitive-objects"
3322 (dolist (obj structs)
3323 (format t "~&#include \"~A.h\"~%"
3325 (string (sb!vm:primitive-object-name obj)))))))
3326 (out-to "static-symbols" (write-static-symbols))
3328 (when core-file-name
3329 (write-initial-core-file core-file-name))))))