1 ;;;; "cold" core image builder: This is how we create a target Lisp
2 ;;;; system from scratch, by converting from fasl files to an image
3 ;;;; file in the cross-compilation host, without the help of the
4 ;;;; target Lisp system.
6 ;;;; As explained by Rob MacLachlan on the CMU CL mailing list Wed, 06
7 ;;;; Jan 1999 11:05:02 -0500, this cold load generator more or less
8 ;;;; fakes up static function linking. I.e. it makes sure that all the
9 ;;;; DEFUN-defined functions in the fasl files it reads are bound to the
10 ;;;; corresponding symbols before execution starts. It doesn't do
11 ;;;; anything to initialize variable values; instead it just arranges
12 ;;;; for !COLD-INIT to be called at cold load time. !COLD-INIT is
13 ;;;; responsible for explicitly initializing anything which has to be
14 ;;;; initialized early before it transfers control to the ordinary
17 ;;;; (In CMU CL, and in SBCL as of 0.6.9 anyway, functions not defined
18 ;;;; by DEFUN aren't set up specially by GENESIS. In particular,
19 ;;;; structure slot accessors are not set up. Slot accessors are
20 ;;;; available at cold init time because they're usually compiled
21 ;;;; inline. They're not available as out-of-line functions until the
22 ;;;; toplevel forms installing them have run.)
24 ;;;; This software is part of the SBCL system. See the README file for
25 ;;;; more information.
27 ;;;; This software is derived from the CMU CL system, which was
28 ;;;; written at Carnegie Mellon University and released into the
29 ;;;; public domain. The software is in the public domain and is
30 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
31 ;;;; files for more information.
33 (in-package "SB!FASL")
35 ;;; a magic number used to identify our core files
36 (defconstant core-magic
37 (logior (ash (sb!xc
:char-code
#\S
) 24)
38 (ash (sb!xc
:char-code
#\B
) 16)
39 (ash (sb!xc
:char-code
#\C
) 8)
40 (sb!xc
:char-code
#\L
)))
42 (defun round-up (number size
)
44 "Round NUMBER up to be an integral multiple of SIZE."
45 (* size
(ceiling number size
)))
47 ;;;; implementing the concept of "vector" in (almost) portable
50 ;;;; "If you only need to do such simple things, it doesn't really
51 ;;;; matter which language you use." -- _ANSI Common Lisp_, p. 1, Paul
52 ;;;; Graham (evidently not considering the abstraction "vector" to be
53 ;;;; such a simple thing:-)
55 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
56 (defconstant +smallvec-length
+
59 ;;; an element of a BIGVEC -- a vector small enough that we have
60 ;;; a good chance of it being portable to other Common Lisps
62 `(simple-array (unsigned-byte 8) (,+smallvec-length
+)))
64 (defun make-smallvec ()
65 (make-array +smallvec-length
+ :element-type
'(unsigned-byte 8)
68 ;;; a big vector, implemented as a vector of SMALLVECs
70 ;;; KLUDGE: This implementation seems portable enough for our
71 ;;; purposes, since realistically every modern implementation is
72 ;;; likely to support vectors of at least 2^16 elements. But if you're
73 ;;; masochistic enough to read this far into the contortions imposed
74 ;;; on us by ANSI and the Lisp community, for daring to use the
75 ;;; abstraction of a large linearly addressable memory space, which is
76 ;;; after all only directly supported by the underlying hardware of at
77 ;;; least 99% of the general-purpose computers in use today, then you
78 ;;; may be titillated to hear that in fact this code isn't really
79 ;;; portable, because as of sbcl-0.7.4 we need somewhat more than
80 ;;; 16Mbytes to represent a core, and ANSI only guarantees that
81 ;;; ARRAY-DIMENSION-LIMIT is not less than 1024. -- WHN 2002-06-13
83 (outer-vector (vector (make-smallvec)) :type
(vector smallvec
)))
85 ;;; analogous to SVREF, but into a BIGVEC
86 (defun bvref (bigvec index
)
87 (multiple-value-bind (outer-index inner-index
)
88 (floor index
+smallvec-length
+)
90 (svref (bigvec-outer-vector bigvec
) outer-index
))
92 (defun (setf bvref
) (new-value bigvec index
)
93 (multiple-value-bind (outer-index inner-index
)
94 (floor index
+smallvec-length
+)
95 (setf (aref (the smallvec
96 (svref (bigvec-outer-vector bigvec
) outer-index
))
100 ;;; analogous to LENGTH, but for a BIGVEC
102 ;;; the length of BIGVEC, measured in the number of BVREFable bytes it
104 (defun bvlength (bigvec)
105 (* (length (bigvec-outer-vector bigvec
))
108 ;;; analogous to WRITE-SEQUENCE, but for a BIGVEC
109 (defun write-bigvec-as-sequence (bigvec stream
&key
(start 0) end pad-with-zeros
)
110 (let* ((bvlength (bvlength bigvec
))
111 (data-length (min (or end bvlength
) bvlength
)))
112 (loop for i of-type index from start below data-length do
113 (write-byte (bvref bigvec i
)
115 (when (and pad-with-zeros
(< bvlength data-length
))
116 (loop repeat
(- data-length bvlength
) do
(write-byte 0 stream
)))))
118 ;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC
119 (defun read-bigvec-as-sequence-or-die (bigvec stream
&key
(start 0) end
)
120 (loop for i of-type index from start below
(or end
(bvlength bigvec
)) do
121 (setf (bvref bigvec i
)
122 (read-byte stream
))))
124 ;;; Grow BIGVEC (exponentially, so that large increases in size have
125 ;;; asymptotic logarithmic cost per byte).
126 (defun expand-bigvec (bigvec)
127 (let* ((old-outer-vector (bigvec-outer-vector bigvec
))
128 (length-old-outer-vector (length old-outer-vector
))
129 (new-outer-vector (make-array (* 2 length-old-outer-vector
))))
130 (dotimes (i length-old-outer-vector
)
131 (setf (svref new-outer-vector i
)
132 (svref old-outer-vector i
)))
133 (loop for i from length-old-outer-vector below
(length new-outer-vector
) do
134 (setf (svref new-outer-vector i
)
136 (setf (bigvec-outer-vector bigvec
)
140 ;;;; looking up bytes and multi-byte values in a BIGVEC (considering
141 ;;;; it as an image of machine memory on the cross-compilation target)
143 ;;; BVREF-32 and friends. These are like SAP-REF-n, except that
144 ;;; instead of a SAP we use a BIGVEC.
145 (macrolet ((make-bvref-n
147 (let* ((name (intern (format nil
"BVREF-~A" n
)))
148 (number-octets (/ n
8))
150 (loop for i from
0 to
(1- number-octets
)
151 collect
`(ash (bvref bigvec
(+ byte-index
,i
))
154 (loop for i from
0 to
(1- number-octets
)
155 collect
`(ash (bvref bigvec
157 ,(- number-octets
1 i
)))
160 (loop for i from
0 to
(1- number-octets
)
162 `((bvref bigvec
(+ byte-index
,i
))
163 (ldb (byte 8 ,(* i
8)) new-value
))))
165 (loop for i from
0 to
(1- number-octets
)
167 `((bvref bigvec
(+ byte-index
,i
))
168 (ldb (byte 8 ,(- n
8 (* i
8))) new-value
)))))
170 (defun ,name
(bigvec byte-index
)
171 (logior ,@(ecase sb
!c
:*backend-byte-order
*
172 (:little-endian ash-list-le
)
173 (:big-endian ash-list-be
))))
174 (defun (setf ,name
) (new-value bigvec byte-index
)
175 (setf ,@(ecase sb
!c
:*backend-byte-order
*
176 (:little-endian setf-list-le
)
177 (:big-endian setf-list-be
))))))))
183 ;; lispobj-sized word, whatever that may be
184 ;; hopefully nobody ever wants a 128-bit SBCL...
185 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-word-bits
) '(and) '(or))
187 (defun bvref-word (bytes index
)
188 (bvref-64 bytes index
))
189 (defun (setf bvref-word
) (new-val bytes index
)
190 (setf (bvref-64 bytes index
) new-val
)))
192 #!+#.
(cl:if
(cl:= 32 sb
!vm
:n-word-bits
) '(and) '(or))
194 (defun bvref-word (bytes index
)
195 (bvref-32 bytes index
))
196 (defun (setf bvref-word
) (new-val bytes index
)
197 (setf (bvref-32 bytes index
) new-val
)))
200 ;;;; representation of spaces in the core
202 ;;; If there is more than one dynamic space in memory (i.e., if a
203 ;;; copying GC is in use), then only the active dynamic space gets
206 (defconstant dynamic-core-space-id
1)
209 (defconstant static-core-space-id
2)
212 (defconstant read-only-core-space-id
3)
214 (defconstant max-core-space-id
3)
215 (defconstant deflated-core-space-id-flag
4)
217 (defconstant descriptor-low-bits
16
218 "the number of bits in the low half of the descriptor")
219 (defconstant target-space-alignment
(ash 1 descriptor-low-bits
)
220 "the alignment requirement for spaces in the target.
221 Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)")
223 ;;; a GENESIS-time representation of a memory space (e.g. read-only
224 ;;; space, dynamic space, or static space)
225 (defstruct (gspace (:constructor %make-gspace
)
227 ;; name and identifier for this GSPACE
228 (name (missing-arg) :type symbol
:read-only t
)
229 (identifier (missing-arg) :type fixnum
:read-only t
)
230 ;; the word address where the data will be loaded
231 (word-address (missing-arg) :type unsigned-byte
:read-only t
)
232 ;; the data themselves. (Note that in CMU CL this was a pair of
233 ;; fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
234 ;; (And then in SBCL this was a VECTOR, but turned out to be
235 ;; unportable too, since ANSI doesn't think that arrays longer than
236 ;; 1024 (!) should needed by portable CL code...)
237 (bytes (make-bigvec) :read-only t
)
238 ;; the index of the next unwritten word (i.e. chunk of
239 ;; SB!VM:N-WORD-BYTES bytes) in BYTES, or equivalently the number of
240 ;; words actually written in BYTES. In order to convert to an actual
241 ;; index into BYTES, thus must be multiplied by SB!VM:N-WORD-BYTES.
244 (defun gspace-byte-address (gspace)
245 (ash (gspace-word-address gspace
) sb
!vm
:word-shift
))
247 (def!method print-object
((gspace gspace
) stream
)
248 (print-unreadable-object (gspace stream
:type t
)
249 (format stream
"~S" (gspace-name gspace
))))
251 (defun make-gspace (name identifier byte-address
)
252 (unless (zerop (rem byte-address target-space-alignment
))
253 (error "The byte address #X~X is not aligned on a #X~X-byte boundary."
255 target-space-alignment
))
256 (%make-gspace
:name name
257 :identifier identifier
258 :word-address
(ash byte-address
(- sb
!vm
:word-shift
))))
260 ;;;; representation of descriptors
262 (defun is-fixnum-lowtag (lowtag)
263 (zerop (logand lowtag sb
!vm
:fixnum-tag-mask
)))
265 (defun is-other-immediate-lowtag (lowtag)
266 ;; The other-immediate lowtags are similar to the fixnum lowtags, in
267 ;; that they have an "effective length" that is shorter than is used
268 ;; for the pointer lowtags. Unlike the fixnum lowtags, however, the
269 ;; other-immediate lowtags are always effectively two bits wide.
270 (= (logand lowtag
3) sb
!vm
:other-immediate-0-lowtag
))
272 (defstruct (descriptor
273 (:constructor make-descriptor
274 (high low
&optional gspace word-offset
))
276 ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
277 (gspace nil
:type
(or gspace
(eql :load-time-value
) null
))
278 ;; the offset in words from the start of GSPACE, or NIL if not set yet
279 (word-offset nil
:type
(or sb
!vm
:word null
))
280 ;; the high and low halves of the descriptor
282 ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL
283 ;; old-rt compiler, this split dates back from a very early version
284 ;; of genesis where 32-bit integers were represented as conses of
285 ;; two 16-bit integers. In any system with nice (UNSIGNED-BYTE 32)
286 ;; structure slots, like CMU CL >= 17 or any version of SBCL, there
287 ;; seems to be no reason to persist in this. -- WHN 19990917
290 (def!method print-object
((des descriptor
) stream
)
291 (let ((lowtag (descriptor-lowtag des
)))
292 (print-unreadable-object (des stream
:type t
)
293 (cond ((is-fixnum-lowtag lowtag
)
294 (let ((unsigned (logior (ash (descriptor-high des
)
295 (1+ (- descriptor-low-bits
296 sb
!vm
:n-lowtag-bits
)))
297 (ash (descriptor-low des
)
298 (- 1 sb
!vm
:n-lowtag-bits
)))))
301 (if (> unsigned
#x1FFFFFFF
)
302 (- unsigned
#x40000000
)
304 ((is-other-immediate-lowtag lowtag
)
306 "for other immediate: #X~X, type #b~8,'0B"
307 (ash (descriptor-bits des
) (- sb
!vm
:n-widetag-bits
))
308 (logand (descriptor-low des
) sb
!vm
:widetag-mask
)))
311 "for pointer: #X~X, lowtag #b~3,'0B, ~A"
312 (logior (ash (descriptor-high des
) descriptor-low-bits
)
313 (logandc2 (descriptor-low des
) sb
!vm
:lowtag-mask
))
315 (let ((gspace (descriptor-gspace des
)))
320 ;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The
321 ;;; free word index is boosted as necessary, and if additional memory
322 ;;; is needed, we grow the GSPACE. The descriptor returned is a
323 ;;; pointer of type LOWTAG.
324 (defun allocate-cold-descriptor (gspace length lowtag
)
325 (let* ((bytes (round-up length
(ash 1 sb
!vm
:n-lowtag-bits
)))
326 (old-free-word-index (gspace-free-word-index gspace
))
327 (new-free-word-index (+ old-free-word-index
328 (ash bytes
(- sb
!vm
:word-shift
)))))
329 ;; Grow GSPACE as necessary until it's big enough to handle
330 ;; NEW-FREE-WORD-INDEX.
332 ((>= (bvlength (gspace-bytes gspace
))
333 (* new-free-word-index sb
!vm
:n-word-bytes
)))
334 (expand-bigvec (gspace-bytes gspace
)))
335 ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it.
336 (setf (gspace-free-word-index gspace
) new-free-word-index
)
337 (let ((ptr (+ (gspace-word-address gspace
) old-free-word-index
)))
338 (make-descriptor (ash ptr
(- sb
!vm
:word-shift descriptor-low-bits
))
339 (logior (ash (logand ptr
341 (- descriptor-low-bits
346 old-free-word-index
))))
348 (defun descriptor-lowtag (des)
350 "the lowtag bits for DES"
351 (logand (descriptor-low des
) sb
!vm
:lowtag-mask
))
353 (defun descriptor-bits (des)
354 (logior (ash (descriptor-high des
) descriptor-low-bits
)
355 (descriptor-low des
)))
357 (defun descriptor-fixnum (des)
358 (let ((bits (descriptor-bits des
)))
359 (if (logbitp (1- sb
!vm
:n-word-bits
) bits
)
360 ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to
361 ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS),
362 ;; and although that doesn't make sense for me, or work for me,
363 ;; it's hard to see how it could have been wrong, since CMU CL
364 ;; genesis worked. It would be nice to understand how this came
365 ;; to be.. -- WHN 19990901
366 (logior (ash bits
(- sb
!vm
:n-fixnum-tag-bits
))
367 (ash -
1 (1+ sb
!vm
:n-positive-fixnum-bits
)))
368 (ash bits
(- sb
!vm
:n-fixnum-tag-bits
)))))
370 (defun descriptor-word-sized-integer (des)
371 ;; Extract an (unsigned-byte 32), from either its fixnum or bignum
373 (let ((lowtag (descriptor-lowtag des
)))
374 (if (is-fixnum-lowtag lowtag
)
375 (make-random-descriptor (descriptor-fixnum des
))
376 (read-wordindexed des
1))))
379 (defun descriptor-bytes (des)
380 (gspace-bytes (descriptor-intuit-gspace des
)))
381 (defun descriptor-byte-offset (des)
382 (ash (descriptor-word-offset des
) sb
!vm
:word-shift
))
384 ;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise,
385 ;;; figure out a GSPACE which corresponds to DES, set it into
386 ;;; (DESCRIPTOR-GSPACE DES), set a consistent value into
387 ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
388 (declaim (ftype (function (descriptor) gspace
) descriptor-intuit-gspace
))
389 (defun descriptor-intuit-gspace (des)
390 (or (descriptor-gspace des
)
392 ;; gspace wasn't set, now we have to search for it.
393 (let ((lowtag (descriptor-lowtag des
))
394 (high (descriptor-high des
))
395 (low (descriptor-low des
)))
397 ;; Non-pointer objects don't have a gspace.
398 (unless (or (eql lowtag sb
!vm
:fun-pointer-lowtag
)
399 (eql lowtag sb
!vm
:instance-pointer-lowtag
)
400 (eql lowtag sb
!vm
:list-pointer-lowtag
)
401 (eql lowtag sb
!vm
:other-pointer-lowtag
))
402 (error "don't even know how to look for a GSPACE for ~S" des
))
404 (dolist (gspace (list *dynamic
* *static
* *read-only
*)
405 (error "couldn't find a GSPACE for ~S" des
))
406 ;; Bounds-check the descriptor against the allocated area
407 ;; within each gspace.
409 ;; Most of the faffing around in here involving ash and
410 ;; various computed shift counts is due to the high/low
411 ;; split representation of the descriptor bits and an
412 ;; apparent disinclination to create intermediate values
413 ;; larger than a target fixnum.
415 ;; This code relies on the fact that GSPACEs are aligned
416 ;; such that the descriptor-low-bits low bits are zero.
417 (when (and (>= high
(ash (gspace-word-address gspace
)
418 (- sb
!vm
:word-shift descriptor-low-bits
)))
419 (<= high
(ash (+ (gspace-word-address gspace
)
420 (gspace-free-word-index gspace
))
421 (- sb
!vm
:word-shift descriptor-low-bits
))))
422 ;; Update the descriptor with the correct gspace and the
423 ;; offset within the gspace and return the gspace.
424 (setf (descriptor-gspace des
) gspace
)
425 (setf (descriptor-word-offset des
)
426 (+ (ash (- high
(ash (gspace-word-address gspace
)
428 descriptor-low-bits
)))
429 (- descriptor-low-bits sb
!vm
:word-shift
))
430 (ash (logandc2 low sb
!vm
:lowtag-mask
)
431 (- sb
!vm
:word-shift
))))
434 (defun make-random-descriptor (value)
435 (make-descriptor (logand (ash value
(- descriptor-low-bits
))
438 descriptor-low-bits
))))
439 (logand value
(1- (ash 1 descriptor-low-bits
)))))
441 (defun make-fixnum-descriptor (num)
442 (when (>= (integer-length num
)
443 (- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
))
444 (error "~W is too big for a fixnum." num
))
445 (make-random-descriptor (ash num sb
!vm
:n-fixnum-tag-bits
)))
447 (defun make-other-immediate-descriptor (data type
)
448 (make-descriptor (ash data
(- sb
!vm
:n-widetag-bits descriptor-low-bits
))
449 (logior (logand (ash data
(- descriptor-low-bits
450 sb
!vm
:n-widetag-bits
))
451 (1- (ash 1 descriptor-low-bits
)))
454 (defun make-character-descriptor (data)
455 (make-other-immediate-descriptor data sb
!vm
:character-widetag
))
457 (defun descriptor-beyond (des offset type
)
458 (let* ((low (logior (+ (logandc2 (descriptor-low des
) sb
!vm
:lowtag-mask
)
461 (high (+ (descriptor-high des
)
462 (ash low
(- descriptor-low-bits
)))))
463 (make-descriptor high
(logand low
(1- (ash 1 descriptor-low-bits
))))))
465 ;;;; miscellaneous variables and other noise
467 ;;; a numeric value to be returned for undefined foreign symbols, or NIL if
468 ;;; undefined foreign symbols are to be treated as an error.
469 ;;; (In the first pass of GENESIS, needed to create a header file before
470 ;;; the C runtime can be built, various foreign symbols will necessarily
471 ;;; be undefined, but we don't need actual values for them anyway, and
472 ;;; we can just use 0 or some other placeholder. In the second pass of
473 ;;; GENESIS, all foreign symbols should be defined, so any undefined
474 ;;; foreign symbol is a problem.)
476 ;;; KLUDGE: It would probably be cleaner to rewrite GENESIS so that it
477 ;;; never tries to look up foreign symbols in the first place unless
478 ;;; it's actually creating a core file (as in the second pass) instead
479 ;;; of using this hack to allow it to go through the motions without
480 ;;; causing an error. -- WHN 20000825
481 (defvar *foreign-symbol-placeholder-value
*)
483 ;;; a handle on the trap object
484 (defvar *unbound-marker
*)
485 ;; was: (make-other-immediate-descriptor 0 sb!vm:unbound-marker-widetag)
487 ;;; a handle on the NIL object
488 (defvar *nil-descriptor
*)
490 ;;; the head of a list of TOPLEVEL-THINGs describing stuff to be done
491 ;;; when the target Lisp starts up
493 ;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or
494 ;;; loadtime value, represented by (CONS KEYWORD ..). The FILENAME
495 ;;; tells which fasl file each list element came from, for debugging
497 (defvar *current-reversed-cold-toplevels
*)
499 ;;; the head of a list of DEBUG-SOURCEs which need to be patched when
500 ;;; the cold core starts up
501 (defvar *current-debug-sources
*)
503 ;;; foreign symbol references
504 (defparameter *cold-foreign-undefined-symbols
* nil
)
506 ;;; the name of the object file currently being cold loaded (as a string, not a
507 ;;; pathname), or NIL if we're not currently cold loading any object file
508 (defvar *cold-load-filename
* nil
)
509 (declaim (type (or string null
) *cold-load-filename
*))
511 ;;;; miscellaneous stuff to read and write the core memory
513 ;;; FIXME: should be DEFINE-MODIFY-MACRO
514 (defmacro cold-push
(thing list
)
516 "Push THING onto the given cold-load LIST."
517 `(setq ,list
(cold-cons ,thing
,list
)))
519 (declaim (ftype (function (descriptor sb
!vm
:word
) descriptor
) read-wordindexed
))
520 (defun read-wordindexed (address index
)
522 "Return the value which is displaced by INDEX words from ADDRESS."
523 (let* ((gspace (descriptor-intuit-gspace address
))
524 (bytes (gspace-bytes gspace
))
525 (byte-index (ash (+ index
(descriptor-word-offset address
))
527 (value (bvref-word bytes byte-index
)))
528 (make-random-descriptor value
)))
530 (declaim (ftype (function (descriptor) descriptor
) read-memory
))
531 (defun read-memory (address)
533 "Return the value at ADDRESS."
534 (read-wordindexed address
0))
536 ;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS
537 ;;; value, instead of the object-and-offset we use here.)
538 (declaim (ftype (function (descriptor sb
!vm
:word descriptor
) (values))
539 note-load-time-value-reference
))
540 (defun note-load-time-value-reference (address offset marker
)
541 (cold-push (cold-cons
542 (cold-intern :load-time-value-fixup
)
544 (cold-cons (number-to-core offset
)
546 (number-to-core (descriptor-word-offset marker
))
548 *current-reversed-cold-toplevels
*)
551 (declaim (ftype (function (descriptor sb
!vm
:word
(or symbol descriptor
))) write-wordindexed
))
552 (defun write-wordindexed (address index value
)
554 "Write VALUE displaced INDEX words from ADDRESS."
555 ;; If we're passed a symbol as a value then it needs to be interned.
556 (let ((value (cond ((symbolp value
) (cold-intern value
))
558 (if (eql (descriptor-gspace value
) :load-time-value
)
559 (note-load-time-value-reference address
560 (- (ash index sb
!vm
:word-shift
)
561 (logand (descriptor-bits address
)
564 (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address
)))
565 (byte-index (ash (+ index
(descriptor-word-offset address
))
567 (setf (bvref-word bytes byte-index
) (descriptor-bits value
))))))
569 (declaim (ftype (function (descriptor (or symbol descriptor
))) write-memory
))
570 (defun write-memory (address value
)
572 "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
573 (write-wordindexed address
0 value
))
575 ;;;; allocating images of primitive objects in the cold core
577 ;;; There are three kinds of blocks of memory in the type system:
578 ;;; * Boxed objects (cons cells, structures, etc): These objects have no
579 ;;; header as all slots are descriptors.
580 ;;; * Unboxed objects (bignums): There is a single header word that contains
582 ;;; * Vector objects: There is a header word with the type, then a word for
583 ;;; the length, then the data.
584 (defun allocate-boxed-object (gspace length lowtag
)
586 "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
588 (allocate-cold-descriptor gspace
(ash length sb
!vm
:word-shift
) lowtag
))
589 (defun allocate-unboxed-object (gspace element-bits length type
)
591 "Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and
592 return an ``other-pointer'' descriptor to them. Initialize the header word
593 with the resultant length and TYPE."
594 (let* ((bytes (/ (* element-bits length
) sb
!vm
:n-byte-bits
))
595 (des (allocate-cold-descriptor gspace
596 (+ bytes sb
!vm
:n-word-bytes
)
597 sb
!vm
:other-pointer-lowtag
)))
599 (make-other-immediate-descriptor (ash bytes
600 (- sb
!vm
:word-shift
))
603 (defun allocate-vector-object (gspace element-bits length type
)
605 "Allocate LENGTH units of ELEMENT-BITS size plus a header plus a length slot in
606 GSPACE and return an ``other-pointer'' descriptor to them. Initialize the
607 header word with TYPE and the length slot with LENGTH."
608 ;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using
609 ;; #'/ instead of #'CEILING, which seems wrong.
610 (let* ((bytes (/ (* element-bits length
) sb
!vm
:n-byte-bits
))
611 (des (allocate-cold-descriptor gspace
612 (+ bytes
(* 2 sb
!vm
:n-word-bytes
))
613 sb
!vm
:other-pointer-lowtag
)))
614 (write-memory des
(make-other-immediate-descriptor 0 type
))
615 (write-wordindexed des
616 sb
!vm
:vector-length-slot
617 (make-fixnum-descriptor length
))
620 ;; Make a structure and set the header word and layout.
621 ;; LAYOUT-LENGTH is as returned by the like-named function.
622 (defun allocate-structure-object (gspace layout-length layout
)
623 ;; The math in here is best illustrated by two examples:
624 ;; even: size 4 => request to allocate 5 => rounds up to 6, logior => 5
625 ;; odd : size 5 => request to allocate 6 => no rounding up, logior => 5
626 ;; In each case, the length of the memory block is even.
627 ;; ALLOCATE-BOXED-OBJECT performs the rounding. It must be supplied
628 ;; the number of words minimally needed, counting the header itself.
629 ;; The number written into the header (%INSTANCE-LENGTH) is always odd.
630 (let ((des (allocate-boxed-object gspace
632 sb
!vm
:instance-pointer-lowtag
)))
634 (make-other-immediate-descriptor
635 (logior layout-length
1)
636 sb
!vm
:instance-header-widetag
))
637 (write-wordindexed des sb
!vm
:instance-slots-offset layout
)
640 ;;;; copying simple objects into the cold core
642 (defun base-string-to-core (string &optional
(gspace *dynamic
*))
644 "Copy STRING (which must only contain STANDARD-CHARs) into the cold
645 core and return a descriptor to it."
646 ;; (Remember that the system convention for storage of strings leaves an
647 ;; extra null byte at the end to aid in call-out to C.)
648 (let* ((length (length string
))
649 (des (allocate-vector-object gspace
652 sb
!vm
:simple-base-string-widetag
))
653 (bytes (gspace-bytes gspace
))
654 (offset (+ (* sb
!vm
:vector-data-offset sb
!vm
:n-word-bytes
)
655 (descriptor-byte-offset des
))))
656 (write-wordindexed des
657 sb
!vm
:vector-length-slot
658 (make-fixnum-descriptor length
))
660 (setf (bvref bytes
(+ offset i
))
661 (sb!xc
:char-code
(aref string i
))))
662 (setf (bvref bytes
(+ offset length
))
663 0) ; null string-termination character for C
666 (defun bignum-to-core (n)
668 "Copy a bignum to the cold core."
669 (let* ((words (ceiling (1+ (integer-length n
)) sb
!vm
:n-word-bits
))
670 (handle (allocate-unboxed-object *dynamic
*
673 sb
!vm
:bignum-widetag
)))
674 (declare (fixnum words
))
675 (do ((index 1 (1+ index
))
676 (remainder n
(ash remainder
(- sb
!vm
:n-word-bits
))))
678 (unless (zerop (integer-length remainder
))
679 ;; FIXME: Shouldn't this be a fatal error?
680 (warn "~W words of ~W were written, but ~W bits were left over."
682 (let ((word (ldb (byte sb
!vm
:n-word-bits
0) remainder
)))
683 (write-wordindexed handle index
684 (make-descriptor (ash word
(- descriptor-low-bits
))
685 (ldb (byte descriptor-low-bits
0)
689 (defun number-pair-to-core (first second type
)
691 "Makes a number pair of TYPE (ratio or complex) and fills it in."
692 (let ((des (allocate-unboxed-object *dynamic
* sb
!vm
:n-word-bits
2 type
)))
693 (write-wordindexed des
1 first
)
694 (write-wordindexed des
2 second
)
697 (defun write-double-float-bits (address index x
)
698 (let ((hi (double-float-high-bits x
))
699 (lo (double-float-low-bits x
)))
700 (ecase sb
!vm
::n-word-bits
702 (let ((high-bits (make-random-descriptor hi
))
703 (low-bits (make-random-descriptor lo
)))
704 (ecase sb
!c
:*backend-byte-order
*
706 (write-wordindexed address index low-bits
)
707 (write-wordindexed address
(1+ index
) high-bits
))
709 (write-wordindexed address index high-bits
)
710 (write-wordindexed address
(1+ index
) low-bits
)))))
712 (let ((bits (make-random-descriptor
713 (ecase sb
!c
:*backend-byte-order
*
714 (:little-endian
(logior lo
(ash hi
32)))
716 #+nil
(:big-endian
(logior (logand hi
#xffffffff
)
718 (write-wordindexed address index bits
))))
721 (defun float-to-core (x)
724 ;; 64-bit platforms have immediate single-floats.
725 #!+#.
(cl:if
(cl:= sb
!vm
:n-word-bits
64) '(and) '(or))
726 (make-random-descriptor (logior (ash (single-float-bits x
) 32)
727 sb
!vm
::single-float-widetag
))
728 #!-
#.
(cl:if
(cl:= sb
!vm
:n-word-bits
64) '(and) '(or))
729 (let ((des (allocate-unboxed-object *dynamic
*
731 (1- sb
!vm
:single-float-size
)
732 sb
!vm
:single-float-widetag
)))
733 (write-wordindexed des
734 sb
!vm
:single-float-value-slot
735 (make-random-descriptor (single-float-bits x
)))
738 (let ((des (allocate-unboxed-object *dynamic
*
740 (1- sb
!vm
:double-float-size
)
741 sb
!vm
:double-float-widetag
)))
742 (write-double-float-bits des sb
!vm
:double-float-value-slot x
)))))
744 (defun complex-single-float-to-core (num)
745 (declare (type (complex single-float
) num
))
746 (let ((des (allocate-unboxed-object *dynamic
* sb
!vm
:n-word-bits
747 (1- sb
!vm
:complex-single-float-size
)
748 sb
!vm
:complex-single-float-widetag
)))
751 (write-wordindexed des sb
!vm
:complex-single-float-real-slot
752 (make-random-descriptor (single-float-bits (realpart num
))))
753 (write-wordindexed des sb
!vm
:complex-single-float-imag-slot
754 (make-random-descriptor (single-float-bits (imagpart num
)))))
756 (write-wordindexed des sb
!vm
:complex-single-float-data-slot
757 (make-random-descriptor
758 (logior (ldb (byte 32 0) (single-float-bits (realpart num
)))
759 (ash (single-float-bits (imagpart num
)) 32))))
762 (defun complex-double-float-to-core (num)
763 (declare (type (complex double-float
) num
))
764 (let ((des (allocate-unboxed-object *dynamic
* sb
!vm
:n-word-bits
765 (1- sb
!vm
:complex-double-float-size
)
766 sb
!vm
:complex-double-float-widetag
)))
767 (write-double-float-bits des sb
!vm
:complex-double-float-real-slot
769 (write-double-float-bits des sb
!vm
:complex-double-float-imag-slot
772 ;;; Copy the given number to the core.
773 (defun number-to-core (number)
775 (integer (if (< (integer-length number
)
776 (- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
))
777 (make-fixnum-descriptor number
)
778 (bignum-to-core number
)))
779 (ratio (number-pair-to-core (number-to-core (numerator number
))
780 (number-to-core (denominator number
))
781 sb
!vm
:ratio-widetag
))
782 ((complex single-float
) (complex-single-float-to-core number
))
783 ((complex double-float
) (complex-double-float-to-core number
))
785 ((complex long-float
)
786 (error "~S isn't a cold-loadable number at all!" number
))
787 (complex (number-pair-to-core (number-to-core (realpart number
))
788 (number-to-core (imagpart number
))
789 sb
!vm
:complex-widetag
))
790 (float (float-to-core number
))
791 (t (error "~S isn't a cold-loadable number at all!" number
))))
793 (declaim (ftype (function (sb!vm
:word
) descriptor
) sap-int-to-core
))
794 (defun sap-int-to-core (sap-int)
795 (let ((des (allocate-unboxed-object *dynamic
*
799 (write-wordindexed des
800 sb
!vm
:sap-pointer-slot
801 (make-random-descriptor sap-int
))
804 ;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
805 (defun cold-cons (car cdr
&optional
(gspace *dynamic
*))
806 (let ((dest (allocate-boxed-object gspace
2 sb
!vm
:list-pointer-lowtag
)))
807 (write-memory dest car
)
808 (write-wordindexed dest
1 cdr
)
811 ;;; Make a simple-vector on the target that holds the specified
812 ;;; OBJECTS, and return its descriptor.
813 (defun vector-to-core (objects &optional
(gspace *dynamic
*))
814 (let* ((size (length objects
))
815 (result (allocate-vector-object gspace sb
!vm
:n-word-bits size
816 sb
!vm
:simple-vector-widetag
)))
817 (dotimes (index size
)
818 (write-wordindexed result
(+ index sb
!vm
:vector-data-offset
)
824 ;; Simulate *FREE-TLS-INDEX*. This is a count, not a displacement.
825 ;; In C, sizeof counts 1 word for the variable-length interrupt_contexts[]
826 ;; but primitive-object-size counts 0, so add 1, though in fact the C code
827 ;; implies that it might have overcounted by 1. We could make this agnostic
828 ;; of MAX-INTERRUPTS by moving the thread base register up by TLS-SIZE words,
829 ;; using negative offsets for all dynamically assigned indices.
830 (defvar *genesis-tls-counter
*
831 (+ 1 sb
!vm
::max-interrupts
832 (sb!vm
:primitive-object-size
833 (find 'sb
!vm
::thread sb
!vm
:*primitive-objects
*
834 :key
#'sb
!vm
:primitive-object-name
))))
838 ;; Assign SYMBOL the tls-index INDEX. SYMBOL must be a descriptor.
839 ;; This is a backend support routine, but the style within this file
840 ;; is to conditionalize by the target features.
841 (defun cold-assign-tls-index (symbol index
)
844 (logior (ash index
32)
845 (descriptor-bits (read-wordindexed symbol
0)))))
846 (write-wordindexed symbol
0 (make-random-descriptor header-word
)))
848 (write-wordindexed symbol sb
!vm
:symbol-tls-index-slot
849 (make-random-descriptor index
)))
851 ;; Return SYMBOL's tls-index,
852 ;; choosing a new index if it doesn't have one yet.
853 (defun ensure-symbol-tls-index (symbol)
854 (let* ((cold-sym (cold-intern symbol
))
857 (ldb (byte 32 32) (descriptor-bits (read-wordindexed cold-sym
0)))
860 (read-wordindexed cold-sym sb
!vm
:symbol-tls-index-slot
))))
861 (unless (plusp tls-index
)
862 (let ((next (prog1 *genesis-tls-counter
* (incf *genesis-tls-counter
*))))
863 (setq tls-index
(ash next sb
!vm
:word-shift
))
864 (cold-assign-tls-index cold-sym tls-index
)))
867 ;; A table of special variable names which get known TLS indices.
868 ;; Some of them are mapped onto 'struct thread' and have pre-determined offsets.
869 ;; Others are static symbols used with bind_variable() in the C runtime,
870 ;; and might not, in the absence of this table, get an index assigned by genesis
871 ;; depending on whether the cross-compiler used the BIND vop on them.
872 ;; Indices for those static symbols can be chosen arbitrarily, which is to say
873 ;; the value doesn't matter but must update the tls-counter correctly.
874 ;; All symbols other than the ones in this table get the indices assigned
875 ;; by the fasloader on demand.
877 (defvar *known-tls-symbols
*
878 ;; FIXME: no mechanism exists to determine which static symbols C code will
879 ;; dynamically bind. TLS is a finite resource, and wasting indices for all
880 ;; static symbols isn't the best idea. This list was hand-made with 'grep'.
881 '(sb!vm
:*alloc-signal
*
882 sb
!sys
:*allow-with-interrupts
*
883 sb
!vm
:*current-catch-block
*
884 sb
!vm
::*current-unwind-protect-block
*
885 sb
!kernel
:*free-interrupt-context-index
*
886 sb
!kernel
:*gc-inhibit
*
887 sb
!kernel
:*gc-pending
*
889 sb
!impl
::*in-safepoint
*
890 sb
!sys
:*interrupt-pending
*
891 sb
!sys
:*interrupts-enabled
*
892 sb
!vm
::*pinned-objects
*
893 sb
!kernel
:*restart-clusters
*
894 sb
!kernel
:*stop-for-gc-pending
*
896 sb
!sys
:*thruption-pending
*))
898 ;;; Allocate (and initialize) a symbol.
899 (defun allocate-symbol (name &key
(gspace *dynamic
*))
900 (declare (simple-string name
))
901 (let ((symbol (allocate-unboxed-object gspace
903 (1- sb
!vm
:symbol-size
)
904 sb
!vm
:symbol-header-widetag
)))
905 (write-wordindexed symbol sb
!vm
:symbol-value-slot
*unbound-marker
*)
906 (write-wordindexed symbol
907 sb
!vm
:symbol-hash-slot
908 (make-fixnum-descriptor 0))
909 (write-wordindexed symbol sb
!vm
:symbol-info-slot
*nil-descriptor
*)
910 (write-wordindexed symbol sb
!vm
:symbol-name-slot
911 (base-string-to-core name
*dynamic
*))
912 (write-wordindexed symbol sb
!vm
:symbol-package-slot
*nil-descriptor
*)
916 (defun assign-tls-index (symbol cold-symbol
)
917 (let ((index (info :variable
:wired-tls symbol
)))
918 (cond ((integerp index
) ; thread slot
919 (cold-assign-tls-index cold-symbol index
))
920 ((memq symbol
*known-tls-symbols
*)
921 ;; symbols without which the C runtime could not start
922 (shiftf index
*genesis-tls-counter
* (1+ *genesis-tls-counter
*))
923 (cold-assign-tls-index cold-symbol
(ash index sb
!vm
:word-shift
))))))
925 ;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a
926 ;;; descriptor of a cold symbol or (in an abbreviation for the
927 ;;; most common usage pattern) an ordinary symbol, which will be
928 ;;; automatically cold-interned.
929 (declaim (ftype (function ((or symbol descriptor
) descriptor
)) cold-set
))
930 (defun cold-set (symbol-or-symbol-des value
)
931 (let ((symbol-des (etypecase symbol-or-symbol-des
932 (descriptor symbol-or-symbol-des
)
933 (symbol (cold-intern symbol-or-symbol-des
)))))
934 (write-wordindexed symbol-des sb
!vm
:symbol-value-slot value
)))
936 ;;;; layouts and type system pre-initialization
938 ;;; Since we want to be able to dump structure constants and
939 ;;; predicates with reference layouts, we need to create layouts at
940 ;;; cold-load time. We use the name to intern layouts by, and dump a
941 ;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system
942 ;;; initialization can find them. The only thing that's tricky [sic --
943 ;;; WHN 19990816] is initializing layout's layout, which must point to
946 ;;; a map from class names to lists of
947 ;;; `(,descriptor ,name ,length ,inherits ,depth)
948 ;;; KLUDGE: It would be more understandable and maintainable to use
949 ;;; DEFSTRUCT (:TYPE LIST) here. -- WHN 19990823
950 (defvar *cold-layouts
* (make-hash-table :test
'equal
))
952 ;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting
954 (defvar *cold-layout-names
* (make-hash-table :test
'eql
))
956 ;;; FIXME: *COLD-LAYOUTS* and *COLD-LAYOUT-NAMES* should be
957 ;;; initialized by binding in GENESIS.
959 ;;; the descriptor for layout's layout (needed when making layouts)
960 (defvar *layout-layout
*)
961 ;;; the descriptor for PACKAGE's layout (needed when making packages)
962 (defvar *package-layout
*)
964 (defconstant target-layout-length
965 ;; LAYOUT-LENGTH counts the number of words in an instance,
966 ;; including the layout itself as 1 word
967 (layout-length (find-layout 'layout
)))
969 (defun target-layout-index (slot-name)
970 ;; KLUDGE: this is a little bit sleazy, but the tricky thing is that
971 ;; structure slots don't have a terribly firm idea of their names.
972 ;; At least here if we change LAYOUT's package of definition, we
973 ;; only have to change one thing...
974 (let* ((name (find-symbol (symbol-name slot-name
) "SB!KERNEL"))
975 (layout (find-layout 'layout
))
976 (dd (layout-info layout
))
977 (slots (dd-slots dd
))
978 (dsd (find name slots
:key
#'dsd-name
)))
982 (defun cold-set-layout-slot (cold-layout slot-name value
)
985 (+ sb
!vm
:instance-slots-offset
(target-layout-index slot-name
))
988 ;;; Return a list of names created from the cold layout INHERITS data
990 (defun listify-cold-inherits (x)
991 (let ((len (descriptor-fixnum (read-wordindexed x
992 sb
!vm
:vector-length-slot
))))
995 (let* ((des (read-wordindexed x
(+ sb
!vm
:vector-data-offset index
)))
996 (found (gethash (descriptor-bits des
) *cold-layout-names
*)))
999 (error "unknown descriptor at index ~S (bits = ~8,'0X)"
1001 (descriptor-bits des
)))))
1004 (declaim (ftype (function (symbol descriptor descriptor descriptor descriptor
)
1007 (defun make-cold-layout (name length inherits depthoid nuntagged
)
1008 (let ((result (allocate-structure-object *dynamic
*
1009 target-layout-length
1011 ;; Don't set the CLOS hash value: done in cold-init instead.
1013 ;; Set other slot values.
1015 ;; leave CLASSOID uninitialized for now
1016 (cold-set-layout-slot result
'invalid
*nil-descriptor
*)
1017 (cold-set-layout-slot result
'inherits inherits
)
1018 (cold-set-layout-slot result
'depthoid depthoid
)
1019 (cold-set-layout-slot result
'length length
)
1020 (cold-set-layout-slot result
'info
*nil-descriptor
*)
1021 (cold-set-layout-slot result
'pure
*nil-descriptor
*)
1022 (cold-set-layout-slot result
'n-untagged-slots nuntagged
)
1023 (cold-set-layout-slot result
'source-location
*nil-descriptor
*)
1024 (cold-set-layout-slot result
'%for-std-class-b
(make-fixnum-descriptor 0))
1025 (cold-set-layout-slot result
'slot-list
*nil-descriptor
*)
1027 (setf (gethash name
*cold-layouts
*)
1030 (descriptor-fixnum length
)
1031 (listify-cold-inherits inherits
)
1032 (descriptor-fixnum depthoid
)
1033 (descriptor-fixnum nuntagged
)))
1034 (setf (gethash (descriptor-bits result
) *cold-layout-names
*) name
)
1038 (defun initialize-layouts ()
1039 (clrhash *cold-layouts
*)
1040 ;; This assertion is due to the fact that MAKE-COLD-LAYOUT does not
1041 ;; know how to set any raw slots.
1042 (aver (= 0 (layout-n-untagged-slots (find-layout 'layout
))))
1043 (setq *layout-layout
* *nil-descriptor
*)
1044 (flet ((chill-layout (name &rest inherits
)
1045 ;; Check that the number of specified INHERITS matches
1046 ;; the length of the layout's inherits in the cross-compiler.
1047 (let ((warm-layout (classoid-layout (find-classoid name
))))
1048 (assert (eql (length (layout-inherits warm-layout
))
1052 (number-to-core (layout-length warm-layout
))
1053 (vector-to-core inherits
)
1054 (number-to-core (layout-depthoid warm-layout
))
1055 (number-to-core (layout-n-untagged-slots warm-layout
))))))
1056 (let* ((t-layout (chill-layout 't
))
1057 (s-o-layout (chill-layout 'structure-object t-layout
))
1058 (s!o-layout
(chill-layout 'structure
!object t-layout s-o-layout
)))
1059 (setf *layout-layout
*
1060 (chill-layout 'layout t-layout s-o-layout s
!o-layout
))
1061 (dolist (layout (list t-layout s-o-layout s
!o-layout
*layout-layout
*))
1062 (write-wordindexed layout sb
!vm
:instance-slots-offset
1064 (setf *package-layout
*
1065 (chill-layout 'package
; *NOT* SB!XC:PACKAGE, or you lose
1066 t-layout s-o-layout s
!o-layout
)))))
1068 ;;;; interning symbols in the cold image
1070 ;;; a map from package name as a host string to
1071 ;;; (cold-package-descriptor . (external-symbols . internal-symbols))
1072 (defvar *cold-package-symbols
*)
1073 (declaim (type hash-table
*cold-package-symbols
*))
1075 ;;; a map from descriptors to symbols, so that we can back up. The key
1076 ;;; is the address in the target core.
1077 (defvar *cold-symbols
*)
1078 (declaim (type hash-table
*cold-symbols
*))
1080 (defun initialize-packages (package-data-list)
1081 (let ((slots (dd-slots (layout-info (find-layout 'package
))))
1082 (target-pkg-list nil
))
1083 (labels ((set-slot (obj slot-name value
)
1084 (write-wordindexed obj
(slot-index slot-name
) value
))
1085 (slot-index (slot-name)
1086 (+ sb
!vm
:instance-slots-offset
1088 (find slot-name slots
:key
#'dsd-name
:test
#'string
=))))
1089 (init-cold-package (name &optional docstring
)
1090 (let ((cold-package (car (gethash name
*cold-package-symbols
*))))
1091 ;; patch in the layout
1092 (write-wordindexed cold-package sb
!vm
:instance-slots-offset
1094 ;; Initialize string slots
1095 (set-slot cold-package
'%name
(base-string-to-core name
))
1096 (set-slot cold-package
'%nicknames
(chill-nicknames name
))
1097 (set-slot cold-package
'doc-string
1099 (base-string-to-core docstring
)
1101 (set-slot cold-package
'%use-list
*nil-descriptor
*)
1102 ;; the cddr of this will accumulate the 'used-by' package list
1103 (push (list name cold-package
) target-pkg-list
)))
1104 (chill-nicknames (pkg-name)
1105 (let ((result *nil-descriptor
*))
1106 ;; Make the package nickname lists for the standard packages
1107 ;; be the minimum specified by ANSI, regardless of what value
1108 ;; the cross-compilation host happens to use.
1109 ;; For packages other than the standard packages, the nickname
1110 ;; list was specified by our package setup code, and we can just
1111 ;; propagate the current state into the target.
1113 (cond ((string= pkg-name
"COMMON-LISP") '("CL"))
1114 ((string= pkg-name
"COMMON-LISP-USER")
1116 ((string= pkg-name
"KEYWORD") '())
1117 (t (package-nicknames (find-package pkg-name
))))
1119 (cold-push (base-string-to-core nickname
) result
))))
1120 (find-cold-package (name)
1121 (cadr (find-package-cell name
)))
1122 (find-package-cell (name)
1123 (or (assoc (if (string= name
"CL") "COMMON-LISP" name
)
1124 target-pkg-list
:test
#'string
=)
1125 (error "No cold package named ~S" name
)))
1126 (list-to-core (list)
1127 (let ((res *nil-descriptor
*))
1128 (dolist (x list res
) (cold-push x res
)))))
1129 ;; pass 1: make all proto-packages
1130 (dolist (pd package-data-list
)
1131 (init-cold-package (sb-cold:package-data-name pd
)
1132 #!+sb-doc
(sb-cold::package-data-doc pd
)))
1133 ;; MISMATCH needs !HAIRY-DATA-VECTOR-REFFER-INIT to have been done,
1134 ;; and FIND-PACKAGE calls MISMATCH - which it shouldn't - but until
1135 ;; that is fixed, doing this in genesis allows packages to be
1136 ;; completely sane, modulo the naming, extremely early in cold-init.
1137 (cold-set '*keyword-package
* (find-cold-package "KEYWORD"))
1138 (cold-set '*cl-package
* (find-cold-package "COMMON-LISP"))
1139 ;; pass 2: set the 'use' lists and collect the 'used-by' lists
1140 (dolist (pd package-data-list
)
1141 (let ((this (find-cold-package (sb-cold:package-data-name pd
)))
1143 (dolist (that (sb-cold:package-data-use pd
))
1144 (let ((cell (find-package-cell that
)))
1145 (push (cadr cell
) use
)
1146 (push this
(cddr cell
))))
1147 (set-slot this
'%use-list
(list-to-core (nreverse use
)))))
1148 ;; pass 3: set the 'used-by' lists
1149 (dolist (cell target-pkg-list
)
1150 (set-slot (cadr cell
) '%used-by-list
(list-to-core (cddr cell
)))))))
1152 ;;; sanity check for a symbol we're about to create on the target
1154 ;;; Make sure that the symbol has an appropriate package. In
1155 ;;; particular, catch the so-easy-to-make error of typing something
1156 ;;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really
1157 ;;; need is SB!KERNEL:%BYTE-BLT.
1158 (defun package-ok-for-target-symbol-p (package)
1159 (let ((package-name (package-name package
)))
1161 ;; Cold interning things in these standard packages is OK. (Cold
1162 ;; interning things in the other standard package, CL-USER, isn't
1163 ;; OK. We just use CL-USER to expose symbols whose homes are in
1164 ;; other packages. Thus, trying to cold intern a symbol whose
1165 ;; home package is CL-USER probably means that a coding error has
1166 ;; been made somewhere.)
1167 (find package-name
'("COMMON-LISP" "KEYWORD") :test
#'string
=)
1168 ;; Cold interning something in one of our target-code packages,
1169 ;; which are ever-so-rigorously-and-elegantly distinguished by
1170 ;; this prefix on their names, is OK too.
1171 (string= package-name
"SB!" :end1
3 :end2
3)
1172 ;; This one is OK too, since it ends up being COMMON-LISP on the
1174 (string= package-name
"SB-XC")
1175 ;; Anything else looks bad. (maybe COMMON-LISP-USER? maybe an extension
1176 ;; package in the xc host? something we can't think of
1177 ;; a valid reason to cold intern, anyway...)
1180 ;;; like SYMBOL-PACKAGE, but safe for symbols which end up on the target
1182 ;;; Most host symbols we dump onto the target are created by SBCL
1183 ;;; itself, so that as long as we avoid gratuitously
1184 ;;; cross-compilation-unfriendly hacks, it just happens that their
1185 ;;; SYMBOL-PACKAGE in the host system corresponds to their
1186 ;;; SYMBOL-PACKAGE in the target system. However, that's not the case
1187 ;;; in the COMMON-LISP package, where we don't get to create the
1188 ;;; symbols but instead have to use the ones that the xc host created.
1189 ;;; In particular, while ANSI specifies which symbols are exported
1190 ;;; from COMMON-LISP, it doesn't specify that their home packages are
1191 ;;; COMMON-LISP, so the xc host can keep them in random packages which
1192 ;;; don't exist on the target (e.g. CLISP keeping some CL-exported
1193 ;;; symbols in the CLOS package).
1194 (defun symbol-package-for-target-symbol (symbol)
1195 ;; We want to catch weird symbols like CLISP's
1196 ;; CL:FIND-METHOD=CLOS::FIND-METHOD, but we don't want to get
1197 ;; sidetracked by ordinary symbols like :CHARACTER which happen to
1198 ;; have the same SYMBOL-NAME as exports from COMMON-LISP.
1199 (multiple-value-bind (cl-symbol cl-status
)
1200 (find-symbol (symbol-name symbol
) *cl-package
*)
1201 (if (and (eq symbol cl-symbol
)
1202 (eq cl-status
:external
))
1203 ;; special case, to work around possible xc host weirdness
1204 ;; in COMMON-LISP package
1207 (let ((result (symbol-package symbol
)))
1208 (unless (package-ok-for-target-symbol-p result
)
1209 (bug "~A in bad package for target: ~A" symbol result
))
1212 ;;; Assign target representation of VALUE to DESCRIPTOR.
1213 ;;; The VALUE should not have shared substructure in a way that matters,
1214 ;;; because sharing detection is not performed. It must not have cycles.
1215 (defun cold-set-symbol-global-value (descriptor value
)
1216 (labels ((target-representation (value)
1218 (symbol (cold-intern value
))
1219 (number (number-to-core value
))
1220 (string (base-string-to-core value
))
1221 (cons (cold-cons (target-representation (car value
))
1222 (target-representation (cdr value
)))))))
1223 (cold-set descriptor
(target-representation value
))))
1225 ;;; Return a handle on an interned symbol. If necessary allocate the
1226 ;;; symbol and record its home package.
1227 (defun cold-intern (symbol
1230 &aux
(package (symbol-package-for-target-symbol symbol
)))
1231 (aver (package-ok-for-target-symbol-p package
))
1233 ;; Anything on the cross-compilation host which refers to the target
1234 ;; machinery through the host SB-XC package should be translated to
1235 ;; something on the target which refers to the same machinery
1236 ;; through the target COMMON-LISP package.
1237 (let ((p (find-package "SB-XC")))
1238 (when (eq package p
)
1239 (setf package
*cl-package
*))
1240 (when (eq (symbol-package symbol
) p
)
1241 (setf symbol
(intern (symbol-name symbol
) *cl-package
*))))
1243 (or (get symbol
'cold-intern-info
)
1244 (let ((pkg-info (gethash (package-name package
) *cold-package-symbols
*))
1245 (handle (allocate-symbol (symbol-name symbol
) :gspace gspace
)))
1246 ;; maintain reverse map from target descriptor to host symbol
1247 (setf (gethash (descriptor-bits handle
) *cold-symbols
*) symbol
)
1249 (error "No target package descriptor for ~S" package
))
1250 (record-accessibility
1251 (or access
(nth-value 1 (find-symbol (symbol-name symbol
) package
)))
1252 handle pkg-info symbol package t
)
1254 (assign-tls-index symbol handle
)
1255 (acond ((eq package
*keyword-package
*)
1256 (setq access
:external
)
1257 (cold-set handle handle
))
1258 ((assoc symbol sb-cold
:*symbol-values-for-genesis
*)
1259 (cold-set-symbol-global-value handle
(cdr it
))))
1260 (setf (get symbol
'cold-intern-info
) handle
))))
1262 (defun record-accessibility (accessibility symbol-descriptor target-pkg-info
1263 host-symbol host-package
&optional set-home-p
)
1265 (write-wordindexed symbol-descriptor sb
!vm
:symbol-package-slot
1266 (car target-pkg-info
)))
1267 (when (member host-symbol
(package-shadowing-symbols host-package
))
1268 ;; Fail in an obvious way if target shadowing symbols exist.
1269 ;; (This is simply not an important use-case during system bootstrap.)
1270 (error "Genesis doesn't like shadowing symbol ~S, sorry." host-symbol
))
1271 (let ((access-lists (cdr target-pkg-info
)))
1273 (:external
(push symbol-descriptor
(car access-lists
)))
1274 (:internal
(push symbol-descriptor
(cdr access-lists
)))
1275 (t (error "~S inaccessible in package ~S" host-symbol host-package
)))))
1277 ;;; Construct and return a value for use as *NIL-DESCRIPTOR*.
1278 ;;; It might be nice to put NIL on a readonly page by itself to prevent unsafe
1279 ;;; code from destroying the world with (RPLACx nil 'kablooey)
1280 (defun make-nil-descriptor (target-cl-pkg-info)
1281 (let* ((des (allocate-unboxed-object
1286 (result (make-descriptor (descriptor-high des
)
1287 (+ (descriptor-low des
)
1288 (* 2 sb
!vm
:n-word-bytes
)
1289 (- sb
!vm
:list-pointer-lowtag
1290 sb
!vm
:other-pointer-lowtag
)))))
1291 (write-wordindexed des
1293 (make-other-immediate-descriptor
1295 sb
!vm
:symbol-header-widetag
))
1296 (write-wordindexed des
1297 (+ 1 sb
!vm
:symbol-value-slot
)
1299 (write-wordindexed des
1300 (+ 2 sb
!vm
:symbol-value-slot
) ; = 1 + symbol-hash-slot
1302 (write-wordindexed des
1303 (+ 1 sb
!vm
:symbol-info-slot
)
1304 (cold-cons result result
)) ; NIL's info is (nil . nil)
1305 (write-wordindexed des
1306 (+ 1 sb
!vm
:symbol-name-slot
)
1307 ;; NIL's name is in dynamic space because any extra
1308 ;; bytes allocated in static space would need to
1309 ;; be accounted for by STATIC-SYMBOL-OFFSET.
1310 (base-string-to-core "NIL" *dynamic
*))
1311 ;; RECORD-ACCESSIBILITY can't assign to the package slot
1312 ;; due to NIL's base address and lowtag being nonstandard.
1313 (write-wordindexed des
1314 (+ 1 sb
!vm
:symbol-package-slot
)
1315 (car target-cl-pkg-info
))
1316 (record-accessibility :external result target-cl-pkg-info nil
*cl-package
*)
1317 (setf (gethash (descriptor-bits result
) *cold-symbols
*) nil
1318 (get nil
'cold-intern-info
) result
)))
1320 ;;; Since the initial symbols must be allocated before we can intern
1321 ;;; anything else, we intern those here. We also set the value of T.
1322 (defun initialize-non-nil-symbols ()
1324 "Initialize the cold load symbol-hacking data structures."
1325 ;; Intern the others.
1326 (dolist (symbol sb
!vm
:*static-symbols
*)
1327 (let* ((des (cold-intern symbol
:gspace
*static
*))
1328 (offset-wanted (sb!vm
:static-symbol-offset symbol
))
1329 (offset-found (- (descriptor-low des
)
1330 (descriptor-low *nil-descriptor
*))))
1331 (unless (= offset-wanted offset-found
)
1332 ;; FIXME: should be fatal
1333 (warn "Offset from ~S to ~S is ~W, not ~W"
1338 ;; Establish the value of T.
1339 (let ((t-symbol (cold-intern t
:gspace
*static
*)))
1340 (cold-set t-symbol t-symbol
))
1341 ;; Establish the value of *PSEUDO-ATOMIC-BITS* so that the
1342 ;; allocation sequences that expect it to be zero upon entrance
1343 ;; actually find it to be so.
1345 (let ((p-a-a-symbol (cold-intern '*pseudo-atomic-bits
*
1347 (cold-set p-a-a-symbol
(make-fixnum-descriptor 0))))
1349 ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
1350 ;;; to be stored in *!INITIAL-LAYOUTS*.
1351 (defun cold-list-all-layouts ()
1353 (result *nil-descriptor
*))
1354 (maphash (lambda (key stuff
)
1355 (push (cons key
(first stuff
)) layouts
))
1357 (flet ((sorter (x y
)
1358 (let ((xpn (package-name (symbol-package-for-target-symbol x
)))
1359 (ypn (package-name (symbol-package-for-target-symbol y
))))
1361 ((string= x y
) (string< xpn ypn
))
1362 (t (string< x y
))))))
1363 (setq layouts
(sort layouts
#'sorter
:key
#'car
)))
1364 (dolist (layout layouts result
)
1365 (cold-push (cold-cons (cold-intern (car layout
)) (cdr layout
))
1368 ;;; Establish initial values for magic symbols.
1370 (defun finish-symbols ()
1372 ;; Everything between this preserved-for-posterity comment down to
1373 ;; the assignment of *CURRENT-CATCH-BLOCK* could be entirely deleted,
1374 ;; including the list of *C-CALLABLE-STATIC-SYMBOLS* itself,
1375 ;; if it is GC-safe for the C runtime to have its own implementation
1376 ;; of the INFO-VECTOR-FDEFN function in a multi-threaded build.
1378 ;; "I think the point of setting these functions into SYMBOL-VALUEs
1379 ;; here, instead of using SYMBOL-FUNCTION, is that in CMU CL
1380 ;; SYMBOL-FUNCTION reduces to FDEFINITION, which is a pretty
1381 ;; hairy operation (involving globaldb.lisp etc.) which we don't
1382 ;; want to invoke early in cold init. -- WHN 2001-12-05"
1384 ;; So... that's no longer true. We _do_ associate symbol -> fdefn in genesis.
1385 ;; Additionally, the INFO-VECTOR-FDEFN function is extremely simple and could
1386 ;; easily be implemented in C. However, info-vectors are inevitably
1387 ;; reallocated when new info is attached to a symbol, so the vectors can't be
1388 ;; in static space; they'd gradually become permanent garbage if they did.
1389 ;; That's the real reason for preserving the approach of storing an #<fdefn>
1390 ;; in a symbol's value cell - that location is static, the symbol-info is not.
1392 ;; FIXME: So OK, that's a reasonable reason to do something weird like
1393 ;; this, but this is still a weird thing to do, and we should change
1394 ;; the names to highlight that something weird is going on. Perhaps
1395 ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
1396 ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...
1397 (dolist (symbol sb
!vm
::*c-callable-static-symbols
*)
1398 (cold-set symbol
(cold-fdefinition-object (cold-intern symbol
))))
1400 (cold-set 'sb
!vm
::*current-catch-block
* (make-fixnum-descriptor 0))
1401 (cold-set 'sb
!vm
::*current-unwind-protect-block
* (make-fixnum-descriptor 0))
1403 (cold-set '*free-interrupt-context-index
* (make-fixnum-descriptor 0))
1405 (cold-set '*!initial-layouts
* (cold-list-all-layouts))
1409 (cold-set 'sb
!vm
::*free-tls-index
*
1410 (make-random-descriptor (ash *genesis-tls-counter
*
1412 (cold-set 'sb
!vm
::*tls-index-lock
* (make-fixnum-descriptor 0)))
1414 (dolist (symbol sb
!impl
::*cache-vector-symbols
*)
1415 (cold-set symbol
*nil-descriptor
*))
1417 ;; Symbols for which no call to COLD-INTERN would occur - due to not being
1418 ;; referenced until warm init - must be artificially cold-interned.
1419 ;; Inasmuch as the "offending" things are compiled by ordinary target code
1420 ;; and not cold-init, I think we should use an ordinary DEFPACKAGE for
1421 ;; the added-on bits. What I've done is somewhat of a fragile kludge.
1423 (with-package-iterator (iter '("SB!PCL" "SB!MOP" "SB!GRAY" "SB!SEQUENCE"
1424 "SB!PROFILE" "SB!EXT" "SB!VM"
1425 "SB!C" "SB!FASL" "SB!DEBUG")
1428 (multiple-value-bind (foundp sym accessibility package
) (iter)
1429 (declare (ignore accessibility
))
1430 (cond ((not foundp
) (return))
1431 ((eq (symbol-package sym
) package
) (push sym syms
))))))
1432 (setf syms
(stable-sort syms
#'string
<))
1436 (let ((cold-pkg-inits *nil-descriptor
*)
1437 cold-package-symbols-list
)
1438 (maphash (lambda (name info
)
1439 (push (cons name info
) cold-package-symbols-list
))
1440 *cold-package-symbols
*)
1441 (setf cold-package-symbols-list
1442 (sort cold-package-symbols-list
#'string
< :key
#'car
))
1443 (dolist (pkgcons cold-package-symbols-list
)
1444 (destructuring-bind (pkg-name . pkg-info
) pkgcons
1445 (unless (member pkg-name
'("COMMON-LISP" "KEYWORD") :test
'string
=)
1446 (let ((host-pkg (find-package pkg-name
))
1447 (sb-xc-pkg (find-package "SB-XC"))
1449 (with-package-iterator (iter host-pkg
:internal
:external
)
1450 (loop (multiple-value-bind (foundp sym accessibility
) (iter)
1451 (unless foundp
(return))
1452 (unless (or (eq (symbol-package sym
) host-pkg
)
1453 (eq (symbol-package sym
) sb-xc-pkg
))
1454 (push (cons sym accessibility
) syms
)))))
1455 (setq syms
(sort syms
#'string
< :key
#'car
))
1456 (dolist (symcons syms
)
1457 (destructuring-bind (sym . accessibility
) symcons
1458 (record-accessibility accessibility
(cold-intern sym
)
1459 pkg-info sym host-pkg
)))))
1460 (cold-push (cold-cons (car pkg-info
)
1461 (cold-cons (vector-to-core (cadr pkg-info
))
1462 (vector-to-core (cddr pkg-info
))))
1464 (cold-set 'sb
!impl
::*!initial-symbols
* cold-pkg-inits
))
1466 (attach-fdefinitions-to-symbols)
1468 (cold-set '*!reversed-cold-toplevels
* *current-reversed-cold-toplevels
*)
1469 (cold-set '*!initial-debug-sources
* *current-debug-sources
*)
1473 (cold-set 'sb
!vm
::*fp-constant-0d0
* (number-to-core 0d0
))
1474 (cold-set 'sb
!vm
::*fp-constant-1d0
* (number-to-core 1d0
))
1475 (cold-set 'sb
!vm
::*fp-constant-0f0
* (number-to-core 0f0
))
1476 (cold-set 'sb
!vm
::*fp-constant-1f0
* (number-to-core 1f0
))))
1478 ;;;; functions and fdefinition objects
1480 ;;; a hash table mapping from fdefinition names to descriptors of cold
1483 ;;; Note: Since fdefinition names can be lists like '(SETF FOO), and
1484 ;;; we want to have only one entry per name, this must be an 'EQUAL
1485 ;;; hash table, not the default 'EQL.
1486 (defvar *cold-fdefn-objects
*)
1488 (defvar *cold-fdefn-gspace
* nil
)
1490 ;;; Given a cold representation of a symbol, return a warm
1492 (defun warm-symbol (des)
1493 ;; Note that COLD-INTERN is responsible for keeping the
1494 ;; *COLD-SYMBOLS* table up to date, so if DES happens to refer to an
1495 ;; uninterned symbol, the code below will fail. But as long as we
1496 ;; don't need to look up uninterned symbols during bootstrapping,
1498 (multiple-value-bind (symbol found-p
)
1499 (gethash (descriptor-bits des
) *cold-symbols
*)
1500 (declare (type symbol symbol
))
1502 (error "no warm symbol"))
1505 ;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values
1506 (defun cold-car (des)
1507 (aver (= (descriptor-lowtag des
) sb
!vm
:list-pointer-lowtag
))
1508 (read-wordindexed des sb
!vm
:cons-car-slot
))
1509 (defun cold-cdr (des)
1510 (aver (= (descriptor-lowtag des
) sb
!vm
:list-pointer-lowtag
))
1511 (read-wordindexed des sb
!vm
:cons-cdr-slot
))
1512 (defun cold-null (des)
1513 (= (descriptor-bits des
)
1514 (descriptor-bits *nil-descriptor
*)))
1516 ;;; Given a cold representation of a function name, return a warm
1518 (declaim (ftype (function ((or symbol descriptor
)) (or symbol list
)) warm-fun-name
))
1519 (defun warm-fun-name (des)
1522 ;; This parallels the logic at the start of COLD-INTERN
1523 ;; which re-homes symbols in SB-XC to COMMON-LISP.
1524 (if (eq (symbol-package des
) (find-package "SB-XC"))
1525 (intern (symbol-name des
) *cl-package
*)
1527 (ecase (descriptor-lowtag des
)
1528 (#.sb
!vm
:list-pointer-lowtag
1529 (aver (not (cold-null des
))) ; function named NIL? please no..
1530 ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..).
1531 (let* ((car-des (cold-car des
))
1532 (cdr-des (cold-cdr des
))
1533 (cadr-des (cold-car cdr-des
))
1534 (cddr-des (cold-cdr cdr-des
)))
1535 (aver (cold-null cddr-des
))
1536 (list (warm-symbol car-des
)
1537 (warm-symbol cadr-des
))))
1538 (#.sb
!vm
:other-pointer-lowtag
1539 (warm-symbol des
))))))
1540 (legal-fun-name-or-type-error result
)
1543 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw
)
1544 (declare (type (or symbol descriptor
) cold-name
))
1545 (/noshow0
"/cold-fdefinition-object")
1546 (let ((warm-name (warm-fun-name cold-name
)))
1547 (or (gethash warm-name
*cold-fdefn-objects
*)
1548 (let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace
* *dynamic
*)
1549 (1- sb
!vm
:fdefn-size
)
1550 sb
!vm
:other-pointer-lowtag
)))
1552 (setf (gethash warm-name
*cold-fdefn-objects
*) fdefn
)
1553 (write-memory fdefn
(make-other-immediate-descriptor
1554 (1- sb
!vm
:fdefn-size
) sb
!vm
:fdefn-widetag
))
1555 (write-wordindexed fdefn sb
!vm
:fdefn-name-slot cold-name
)
1556 (unless leave-fn-raw
1557 (write-wordindexed fdefn sb
!vm
:fdefn-fun-slot
1559 (write-wordindexed fdefn
1560 sb
!vm
:fdefn-raw-addr-slot
1561 (make-random-descriptor
1562 (cold-foreign-symbol-address "undefined_tramp"))))
1565 ;;; Handle the at-cold-init-time, fset-for-static-linkage operation
1566 ;;; requested by FOP-FSET.
1567 (defun static-fset (cold-name defn
)
1568 (declare (type (or symbol descriptor
) cold-name
))
1569 (let ((fdefn (cold-fdefinition-object cold-name t
))
1570 (type (logand (descriptor-low (read-memory defn
)) sb
!vm
:widetag-mask
)))
1571 (write-wordindexed fdefn sb
!vm
:fdefn-fun-slot defn
)
1572 (write-wordindexed fdefn
1573 sb
!vm
:fdefn-raw-addr-slot
1575 (#.sb
!vm
:simple-fun-header-widetag
1576 (/noshow0
"static-fset (simple-fun)")
1580 (make-random-descriptor
1581 (+ (logandc2 (descriptor-bits defn
)
1583 (ash sb
!vm
:simple-fun-code-offset
1584 sb
!vm
:word-shift
))))
1585 (#.sb
!vm
:closure-header-widetag
1586 (/show0
"/static-fset (closure)")
1587 (make-random-descriptor
1588 (cold-foreign-symbol-address "closure_tramp")))))
1591 (defun initialize-static-fns ()
1592 (let ((*cold-fdefn-gspace
* *static
*))
1593 (dolist (sym sb
!vm
:*static-funs
*)
1594 (let* ((fdefn (cold-fdefinition-object (cold-intern sym
)))
1595 (offset (- (+ (- (descriptor-low fdefn
)
1596 sb
!vm
:other-pointer-lowtag
)
1597 (* sb
!vm
:fdefn-raw-addr-slot sb
!vm
:n-word-bytes
))
1598 (descriptor-low *nil-descriptor
*)))
1599 (desired (sb!vm
:static-fun-offset sym
)))
1600 (unless (= offset desired
)
1601 ;; FIXME: should be fatal
1602 (error "Offset from FDEFN ~S to ~S is ~W, not ~W."
1603 sym nil offset desired
))))))
1605 ;; Create pointer from SYMBOL and/or (SETF SYMBOL) to respective fdefinition
1607 (defun attach-fdefinitions-to-symbols ()
1608 (let ((hashtable (make-hash-table :test
#'eq
)))
1609 ;; Collect fdefinitions that go with one symbol, e.g. CAR and (SETF CAR),
1610 ;; using the hosts's code for manipulating a packed info-vector.
1611 (maphash (lambda (warm-name cold-fdefn
)
1612 (sb!c
::with-globaldb-name
(key1 key2
) warm-name
1613 :hairy
(error "Hairy fdefn name in genesis: ~S" warm-name
)
1615 (setf (gethash key1 hashtable
)
1616 (sb!c
::packed-info-insert
1617 (gethash key1 hashtable sb
!c
::+nil-packed-infos
+)
1618 key2 sb
!c
::+fdefn-type-num
+ cold-fdefn
))))
1619 *cold-fdefn-objects
*)
1620 ;; Emit in the same order symbols reside in core, for no particular reason.
1621 (loop for
(warm-sym . info
)
1622 in
(sort (sb!impl
::%hash-table-alist hashtable
) #'<
1623 :key
(lambda (x) (descriptor-bits (cold-intern (car x
)))))
1624 do
(write-wordindexed
1625 (cold-intern warm-sym
) sb
!vm
:symbol-info-slot
1626 ;; Each vector will have one fixnum, possibly the symbol SETF,
1627 ;; and one or two #<fdefn> objects in it.
1629 (map 'list
(lambda (elt)
1631 (symbol (cold-intern elt
))
1632 (fixnum (make-fixnum-descriptor elt
))
1637 ;;;; fixups and related stuff
1639 ;;; an EQUAL hash table
1640 (defvar *cold-foreign-symbol-table
*)
1641 (declaim (type hash-table
*cold-foreign-symbol-table
*))
1643 ;; Read the sbcl.nm file to find the addresses for foreign-symbols in
1645 (defun load-cold-foreign-symbol-table (filename)
1646 (/show
"load-cold-foreign-symbol-table" filename
)
1647 (with-open-file (file filename
)
1648 (loop for line
= (read-line file nil nil
)
1650 ;; UNIX symbol tables might have tabs in them, and tabs are
1651 ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
1652 ;; nice portable way to deal with them within Lisp, alas.
1653 ;; Fortunately, it's easy to use UNIX command line tools like
1654 ;; sed to remove the problem, so it's not too painful for us
1655 ;; to push responsibility for converting tabs to spaces out to
1658 ;; Other non-STANDARD-CHARs are problematic for the same reason.
1659 ;; Make sure that there aren't any..
1660 (let ((ch (find-if (lambda (char)
1661 (not (typep char
'standard-char
)))
1664 (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
1667 (setf line
(string-trim '(#\space
) line
))
1668 (let ((p1 (position #\space line
:from-end nil
))
1669 (p2 (position #\space line
:from-end t
)))
1670 (if (not (and p1 p2
(< p1 p2
)))
1671 ;; KLUDGE: It's too messy to try to understand all
1672 ;; possible output from nm, so we just punt the lines we
1673 ;; don't recognize. We realize that there's some chance
1674 ;; that might get us in trouble someday, so we warn
1676 (warn "ignoring unrecognized line ~S in ~A" line filename
)
1677 (multiple-value-bind (value name
)
1678 (if (string= "0x" line
:end2
2)
1679 (values (parse-integer line
:start
2 :end p1
:radix
16)
1680 (subseq line
(1+ p2
)))
1681 (values (parse-integer line
:end p1
:radix
16)
1682 (subseq line
(1+ p2
))))
1683 ;; KLUDGE CLH 2010-05-31: on darwin, nm gives us
1684 ;; _function but dlsym expects us to look up
1685 ;; function, without the leading _ . Therefore, we
1686 ;; strip it off here.
1688 (when (equal (char name
0) #\_
)
1689 (setf name
(subseq name
1)))
1690 (multiple-value-bind (old-value found
)
1691 (gethash name
*cold-foreign-symbol-table
*)
1693 (not (= old-value value
)))
1694 (warn "redefining ~S from #X~X to #X~X"
1695 name old-value value
)))
1696 (/show
"adding to *cold-foreign-symbol-table*:" name value
)
1697 (setf (gethash name
*cold-foreign-symbol-table
*) value
)
1699 (let ((at-position (position #\
@ name
)))
1701 (let ((name (subseq name
0 at-position
)))
1702 (multiple-value-bind (old-value found
)
1703 (gethash name
*cold-foreign-symbol-table
*)
1705 (not (= old-value value
)))
1706 (warn "redefining ~S from #X~X to #X~X"
1707 name old-value value
)))
1708 (setf (gethash name
*cold-foreign-symbol-table
*)
1712 (defun cold-foreign-symbol-address (name)
1713 (or (find-foreign-symbol-in-table name
*cold-foreign-symbol-table
*)
1714 *foreign-symbol-placeholder-value
*
1716 (format *error-output
* "~&The foreign symbol table is:~%")
1717 (maphash (lambda (k v
)
1718 (format *error-output
* "~&~S = #X~8X~%" k v
))
1719 *cold-foreign-symbol-table
*)
1720 (error "The foreign symbol ~S is undefined." name
))))
1722 (defvar *cold-assembler-routines
*)
1724 (defvar *cold-assembler-fixups
*)
1726 (defun record-cold-assembler-routine (name address
)
1727 (/xhow
"in RECORD-COLD-ASSEMBLER-ROUTINE" name address
)
1728 (push (cons name address
)
1729 *cold-assembler-routines
*))
1731 (defun record-cold-assembler-fixup (routine
1736 (push (list routine code-object offset kind
)
1737 *cold-assembler-fixups
*))
1739 (defun lookup-assembler-reference (symbol)
1740 (let ((value (cdr (assoc symbol
*cold-assembler-routines
*))))
1741 ;; FIXME: Should this be ERROR instead of WARN?
1743 (warn "Assembler routine ~S not defined." symbol
))
1746 ;;; The x86 port needs to store code fixups along with code objects if
1747 ;;; they are to be moved, so fixups for code objects in the dynamic
1748 ;;; heap need to be noted.
1750 (defvar *load-time-code-fixups
*)
1753 (defun note-load-time-code-fixup (code-object offset
)
1754 ;; If CODE-OBJECT might be moved
1755 (when (= (gspace-identifier (descriptor-intuit-gspace code-object
))
1756 dynamic-core-space-id
)
1757 (push offset
(gethash (descriptor-bits code-object
)
1758 *load-time-code-fixups
*
1763 (defun output-load-time-code-fixups ()
1764 (let ((fixup-infos nil
))
1766 (lambda (code-object-address fixup-offsets
)
1767 (push (cons code-object-address fixup-offsets
) fixup-infos
))
1768 *load-time-code-fixups
*)
1769 (setq fixup-infos
(sort fixup-infos
#'< :key
#'car
))
1770 (dolist (fixup-info fixup-infos
)
1771 (let ((code-object-address (car fixup-info
))
1772 (fixup-offsets (cdr fixup-info
)))
1774 (allocate-vector-object
1775 *dynamic
* sb
!vm
:n-word-bits
(length fixup-offsets
)
1776 sb
!vm
:simple-array-unsigned-byte-32-widetag
)))
1777 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
1778 (fixups fixup-offsets
(cdr fixups
)))
1780 (write-wordindexed fixup-vector index
1781 (make-random-descriptor (car fixups
))))
1782 ;; KLUDGE: The fixup vector is stored as the first constant,
1783 ;; not as a separately-named slot.
1784 (write-wordindexed (make-random-descriptor code-object-address
)
1785 sb
!vm
:code-constants-offset
1788 ;;; Given a pointer to a code object and an offset relative to the
1789 ;;; tail of the code object's header, return an offset relative to the
1790 ;;; (beginning of the) code object.
1792 ;;; FIXME: It might be clearer to reexpress
1793 ;;; (LET ((X (CALC-OFFSET CODE-OBJECT OFFSET0))) ..)
1795 ;;; (LET ((X (+ OFFSET0 (CODE-OBJECT-HEADER-N-BYTES CODE-OBJECT)))) ..).
1796 (declaim (ftype (function (descriptor sb
!vm
:word
)) calc-offset
))
1797 (defun calc-offset (code-object offset-from-tail-of-header
)
1798 (let* ((header (read-memory code-object
))
1799 (header-n-words (ash (descriptor-bits header
)
1800 (- sb
!vm
:n-widetag-bits
)))
1801 (header-n-bytes (ash header-n-words sb
!vm
:word-shift
))
1802 (result (+ offset-from-tail-of-header header-n-bytes
)))
1805 (declaim (ftype (function (descriptor sb
!vm
:word sb
!vm
:word keyword
))
1807 (defun do-cold-fixup (code-object after-header value kind
)
1808 (let* ((offset-within-code-object (calc-offset code-object after-header
))
1809 (gspace-bytes (descriptor-bytes code-object
))
1810 (gspace-byte-offset (+ (descriptor-byte-offset code-object
)
1811 offset-within-code-object
))
1812 (gspace-byte-address (gspace-byte-address
1813 (descriptor-gspace code-object
))))
1814 (ecase +backend-fasl-file-implementation
+
1815 ;; See CMU CL source for other formerly-supported architectures
1816 ;; (and note that you have to rewrite them to use BVREF-X
1817 ;; instead of SAP-REF).
1821 (assert (zerop (ldb (byte 2 0) value
))))
1823 (let* ((value (if (logbitp 15 value
) (+ value
(ash 1 16)) value
))
1824 (value (if (logbitp 31 value
) (+ value
(ash 1 32)) value
))
1825 (value (if (logbitp 47 value
) (+ value
(ash 1 48)) value
)))
1826 (setf (bvref-8 gspace-bytes gspace-byte-offset
)
1827 (ldb (byte 8 48) value
)
1828 (bvref-8 gspace-bytes
(1+ gspace-byte-offset
))
1829 (ldb (byte 8 56) value
))))
1831 (let* ((value (if (logbitp 15 value
) (+ value
(ash 1 16)) value
))
1832 (value (if (logbitp 31 value
) (+ value
(ash 1 32)) value
)))
1833 (setf (bvref-8 gspace-bytes gspace-byte-offset
)
1834 (ldb (byte 8 32) value
)
1835 (bvref-8 gspace-bytes
(1+ gspace-byte-offset
))
1836 (ldb (byte 8 40) value
))))
1838 (let ((value (if (logbitp 15 value
) (+ value
(ash 1 16)) value
)))
1839 (setf (bvref-8 gspace-bytes gspace-byte-offset
)
1840 (ldb (byte 8 16) value
)
1841 (bvref-8 gspace-bytes
(1+ gspace-byte-offset
))
1842 (ldb (byte 8 24) value
))))
1844 (setf (bvref-8 gspace-bytes gspace-byte-offset
)
1845 (ldb (byte 8 0) value
)
1846 (bvref-8 gspace-bytes
(1+ gspace-byte-offset
))
1847 (ldb (byte 8 8) value
)))))
1851 (setf (bvref-32 gspace-bytes gspace-byte-offset
) value
))))
1855 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1856 (logior (mask-field (byte 18 14)
1857 (bvref-32 gspace-bytes gspace-byte-offset
))
1859 (1+ (ash (ldb (byte 13 0) value
) 1))
1860 (ash (ldb (byte 13 0) value
) 1)))))
1862 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1863 (logior (mask-field (byte 18 14)
1864 (bvref-32 gspace-bytes gspace-byte-offset
))
1866 (1+ (ash (ldb (byte 10 0) value
) 1))
1867 (ash (ldb (byte 11 0) value
) 1)))))
1869 (let ((low-bits (ldb (byte 11 0) value
)))
1870 (assert (<= 0 low-bits
(1- (ash 1 4)))))
1871 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1872 (logior (ash (dpb (ldb (byte 4 0) value
)
1874 (ldb (byte 1 4) value
)) 17)
1875 (logand (bvref-32 gspace-bytes gspace-byte-offset
)
1878 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1879 (logior (mask-field (byte 11 21)
1880 (bvref-32 gspace-bytes gspace-byte-offset
))
1881 (ash (ldb (byte 5 13) value
) 16)
1882 (ash (ldb (byte 2 18) value
) 14)
1883 (ash (ldb (byte 2 11) value
) 12)
1884 (ash (ldb (byte 11 20) value
) 1)
1885 (ldb (byte 1 31) value
))))
1887 (let ((bits (ldb (byte 9 2) value
)))
1888 (assert (zerop (ldb (byte 2 0) value
)))
1889 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1890 (logior (ash bits
3)
1891 (mask-field (byte 1 1) (bvref-32 gspace-bytes gspace-byte-offset
))
1892 (mask-field (byte 3 13) (bvref-32 gspace-bytes gspace-byte-offset
))
1893 (mask-field (byte 11 21) (bvref-32 gspace-bytes gspace-byte-offset
))))))))
1897 (assert (zerop (ash value -
28)))
1898 (setf (ldb (byte 26 0)
1899 (bvref-32 gspace-bytes gspace-byte-offset
))
1902 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1903 (logior (mask-field (byte 16 16)
1904 (bvref-32 gspace-bytes gspace-byte-offset
))
1905 (ash (1+ (ldb (byte 17 15) value
)) -
1))))
1907 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1908 (logior (mask-field (byte 16 16)
1909 (bvref-32 gspace-bytes gspace-byte-offset
))
1910 (ldb (byte 16 0) value
))))))
1911 ;; FIXME: PowerPC Fixups are not fully implemented. The bit
1912 ;; here starts to set things up to work properly, but there
1913 ;; needs to be corresponding code in ppc-vm.lisp
1917 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1918 (dpb (ash value -
2) (byte 24 2)
1919 (bvref-32 gspace-bytes gspace-byte-offset
))))
1921 (let* ((un-fixed-up (bvref-16 gspace-bytes
1922 (+ gspace-byte-offset
2)))
1923 (fixed-up (+ un-fixed-up value
))
1924 (h (ldb (byte 16 16) fixed-up
))
1925 (l (ldb (byte 16 0) fixed-up
)))
1926 (setf (bvref-16 gspace-bytes
(+ gspace-byte-offset
2))
1927 (if (logbitp 15 l
) (ldb (byte 16 0) (1+ h
)) h
))))
1929 (let* ((un-fixed-up (bvref-16 gspace-bytes
1930 (+ gspace-byte-offset
2)))
1931 (fixed-up (+ un-fixed-up value
)))
1932 (setf (bvref-16 gspace-bytes
(+ gspace-byte-offset
2))
1933 (ldb (byte 16 0) fixed-up
))))))
1937 (error "can't deal with call fixups yet"))
1939 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1940 (dpb (ldb (byte 22 10) value
)
1942 (bvref-32 gspace-bytes gspace-byte-offset
))))
1944 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1945 (dpb (ldb (byte 10 0) value
)
1947 (bvref-32 gspace-bytes gspace-byte-offset
))))))
1949 ;; XXX: Note that un-fixed-up is read via bvref-word, which is
1950 ;; 64 bits wide on x86-64, but the fixed-up value is written
1951 ;; via bvref-32. This would make more sense if we supported
1952 ;; :absolute64 fixups, but apparently the cross-compiler
1953 ;; doesn't dump them.
1954 (let* ((un-fixed-up (bvref-word gspace-bytes
1955 gspace-byte-offset
))
1956 (code-object-start-addr (logandc2 (descriptor-bits code-object
)
1957 sb
!vm
:lowtag-mask
)))
1958 (assert (= code-object-start-addr
1959 (+ gspace-byte-address
1960 (descriptor-byte-offset code-object
))))
1963 (let ((fixed-up (+ value un-fixed-up
)))
1964 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1966 ;; comment from CMU CL sources:
1968 ;; Note absolute fixups that point within the object.
1969 ;; KLUDGE: There seems to be an implicit assumption in
1970 ;; the old CMU CL code here, that if it doesn't point
1971 ;; before the object, it must point within the object
1972 ;; (not beyond it). It would be good to add an
1973 ;; explanation of why that's true, or an assertion that
1974 ;; it's really true, or both.
1976 ;; One possible explanation is that all absolute fixups
1977 ;; point either within the code object, within the
1978 ;; runtime, within read-only or static-space, or within
1979 ;; the linkage-table space. In all x86 configurations,
1980 ;; these areas are prior to the start of dynamic space,
1981 ;; where all the code-objects are loaded.
1983 (unless (< fixed-up code-object-start-addr
)
1984 (note-load-time-code-fixup code-object
1986 (:relative
; (used for arguments to X86 relative CALL instruction)
1987 (let ((fixed-up (- (+ value un-fixed-up
)
1990 4))) ; "length of CALL argument"
1991 (setf (bvref-32 gspace-bytes gspace-byte-offset
)
1993 ;; Note relative fixups that point outside the code
1994 ;; object, which is to say all relative fixups, since
1995 ;; relative addressing within a code object never needs
1998 (note-load-time-code-fixup code-object
1999 after-header
))))))))
2002 (defun resolve-assembler-fixups ()
2003 (dolist (fixup *cold-assembler-fixups
*)
2004 (let* ((routine (car fixup
))
2005 (value (lookup-assembler-reference routine
)))
2007 (do-cold-fixup (second fixup
) (third fixup
) value
(fourth fixup
))))))
2011 (defparameter *dyncore-address
* sb
!vm
::linkage-table-space-start
)
2012 (defparameter *dyncore-linkage-keys
* nil
)
2013 (defparameter *dyncore-table
* (make-hash-table :test
'equal
))
2015 (defun dyncore-note-symbol (symbol-name datap
)
2016 "Register a symbol and return its address in proto-linkage-table."
2017 (let ((key (cons symbol-name datap
)))
2018 (symbol-macrolet ((entry (gethash key
*dyncore-table
*)))
2021 (prog1 *dyncore-address
*
2022 (push key
*dyncore-linkage-keys
*)
2023 (incf *dyncore-address
* sb
!vm
::linkage-table-entry-size
))))))))
2025 ;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in
2026 ;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to
2027 ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
2028 ;;; target-load.lisp refers to.
2029 (defun foreign-symbols-to-core ()
2031 (result *nil-descriptor
*))
2034 (maphash (lambda (symbol value
)
2035 (push (cons symbol value
) symbols
))
2036 *cold-foreign-symbol-table
*)
2037 (setq symbols
(sort symbols
#'string
< :key
#'car
))
2038 (dolist (symbol symbols
)
2039 (cold-push (cold-cons (base-string-to-core (car symbol
))
2040 (number-to-core (cdr symbol
)))
2042 (cold-set '*!initial-foreign-symbols
* result
)
2044 (let ((runtime-linking-list *nil-descriptor
*))
2045 (dolist (symbol *dyncore-linkage-keys
*)
2046 (cold-push (cold-cons (base-string-to-core (car symbol
))
2048 runtime-linking-list
))
2049 (cold-set 'sb
!vm
::*required-runtime-c-symbols
*
2050 runtime-linking-list
)))
2051 (let ((result *nil-descriptor
*))
2052 (dolist (rtn (sort (copy-list *cold-assembler-routines
*) #'string
< :key
#'car
))
2053 (cold-push (cold-cons (cold-intern (car rtn
))
2054 (number-to-core (cdr rtn
)))
2056 (cold-set '*!initial-assembler-routines
* result
)))
2059 ;;;; general machinery for cold-loading FASL files
2061 ;;; FOP functions for cold loading
2062 (defvar *cold-fop-funs
*
2063 ;; We start out with a copy of the ordinary *FOP-FUNS*. The ones
2064 ;; which aren't appropriate for cold load will be destructively
2066 (copy-seq *fop-funs
*))
2068 (defun pop-fop-stack ()
2069 (let* ((stack *fop-stack
*)
2070 (top (svref stack
0)))
2071 (declare (type index top
))
2073 (error "FOP stack empty"))
2074 (setf (svref stack
0) (1- top
))
2077 ;;; Cause a fop to have a special definition for cold load.
2079 ;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version
2080 ;;; (1) looks up the code for this name (created by a previous
2081 ;;; DEFINE-FOP) instead of creating a code, and
2082 ;;; (2) stores its definition in the *COLD-FOP-FUNS* vector,
2083 ;;; instead of storing in the *FOP-FUNS* vector.
2084 (defmacro define-cold-fop
((name &key
(pushp t
)) &rest forms
)
2085 (aver (member pushp
'(nil t
)))
2086 (let ((code (get name
'fop-code
))
2087 (fname (symbolicate "COLD-" name
)))
2089 (error "~S is not a defined FOP." name
))
2092 (macrolet ((pop-stack () `(pop-fop-stack)))
2093 ,@(if pushp
`((push-fop-stack (progn ,@forms
))) forms
)))
2094 (setf (svref *cold-fop-funs
* ,code
) #',fname
))))
2096 (defmacro clone-cold-fop
((name &key
(pushp t
))
2099 (aver (member pushp
'(nil t
)))
2101 (macrolet ((clone-arg () '(read-word-arg)))
2102 (define-cold-fop (,name
:pushp
,pushp
) ,@forms
))
2103 (macrolet ((clone-arg () '(read-byte-arg)))
2104 (define-cold-fop (,small-name
:pushp
,pushp
) ,@forms
))))
2106 ;;; Cause a fop to be undefined in cold load.
2107 (defmacro not-cold-fop
(name)
2108 `(define-cold-fop (,name
)
2109 (error "The fop ~S is not supported in cold load." ',name
)))
2111 ;;; COLD-LOAD loads stuff into the core image being built by calling
2112 ;;; LOAD-AS-FASL with the fop function table rebound to a table of cold
2113 ;;; loading functions.
2114 (defun cold-load (filename)
2116 "Load the file named by FILENAME into the cold load image being built."
2117 (let* ((*fop-funs
* *cold-fop-funs
*)
2118 (*cold-load-filename
* (etypecase filename
2120 (pathname (namestring filename
)))))
2121 (with-open-file (s filename
:element-type
'(unsigned-byte 8))
2122 (load-as-fasl s nil nil
))))
2124 ;;;; miscellaneous cold fops
2126 (define-cold-fop (fop-misc-trap) *unbound-marker
*)
2128 (define-cold-fop (fop-short-character)
2129 (make-character-descriptor (read-byte-arg)))
2131 (define-cold-fop (fop-empty-list) nil
)
2132 (define-cold-fop (fop-truth) t
)
2134 (clone-cold-fop (fop-struct)
2136 (let* ((size (clone-arg)) ; n-words including layout, excluding header
2137 (layout (pop-stack))
2138 (result (allocate-structure-object *dynamic
* size layout
))
2143 (+ sb
!vm
:instance-slots-offset
2144 (target-layout-index 'n-untagged-slots
)))))
2145 (ntagged (- size nuntagged
)))
2146 (do ((index 1 (1+ index
)))
2148 (declare (fixnum index
))
2149 (write-wordindexed result
2150 (+ index sb
!vm
:instance-slots-offset
)
2151 (if (>= index ntagged
)
2152 (descriptor-word-sized-integer (pop-stack))
2156 (define-cold-fop (fop-layout)
2157 (let* ((nuntagged-des (pop-stack))
2158 (length-des (pop-stack))
2159 (depthoid-des (pop-stack))
2160 (cold-inherits (pop-stack))
2162 (old (gethash name
*cold-layouts
*)))
2163 (declare (type descriptor length-des depthoid-des cold-inherits
))
2164 (declare (type symbol name
))
2165 ;; If a layout of this name has been defined already
2167 ;; Enforce consistency between the previous definition and the
2168 ;; current definition, then return the previous definition.
2170 ;; FIXME: This would be more maintainable if we used
2171 ;; DEFSTRUCT (:TYPE LIST) to define COLD-LAYOUT. -- WHN 19990825
2172 (old-layout-descriptor
2179 (declare (type descriptor old-layout-descriptor
))
2180 (declare (type index old-length old-nuntagged
))
2181 (declare (type fixnum old-depthoid
))
2182 (declare (type list old-inherits-list
))
2183 (aver (eq name old-name
))
2184 (let ((length (descriptor-fixnum length-des
))
2185 (inherits-list (listify-cold-inherits cold-inherits
))
2186 (depthoid (descriptor-fixnum depthoid-des
))
2187 (nuntagged (descriptor-fixnum nuntagged-des
)))
2188 (unless (= length old-length
)
2189 (error "cold loading a reference to class ~S when the compile~%~
2190 time length was ~S and current length is ~S"
2194 (unless (equal inherits-list old-inherits-list
)
2195 (error "cold loading a reference to class ~S when the compile~%~
2196 time inherits were ~S~%~
2197 and current inherits are ~S"
2201 (unless (= depthoid old-depthoid
)
2202 (error "cold loading a reference to class ~S when the compile~%~
2203 time inheritance depthoid was ~S and current inheritance~%~
2208 (unless (= nuntagged old-nuntagged
)
2209 (error "cold loading a reference to class ~S when the compile~%~
2210 time number of untagged slots was ~S and is currently ~S"
2214 old-layout-descriptor
)
2215 ;; Make a new definition from scratch.
2216 (make-cold-layout name length-des cold-inherits depthoid-des
2219 ;;;; cold fops for loading symbols
2221 ;;; Load a symbol SIZE characters long from *FASL-INPUT-STREAM* and
2222 ;;; intern that symbol in PACKAGE.
2223 (defun cold-load-symbol (size package
)
2224 (let ((string (make-string size
)))
2225 (read-string-as-bytes *fasl-input-stream
* string
)
2226 (intern string package
)))
2228 (macrolet ((frob (name pname-len package-len
)
2229 `(define-cold-fop (,name
)
2230 (let ((index (read-arg ,package-len
)))
2232 (cold-load-symbol (read-arg ,pname-len
)
2233 (ref-fop-table index
)))))))
2234 (frob fop-symbol-in-package-save
#.sb
!vm
:n-word-bytes
#.sb
!vm
:n-word-bytes
)
2235 (frob fop-small-symbol-in-package-save
1 #.sb
!vm
:n-word-bytes
)
2236 (frob fop-symbol-in-byte-package-save
#.sb
!vm
:n-word-bytes
1)
2237 (frob fop-small-symbol-in-byte-package-save
1 1))
2239 (clone-cold-fop (fop-lisp-symbol-save)
2240 (fop-lisp-small-symbol-save)
2241 (push-fop-table (cold-load-symbol (clone-arg) *cl-package
*)))
2243 (clone-cold-fop (fop-keyword-symbol-save)
2244 (fop-keyword-small-symbol-save)
2245 (push-fop-table (cold-load-symbol (clone-arg) *keyword-package
*)))
2247 (defvar *uninterned-symbol-table
* (make-hash-table :test
#'equal
))
2248 (clone-cold-fop (fop-uninterned-symbol-save)
2249 (fop-uninterned-small-symbol-save)
2250 (let* ((size (clone-arg))
2251 (name (make-string size
)))
2252 (read-string-as-bytes *fasl-input-stream
* name
)
2253 (let ((symbol-des (gethash name
*uninterned-symbol-table
*)))
2255 (setf symbol-des
(allocate-symbol name
)
2256 (gethash name
*uninterned-symbol-table
*) symbol-des
))
2257 (push-fop-table symbol-des
))))
2259 ;;;; cold fops for loading packages
2261 (clone-cold-fop (fop-named-package-save :pushp nil
)
2262 (fop-small-named-package-save)
2263 (let* ((size (clone-arg))
2264 (name (make-string size
)))
2265 (read-string-as-bytes *fasl-input-stream
* name
)
2266 (push-fop-table (find-package name
))))
2268 ;;;; cold fops for loading lists
2270 ;;; Make a list of the top LENGTH things on the fop stack. The last
2271 ;;; cdr of the list is set to LAST.
2272 (defmacro cold-stack-list
(length last
)
2273 `(do* ((index ,length
(1- index
))
2274 (result ,last
(cold-cons (pop-stack) result
)))
2275 ((= index
0) result
)
2276 (declare (fixnum index
))))
2278 (define-cold-fop (fop-list)
2279 (cold-stack-list (read-byte-arg) *nil-descriptor
*))
2280 (define-cold-fop (fop-list*)
2281 (cold-stack-list (read-byte-arg) (pop-stack)))
2282 (define-cold-fop (fop-list-1)
2283 (cold-stack-list 1 *nil-descriptor
*))
2284 (define-cold-fop (fop-list-2)
2285 (cold-stack-list 2 *nil-descriptor
*))
2286 (define-cold-fop (fop-list-3)
2287 (cold-stack-list 3 *nil-descriptor
*))
2288 (define-cold-fop (fop-list-4)
2289 (cold-stack-list 4 *nil-descriptor
*))
2290 (define-cold-fop (fop-list-5)
2291 (cold-stack-list 5 *nil-descriptor
*))
2292 (define-cold-fop (fop-list-6)
2293 (cold-stack-list 6 *nil-descriptor
*))
2294 (define-cold-fop (fop-list-7)
2295 (cold-stack-list 7 *nil-descriptor
*))
2296 (define-cold-fop (fop-list-8)
2297 (cold-stack-list 8 *nil-descriptor
*))
2298 (define-cold-fop (fop-list*-
1)
2299 (cold-stack-list 1 (pop-stack)))
2300 (define-cold-fop (fop-list*-
2)
2301 (cold-stack-list 2 (pop-stack)))
2302 (define-cold-fop (fop-list*-
3)
2303 (cold-stack-list 3 (pop-stack)))
2304 (define-cold-fop (fop-list*-
4)
2305 (cold-stack-list 4 (pop-stack)))
2306 (define-cold-fop (fop-list*-
5)
2307 (cold-stack-list 5 (pop-stack)))
2308 (define-cold-fop (fop-list*-
6)
2309 (cold-stack-list 6 (pop-stack)))
2310 (define-cold-fop (fop-list*-
7)
2311 (cold-stack-list 7 (pop-stack)))
2312 (define-cold-fop (fop-list*-
8)
2313 (cold-stack-list 8 (pop-stack)))
2315 ;;;; cold fops for loading vectors
2317 (clone-cold-fop (fop-base-string)
2318 (fop-small-base-string)
2319 (let* ((len (clone-arg))
2320 (string (make-string len
)))
2321 (read-string-as-bytes *fasl-input-stream
* string
)
2322 (base-string-to-core string
)))
2325 (clone-cold-fop (fop-character-string)
2326 (fop-small-character-string)
2327 (bug "CHARACTER-STRING dumped by cross-compiler."))
2329 (clone-cold-fop (fop-vector)
2331 (let* ((size (clone-arg))
2332 (result (allocate-vector-object *dynamic
*
2335 sb
!vm
:simple-vector-widetag
)))
2336 (do ((index (1- size
) (1- index
)))
2338 (declare (fixnum index
))
2339 (write-wordindexed result
2340 (+ index sb
!vm
:vector-data-offset
)
2344 (define-cold-fop (fop-spec-vector)
2345 (let* ((len (read-word-arg))
2346 (type (read-byte-arg))
2347 (sizebits (aref **saetp-bits-per-length
** type
))
2348 (result (progn (aver (< sizebits
255))
2349 (allocate-vector-object *dynamic
* sizebits len type
)))
2350 (start (+ (descriptor-byte-offset result
)
2351 (ash sb
!vm
:vector-data-offset sb
!vm
:word-shift
)))
2353 (ceiling (* len sizebits
)
2354 sb
!vm
:n-byte-bits
))))
2355 (read-bigvec-as-sequence-or-die (descriptor-bytes result
)
2361 (define-cold-fop (fop-array)
2362 (let* ((rank (read-word-arg))
2363 (data-vector (pop-stack))
2364 (result (allocate-boxed-object *dynamic
*
2365 (+ sb
!vm
:array-dimensions-offset rank
)
2366 sb
!vm
:other-pointer-lowtag
)))
2367 (write-memory result
2368 (make-other-immediate-descriptor rank
2369 sb
!vm
:simple-array-widetag
))
2370 (write-wordindexed result sb
!vm
:array-fill-pointer-slot
*nil-descriptor
*)
2371 (write-wordindexed result sb
!vm
:array-data-slot data-vector
)
2372 (write-wordindexed result sb
!vm
:array-displacement-slot
*nil-descriptor
*)
2373 (write-wordindexed result sb
!vm
:array-displaced-p-slot
*nil-descriptor
*)
2374 (write-wordindexed result sb
!vm
:array-displaced-from-slot
*nil-descriptor
*)
2375 (let ((total-elements 1))
2376 (dotimes (axis rank
)
2377 (let ((dim (pop-stack)))
2378 (unless (is-fixnum-lowtag (descriptor-lowtag dim
))
2379 (error "non-fixnum dimension? (~S)" dim
))
2380 (setf total-elements
2382 (logior (ash (descriptor-high dim
)
2383 (- descriptor-low-bits
2384 sb
!vm
:n-fixnum-tag-bits
))
2385 (ash (descriptor-low dim
)
2386 sb
!vm
:n-fixnum-tag-bits
))))
2387 (write-wordindexed result
2388 (+ sb
!vm
:array-dimensions-offset axis
)
2390 (write-wordindexed result
2391 sb
!vm
:array-elements-slot
2392 (make-fixnum-descriptor total-elements
)))
2396 ;;;; cold fops for loading numbers
2398 (defmacro define-cold-number-fop
(fop)
2399 `(define-cold-fop (,fop
)
2400 ;; Invoke the ordinary warm version of this fop to push the
2403 ;; Replace the warm fop result with the cold image of the warm
2405 (number-to-core (pop-stack))))
2407 (define-cold-number-fop fop-single-float
)
2408 (define-cold-number-fop fop-double-float
)
2409 (define-cold-number-fop fop-integer
)
2410 (define-cold-number-fop fop-small-integer
)
2411 (define-cold-number-fop fop-word-integer
)
2412 (define-cold-number-fop fop-byte-integer
)
2413 (define-cold-number-fop fop-complex-single-float
)
2414 (define-cold-number-fop fop-complex-double-float
)
2416 (define-cold-fop (fop-ratio)
2417 (let ((den (pop-stack)))
2418 (number-pair-to-core (pop-stack) den sb
!vm
:ratio-widetag
)))
2420 (define-cold-fop (fop-complex)
2421 (let ((im (pop-stack)))
2422 (number-pair-to-core (pop-stack) im sb
!vm
:complex-widetag
)))
2424 ;;;; cold fops for calling (or not calling)
2426 (not-cold-fop fop-eval
)
2427 (not-cold-fop fop-eval-for-effect
)
2429 (defvar *load-time-value-counter
*)
2431 (define-cold-fop (fop-funcall)
2432 (unless (= (read-byte-arg) 0)
2433 (error "You can't FOP-FUNCALL arbitrary stuff in cold load."))
2434 (let ((counter *load-time-value-counter
*))
2435 (cold-push (cold-cons
2436 (cold-intern :load-time-value
)
2440 (number-to-core counter
)
2442 *current-reversed-cold-toplevels
*)
2443 (setf *load-time-value-counter
* (1+ counter
))
2444 (make-descriptor 0 0 :load-time-value counter
)))
2446 (defun finalize-load-time-value-noise ()
2447 (cold-set '*!load-time-values
*
2448 (allocate-vector-object *dynamic
*
2450 *load-time-value-counter
*
2451 sb
!vm
:simple-vector-widetag
)))
2453 (define-cold-fop (fop-funcall-for-effect :pushp nil
)
2454 (if (= (read-byte-arg) 0)
2455 (cold-push (pop-stack)
2456 *current-reversed-cold-toplevels
*)
2457 (error "You can't FOP-FUNCALL arbitrary stuff in cold load.")))
2459 ;;;; cold fops for fixing up circularities
2461 (define-cold-fop (fop-rplaca :pushp nil
)
2462 (let ((obj (ref-fop-table (read-word-arg)))
2463 (idx (read-word-arg)))
2464 (write-memory (cold-nthcdr idx obj
) (pop-stack))))
2466 (define-cold-fop (fop-rplacd :pushp nil
)
2467 (let ((obj (ref-fop-table (read-word-arg)))
2468 (idx (read-word-arg)))
2469 (write-wordindexed (cold-nthcdr idx obj
) 1 (pop-stack))))
2471 (define-cold-fop (fop-svset :pushp nil
)
2472 (let ((obj (ref-fop-table (read-word-arg)))
2473 (idx (read-word-arg)))
2474 (write-wordindexed obj
2476 (ecase (descriptor-lowtag obj
)
2477 (#.sb
!vm
:instance-pointer-lowtag
1)
2478 (#.sb
!vm
:other-pointer-lowtag
2)))
2481 (define-cold-fop (fop-structset :pushp nil
)
2482 (let ((obj (ref-fop-table (read-word-arg)))
2483 (idx (read-word-arg)))
2484 (write-wordindexed obj
(1+ idx
) (pop-stack))))
2486 ;;; In the original CMUCL code, this actually explicitly declared PUSHP
2487 ;;; to be T, even though that's what it defaults to in DEFINE-COLD-FOP.
2488 (define-cold-fop (fop-nthcdr)
2489 (cold-nthcdr (read-word-arg) (pop-stack)))
2491 (defun cold-nthcdr (index obj
)
2493 (setq obj
(read-wordindexed obj
1)))
2496 ;;;; cold fops for loading code objects and functions
2498 ;;; the names of things which have had COLD-FSET used on them already
2499 ;;; (used to make sure that we don't try to statically link a name to
2500 ;;; more than one definition)
2501 (defparameter *cold-fset-warm-names
*
2502 ;; This can't be an EQL hash table because names can be conses, e.g.
2504 (make-hash-table :test
'equal
))
2506 (define-cold-fop (fop-fset :pushp nil
)
2507 (let* ((fn (pop-stack))
2508 (cold-name (pop-stack))
2509 (warm-name (warm-fun-name cold-name
)))
2510 (if (gethash warm-name
*cold-fset-warm-names
*)
2511 (error "duplicate COLD-FSET for ~S" warm-name
)
2512 (setf (gethash warm-name
*cold-fset-warm-names
*) t
))
2513 (static-fset cold-name fn
)))
2515 (define-cold-fop (fop-note-debug-source :pushp nil
)
2516 (let ((debug-source (pop-stack)))
2517 (cold-push debug-source
*current-debug-sources
*)))
2519 (define-cold-fop (fop-fdefinition)
2520 (cold-fdefinition-object (pop-stack)))
2523 (define-cold-fop (fop-sanctify-for-execution)
2526 ;;; Setting this variable shows what code looks like before any
2527 ;;; fixups (or function headers) are applied.
2528 #!+sb-show
(defvar *show-pre-fixup-code-p
* nil
)
2530 ;;; FIXME: The logic here should be converted into a function
2531 ;;; COLD-CODE-FOP-GUTS (NCONST CODE-SIZE) called by DEFINE-COLD-FOP
2532 ;;; FOP-CODE and DEFINE-COLD-FOP FOP-SMALL-CODE, so that
2533 ;;; variable-capture nastiness like (LET ((NCONST ,NCONST) ..) ..)
2534 ;;; doesn't keep me awake at night.
2535 (defmacro define-cold-code-fop
(name nconst code-size
)
2536 `(define-cold-fop (,name
)
2537 (let* ((nconst ,nconst
)
2538 (code-size ,code-size
)
2539 (raw-header-n-words (+ sb
!vm
:code-constants-offset nconst
))
2541 ;; Note: we round the number of constants up to ensure
2542 ;; that the code vector will be properly aligned.
2543 (round-up raw-header-n-words
2))
2544 (des (allocate-cold-descriptor *dynamic
*
2545 (+ (ash header-n-words
2548 sb
!vm
:other-pointer-lowtag
)))
2550 (make-other-immediate-descriptor
2551 header-n-words sb
!vm
:code-header-widetag
))
2552 (write-wordindexed des
2553 sb
!vm
:code-code-size-slot
2554 (make-fixnum-descriptor code-size
))
2555 (write-wordindexed des sb
!vm
:code-entry-points-slot
*nil-descriptor
*)
2556 (write-wordindexed des sb
!vm
:code-debug-info-slot
(pop-stack))
2557 (when (oddp raw-header-n-words
)
2558 (write-wordindexed des
2560 (make-random-descriptor 0)))
2561 (do ((index (1- raw-header-n-words
) (1- index
)))
2562 ((< index sb
!vm
:code-constants-offset
))
2563 (write-wordindexed des index
(pop-stack)))
2564 (let* ((start (+ (descriptor-byte-offset des
)
2565 (ash header-n-words sb
!vm
:word-shift
)))
2566 (end (+ start code-size
)))
2567 (read-bigvec-as-sequence-or-die (descriptor-bytes des
)
2572 (when *show-pre-fixup-code-p
*
2573 (format *trace-output
*
2574 "~&/raw code from code-fop ~W ~W:~%"
2577 (do ((i start
(+ i sb
!vm
:n-word-bytes
)))
2579 (format *trace-output
*
2580 "/#X~8,'0x: #X~8,'0x~%"
2581 (+ i
(gspace-byte-address (descriptor-gspace des
)))
2582 (bvref-32 (descriptor-bytes des
) i
)))))
2585 (define-cold-code-fop fop-code
(read-word-arg) (read-word-arg))
2587 (define-cold-code-fop fop-small-code
(read-byte-arg) (read-halfword-arg))
2589 (clone-cold-fop (fop-alter-code :pushp nil
)
2590 (fop-byte-alter-code)
2591 (let ((slot (clone-arg))
2594 (write-wordindexed code slot value
)))
2596 (define-cold-fop (fop-fun-entry)
2597 (let* ((info (pop-stack))
2599 (arglist (pop-stack))
2601 (code-object (pop-stack))
2602 (offset (calc-offset code-object
(read-word-arg)))
2603 (fn (descriptor-beyond code-object
2605 sb
!vm
:fun-pointer-lowtag
))
2606 (next (read-wordindexed code-object sb
!vm
:code-entry-points-slot
)))
2607 (unless (zerop (logand offset sb
!vm
:lowtag-mask
))
2608 (error "unaligned function entry: ~S at #X~X" name offset
))
2609 (write-wordindexed code-object sb
!vm
:code-entry-points-slot fn
)
2611 (make-other-immediate-descriptor
2612 (ash offset
(- sb
!vm
:word-shift
))
2613 sb
!vm
:simple-fun-header-widetag
))
2614 (write-wordindexed fn
2615 sb
!vm
:simple-fun-self-slot
2616 ;; KLUDGE: Wiring decisions like this in at
2617 ;; this level ("if it's an x86") instead of a
2618 ;; higher level of abstraction ("if it has such
2619 ;; and such relocation peculiarities (which
2620 ;; happen to be confined to the x86)") is bad.
2621 ;; It would be nice if the code were instead
2622 ;; conditional on some more descriptive
2623 ;; feature, :STICKY-CODE or
2624 ;; :LOAD-GC-INTERACTION or something.
2626 ;; FIXME: The X86 definition of the function
2627 ;; self slot breaks everything object.tex says
2628 ;; about it. (As far as I can tell, the X86
2629 ;; definition makes it a pointer to the actual
2630 ;; code instead of a pointer back to the object
2631 ;; itself.) Ask on the mailing list whether
2632 ;; this is documented somewhere, and if not,
2633 ;; try to reverse engineer some documentation.
2635 ;; a pointer back to the function object, as
2636 ;; described in CMU CL
2637 ;; src/docs/internals/object.tex
2640 ;; KLUDGE: a pointer to the actual code of the
2641 ;; object, as described nowhere that I can find
2643 (make-random-descriptor
2644 (+ (descriptor-bits fn
)
2645 (- (ash sb
!vm
:simple-fun-code-offset
2647 ;; FIXME: We should mask out the type
2648 ;; bits, not assume we know what they
2649 ;; are and subtract them out this way.
2650 sb
!vm
:fun-pointer-lowtag
))))
2651 (write-wordindexed fn sb
!vm
:simple-fun-next-slot next
)
2652 (write-wordindexed fn sb
!vm
:simple-fun-name-slot name
)
2653 (write-wordindexed fn sb
!vm
:simple-fun-arglist-slot arglist
)
2654 (write-wordindexed fn sb
!vm
:simple-fun-type-slot type
)
2655 (write-wordindexed fn sb
!vm
::simple-fun-info-slot info
)
2659 (define-cold-fop (fop-symbol-tls-fixup)
2660 (let* ((symbol (pop-stack))
2662 (code-object (pop-stack)))
2663 (do-cold-fixup code-object
(read-word-arg) (ensure-symbol-tls-index symbol
)
2667 (define-cold-fop (fop-foreign-fixup)
2668 (let* ((kind (pop-stack))
2669 (code-object (pop-stack))
2670 (len (read-byte-arg))
2671 (sym (make-string len
)))
2672 (read-string-as-bytes *fasl-input-stream
* sym
)
2674 (let ((offset (read-word-arg))
2675 (value (dyncore-note-symbol sym nil
)))
2676 (do-cold-fixup code-object offset value kind
))
2677 #!-
(and) (format t
"Bad non-plt fixup: ~S~S~%" sym code-object
)
2679 (let ((offset (read-word-arg))
2680 (value (cold-foreign-symbol-address sym
)))
2681 (do-cold-fixup code-object offset value kind
))
2685 (define-cold-fop (fop-foreign-dataref-fixup)
2686 (let* ((kind (pop-stack))
2687 (code-object (pop-stack))
2688 (len (read-byte-arg))
2689 (sym (make-string len
)))
2690 #!-sb-dynamic-core
(declare (ignore code-object
))
2691 (read-string-as-bytes *fasl-input-stream
* sym
)
2693 (let ((offset (read-word-arg))
2694 (value (dyncore-note-symbol sym t
)))
2695 (do-cold-fixup code-object offset value kind
)
2699 (maphash (lambda (k v
)
2700 (format *error-output
* "~&~S = #X~8X~%" k v
))
2701 *cold-foreign-symbol-table
*)
2702 (error "shared foreign symbol in cold load: ~S (~S)" sym kind
))))
2704 (define-cold-fop (fop-assembler-code)
2705 (let* ((length (read-word-arg))
2707 ;; Note: we round the number of constants up to ensure that
2708 ;; the code vector will be properly aligned.
2709 (round-up sb
!vm
:code-constants-offset
2))
2710 (des (allocate-cold-descriptor *read-only
*
2711 (+ (ash header-n-words
2714 sb
!vm
:other-pointer-lowtag
)))
2716 (make-other-immediate-descriptor
2717 header-n-words sb
!vm
:code-header-widetag
))
2718 (write-wordindexed des
2719 sb
!vm
:code-code-size-slot
2720 (make-fixnum-descriptor length
))
2721 (write-wordindexed des sb
!vm
:code-entry-points-slot
*nil-descriptor
*)
2722 (write-wordindexed des sb
!vm
:code-debug-info-slot
*nil-descriptor
*)
2724 (let* ((start (+ (descriptor-byte-offset des
)
2725 (ash header-n-words sb
!vm
:word-shift
)))
2726 (end (+ start length
)))
2727 (read-bigvec-as-sequence-or-die (descriptor-bytes des
)
2733 (define-cold-fop (fop-assembler-routine)
2734 (let* ((routine (pop-stack))
2736 (offset (calc-offset des
(read-word-arg))))
2737 (record-cold-assembler-routine
2739 (+ (logandc2 (descriptor-bits des
) sb
!vm
:lowtag-mask
) offset
))
2742 (define-cold-fop (fop-assembler-fixup)
2743 (let* ((routine (pop-stack))
2745 (code-object (pop-stack))
2746 (offset (read-word-arg)))
2747 (record-cold-assembler-fixup routine code-object offset kind
)
2750 (define-cold-fop (fop-code-object-fixup)
2751 (let* ((kind (pop-stack))
2752 (code-object (pop-stack))
2753 (offset (read-word-arg))
2754 (value (descriptor-bits code-object
)))
2755 (do-cold-fixup code-object offset value kind
)
2758 ;;;; sanity checking space layouts
2760 (defun check-spaces ()
2761 ;;; Co-opt type machinery to check for intersections...
2763 (flet ((check (start end space
)
2764 (unless (< start end
)
2765 (error "Bogus space: ~A" space
))
2766 (let ((type (specifier-type `(integer ,start
,end
))))
2767 (dolist (other types
)
2768 (unless (eq *empty-type
* (type-intersection (cdr other
) type
))
2769 (error "Space overlap: ~A with ~A" space
(car other
))))
2770 (push (cons space type
) types
))))
2771 (check sb
!vm
:read-only-space-start sb
!vm
:read-only-space-end
:read-only
)
2772 (check sb
!vm
:static-space-start sb
!vm
:static-space-end
:static
)
2774 (check sb
!vm
:dynamic-space-start sb
!vm
:dynamic-space-end
:dynamic
)
2777 (check sb
!vm
:dynamic-0-space-start sb
!vm
:dynamic-0-space-end
:dynamic-0
)
2778 (check sb
!vm
:dynamic-1-space-start sb
!vm
:dynamic-1-space-end
:dynamic-1
))
2780 (check sb
!vm
:linkage-table-space-start sb
!vm
:linkage-table-space-end
:linkage-table
))))
2782 ;;;; emitting C header file
2784 (defun tailwise-equal (string tail
)
2785 (and (>= (length string
) (length tail
))
2786 (string= string tail
:start1
(- (length string
) (length tail
)))))
2788 (defun write-boilerplate ()
2791 '("This is a machine-generated file. Please do not edit it by hand."
2792 "(As of sbcl-0.8.14, it came from WRITE-CONFIG-H in genesis.lisp.)"
2794 "This file contains low-level information about the"
2795 "internals of a particular version and configuration"
2796 "of SBCL. It is used by the C compiler to create a runtime"
2797 "support environment, an executable program in the host"
2798 "operating system's native format, which can then be used to"
2799 "load and run 'core' files, which are basically programs"
2800 "in SBCL's own format."))
2801 (format t
" *~@[ ~A~]~%" line
))
2804 (defun c-name (string &optional strip
)
2806 (substitute-if #\_
(lambda (c) (member c
'(#\-
#\
/ #\%
)))
2807 (remove-if (lambda (c) (position c strip
))
2810 (defun c-symbol-name (symbol &optional strip
)
2811 (c-name (symbol-name symbol
) strip
))
2813 (defun write-makefile-features ()
2814 ;; propagating *SHEBANG-FEATURES* into the Makefiles
2815 (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name
2816 sb-cold
:*shebang-features
*)
2818 (format t
"LISP_FEATURE_~A=1~%" shebang-feature-name
)))
2820 (defun write-config-h ()
2821 ;; propagating *SHEBANG-FEATURES* into C-level #define's
2822 (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name
2823 sb-cold
:*shebang-features
*)
2825 (format t
"#define LISP_FEATURE_~A~%" shebang-feature-name
))
2827 ;; and miscellaneous constants
2828 (format t
"#define SBCL_VERSION_STRING ~S~%"
2829 (sb!xc
:lisp-implementation-version
))
2830 (format t
"#define CORE_MAGIC 0x~X~%" core-magic
)
2831 (format t
"#ifndef LANGUAGE_ASSEMBLY~2%")
2832 (format t
"#define LISPOBJ(x) ((lispobj)x)~2%")
2833 (format t
"#else /* LANGUAGE_ASSEMBLY */~2%")
2834 (format t
"#define LISPOBJ(thing) thing~2%")
2835 (format t
"#endif /* LANGUAGE_ASSEMBLY */~2%")
2838 (defun write-constants-h ()
2839 ;; writing entire families of named constants
2840 (let ((constants nil
))
2841 (dolist (package-name '( ;; Even in CMU CL, constants from VM
2842 ;; were automatically propagated
2843 ;; into the runtime.
2845 ;; In SBCL, we also propagate various
2846 ;; magic numbers related to file format,
2847 ;; which live here instead of SB!VM.
2849 (do-external-symbols (symbol (find-package package-name
))
2850 (when (constantp symbol
)
2851 (let ((name (symbol-name symbol
)))
2852 (labels ( ;; shared machinery
2853 (record (string priority suffix
)
2856 (symbol-value symbol
)
2858 (documentation symbol
'variable
))
2860 ;; machinery for old-style CMU CL Lisp-to-C
2861 ;; arbitrary renaming, being phased out in favor of
2862 ;; the newer systematic RECORD-WITH-TRANSLATED-NAME
2864 (record-with-munged-name (prefix string priority
)
2865 (record (concatenate
2868 (delete #\-
(string-capitalize string
)))
2871 (maybe-record-with-munged-name (tail prefix priority
)
2872 (when (tailwise-equal name tail
)
2873 (record-with-munged-name prefix
2878 ;; machinery for new-style SBCL Lisp-to-C naming
2879 (record-with-translated-name (priority large
)
2880 (record (c-name name
) priority
2882 #!+(and win32 x86-64
) "LLU"
2883 #!-
(and win32 x86-64
) "LU"
2885 (maybe-record-with-translated-name (suffixes priority
&key large
)
2886 (when (some (lambda (suffix)
2887 (tailwise-equal name suffix
))
2889 (record-with-translated-name priority large
))))
2890 (maybe-record-with-translated-name '("-LOWTAG") 0)
2891 (maybe-record-with-translated-name '("-WIDETAG" "-SHIFT") 1)
2892 (maybe-record-with-munged-name "-FLAG" "flag_" 2)
2893 (maybe-record-with-munged-name "-TRAP" "trap_" 3)
2894 (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
2895 (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
2896 (maybe-record-with-translated-name '("-SIZE" "-INTERRUPTS") 6)
2897 (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES"
2898 "-CARD-BYTES" "-GRANULARITY")
2900 (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8)
2901 (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9)
2902 (maybe-record-with-translated-name '("-CORE-SPACE-ID-FLAG") 9)
2903 (maybe-record-with-translated-name '("-GENERATION+") 10))))))
2904 ;; KLUDGE: these constants are sort of important, but there's no
2905 ;; pleasing way to inform the code above about them. So we fake
2906 ;; it for now. nikodemus on #lisp (2004-08-09) suggested simply
2907 ;; exporting every numeric constant from SB!VM; that would work,
2908 ;; but the C runtime would have to be altered to use Lisp-like names
2909 ;; rather than the munged names currently exported. --njf, 2004-08-09
2910 (dolist (c '(sb!vm
:n-word-bits sb
!vm
:n-word-bytes
2911 sb
!vm
:n-lowtag-bits sb
!vm
:lowtag-mask
2912 sb
!vm
:n-widetag-bits sb
!vm
:widetag-mask
2913 sb
!vm
:n-fixnum-tag-bits sb
!vm
:fixnum-tag-mask
))
2914 (push (list (c-symbol-name c
)
2915 -
1 ; invent a new priority
2920 ;; One more symbol that doesn't fit into the code above.
2921 (let ((c 'sb
!impl
::+magic-hash-vector-value
+))
2922 (push (list (c-symbol-name c
)
2925 #!+(and win32 x86-64
) "LLU"
2926 #!-
(and win32 x86-64
) "LU"
2931 (lambda (const1 const2
)
2932 (if (= (second const1
) (second const2
))
2933 (if (= (third const1
) (third const2
))
2934 (string< (first const1
) (first const2
))
2935 (< (third const1
) (third const2
)))
2936 (< (second const1
) (second const2
))))))
2937 (let ((prev-priority (second (car constants
))))
2938 (dolist (const constants
)
2939 (destructuring-bind (name priority value suffix doc
) const
2940 (unless (= prev-priority priority
)
2942 (setf prev-priority priority
))
2943 (when (minusp value
)
2944 (error "stub: negative values unsupported"))
2945 (format t
"#define ~A ~A~A /* 0x~X ~@[ -- ~A ~]*/~%" name value suffix value doc
))))
2948 ;; writing information about internal errors
2949 ;; Assembly code needs only the constants for UNDEFINED_[ALIEN_]FUN_ERROR
2950 ;; but to avoid imparting that knowledge here, we'll expose all error
2951 ;; number constants except for OBJECT-NOT-<x>-ERROR ones.
2952 (loop for interr across sb
!c
:*backend-internal-errors
*
2954 when
(stringp (car interr
))
2955 do
(format t
"#define ~A ~D~%" (c-symbol-name (cdr interr
)) i
))
2956 ;; C code needs strings for describe_internal_error()
2957 (format t
"#define INTERNAL_ERROR_NAMES ~{\\~%~S~^, ~}~2%"
2958 (map 'list
'sb
!kernel
::!c-stringify-internal-error
2959 sb
!c
:*backend-internal-errors
*))
2961 ;; I'm not really sure why this is in SB!C, since it seems
2962 ;; conceptually like something that belongs to SB!VM. In any case,
2963 ;; it's needed C-side.
2964 (format t
"#define BACKEND_PAGE_BYTES ~DLU~%" sb
!c
:*backend-page-bytes
*)
2968 ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between
2969 ;; platforms. If we export this from the SB!VM package, it gets
2970 ;; written out as #define trap_PseudoAtomic, which is confusing as
2971 ;; the runtime treats trap_ as the prefix for illegal instruction
2972 ;; type things. We therefore don't export it, but instead do
2974 (when (boundp 'sb
!vm
::pseudo-atomic-trap
)
2976 "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%"
2977 sb
!vm
::pseudo-atomic-trap
)
2979 ;; possibly this is another candidate for a rename (to
2980 ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
2981 ;; [possibly applicable to other platforms])
2984 (format t
"#define GC_SAFEPOINT_PAGE_ADDR ((void*)0x~XUL) /* ~:*~A */~%"
2985 sb
!vm
:gc-safepoint-page-addr
)
2987 (dolist (symbol '(sb!vm
::float-traps-byte
2988 sb
!vm
::float-exceptions-byte
2989 sb
!vm
::float-sticky-bits
2990 sb
!vm
::float-rounding-mode
))
2991 (format t
"#define ~A_POSITION ~A /* ~:*0x~X */~%"
2992 (c-symbol-name symbol
)
2993 (sb!xc
:byte-position
(symbol-value symbol
)))
2994 (format t
"#define ~A_MASK 0x~X /* ~:*~A */~%"
2995 (c-symbol-name symbol
)
2996 (sb!xc
:mask-field
(symbol-value symbol
) -
1))))
2999 (defun write-tagnames-h (&optional
(out *standard-output
*))
3001 ((pretty-name (symbol strip
)
3002 (let ((name (string-downcase symbol
)))
3003 (substitute #\Space
#\-
3004 (subseq name
0 (- (length name
) (length strip
))))))
3005 (list-sorted-tags (tail)
3006 (loop for symbol being the external-symbols of
"SB!VM"
3007 when
(and (constantp symbol
)
3008 (tailwise-equal (string symbol
) tail
))
3009 collect symbol into tags
3010 finally
(return (sort tags
#'< :key
#'symbol-value
))))
3011 (write-tags (kind limit ash-count
)
3012 (format out
"~%static const char *~(~A~)_names[] = {~%"
3014 (let ((tags (list-sorted-tags kind
)))
3016 (if (eql i
(ash (or (symbol-value (first tags
)) -
1) ash-count
))
3017 (format out
" \"~A\"" (pretty-name (pop tags
) kind
))
3018 (format out
" \"unknown [~D]\"" i
))
3019 (unless (eql i
(1- limit
))
3020 (write-string "," out
))
3022 (write-line "};" out
)))
3023 (write-tags "-LOWTAG" sb
!vm
:lowtag-limit
0)
3024 ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG
3025 ;; ending with the same 2 bits. (#b10)
3026 (write-tags "-WIDETAG" (ash (1+ sb
!vm
:widetag-mask
) -
2) -
2))
3029 (defun write-primitive-object (obj)
3030 ;; writing primitive object layouts
3031 (format t
"#ifndef LANGUAGE_ASSEMBLY~2%")
3034 (c-name (string-downcase (string (sb!vm
:primitive-object-name obj
)))))
3035 (when (sb!vm
:primitive-object-widetag obj
)
3036 (format t
" lispobj header;~%"))
3037 (dolist (slot (sb!vm
:primitive-object-slots obj
))
3038 (format t
" ~A ~A~@[[1]~];~%"
3039 (getf (sb!vm
:slot-options slot
) :c-type
"lispobj")
3040 (c-name (string-downcase (string (sb!vm
:slot-name slot
))))
3041 (sb!vm
:slot-rest-p slot
)))
3043 (format t
"#else /* LANGUAGE_ASSEMBLY */~2%")
3044 (format t
"/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%")
3045 (format t
" * so they work directly on tagged addresses. */~2%")
3046 (let ((name (sb!vm
:primitive-object-name obj
))
3047 (lowtag (or (symbol-value (sb!vm
:primitive-object-lowtag obj
))
3049 (dolist (slot (sb!vm
:primitive-object-slots obj
))
3050 (format t
"#define ~A_~A_OFFSET ~D~%"
3051 (c-symbol-name name
)
3052 (c-symbol-name (sb!vm
:slot-name slot
))
3053 (- (* (sb!vm
:slot-offset slot
) sb
!vm
:n-word-bytes
) lowtag
)))
3055 (format t
"#endif /* LANGUAGE_ASSEMBLY */~2%"))
3057 (defun write-structure-object (dd)
3058 (flet ((cstring (designator)
3059 (c-name (string-downcase (string designator
)))))
3060 (format t
"#ifndef LANGUAGE_ASSEMBLY~2%")
3061 (format t
"struct ~A {~%" (cstring (dd-name dd
)))
3062 (format t
" lispobj header;~%")
3063 (format t
" lispobj layout;~%")
3064 (dolist (slot (dd-slots dd
))
3065 (when (eq t
(dsd-raw-type slot
))
3066 (format t
" lispobj ~A;~%" (cstring (dsd-name slot
)))))
3067 (unless (oddp (+ (dd-length dd
) (dd-raw-length dd
)))
3068 (format t
" lispobj raw_slot_padding;~%"))
3069 (dotimes (n (dd-raw-length dd
))
3070 (format t
" lispobj raw~D;~%" (- (dd-raw-length dd
) n
1)))
3072 (format t
"#endif /* LANGUAGE_ASSEMBLY */~2%")))
3074 (defun write-static-symbols ()
3075 (dolist (symbol (cons nil sb
!vm
:*static-symbols
*))
3076 ;; FIXME: It would be nice to use longer names than NIL and
3077 ;; (particularly) T in #define statements.
3078 (format t
"#define ~A LISPOBJ(0x~X)~%"
3079 ;; FIXME: It would be nice not to need to strip anything
3080 ;; that doesn't get stripped always by C-SYMBOL-NAME.
3081 (c-symbol-name symbol
"%*.!")
3082 (if *static
* ; if we ran GENESIS
3083 ;; We actually ran GENESIS, use the real value.
3084 (descriptor-bits (cold-intern symbol
))
3085 ;; We didn't run GENESIS, so guess at the address.
3086 (+ sb
!vm
:static-space-start
3088 sb
!vm
:other-pointer-lowtag
3089 (if symbol
(sb!vm
:static-symbol-offset symbol
) 0))))))
3092 ;;;; writing map file
3094 ;;; Write a map file describing the cold load. Some of this
3095 ;;; information is subject to change due to relocating GC, but even so
3096 ;;; it can be very handy when attempting to troubleshoot the early
3097 ;;; stages of cold load.
3099 (let ((*print-pretty
* nil
)
3100 (*print-case
* :upcase
))
3101 (format t
"assembler routines defined in core image:~2%")
3102 (dolist (routine (sort (copy-list *cold-assembler-routines
*) #'<
3104 (format t
"#X~8,'0X: ~S~%" (cdr routine
) (car routine
)))
3107 (maphash (lambda (name fdefn
)
3108 (let ((fun (read-wordindexed fdefn
3109 sb
!vm
:fdefn-fun-slot
)))
3110 (if (= (descriptor-bits fun
)
3111 (descriptor-bits *nil-descriptor
*))
3113 (let ((addr (read-wordindexed
3114 fdefn sb
!vm
:fdefn-raw-addr-slot
)))
3115 (push (cons name
(descriptor-bits addr
))
3117 *cold-fdefn-objects
*)
3118 (format t
"~%~|~%initially defined functions:~2%")
3119 (setf funs
(sort funs
#'< :key
#'cdr
))
3121 (format t
"0x~8,'0X: ~S #X~8,'0X~%" (cdr info
) (car info
)
3122 (- (cdr info
) #x17
)))
3125 (a note about initially undefined function references: These functions
3126 are referred to by code which is installed by GENESIS, but they are not
3127 installed by GENESIS. This is not necessarily a problem; functions can
3128 be defined later, by cold init toplevel forms, or in files compiled and
3129 loaded at warm init, or elsewhere. As long as they are defined before
3130 they are called, everything should be OK. Things are also OK if the
3131 cross-compiler knew their inline definition and used that everywhere
3132 that they were called before the out-of-line definition is installed,
3133 as is fairly common for structure accessors.)
3134 initially undefined function references:~2%")
3136 (setf undefs
(sort undefs
#'string
< :key
#'fun-name-block-name
))
3137 (dolist (name undefs
)
3138 (format t
"~8,'0X: ~S~%"
3139 (descriptor-bits (gethash name
*cold-fdefn-objects
*))
3142 (format t
"~%~|~%layout names:~2%")
3144 (maphash (lambda (name gorp
)
3145 (declare (ignore name
))
3146 (stuff (cons (descriptor-bits (car gorp
))
3149 (dolist (x (sort (stuff) #'< :key
#'car
))
3150 (apply #'format t
"~8,'0X: ~S[~D]~%~10T~S~%" x
))))
3154 ;;;; writing core file
3156 (defvar *core-file
*)
3157 (defvar *data-page
*)
3159 ;;; magic numbers to identify entries in a core file
3161 ;;; (In case you were wondering: No, AFAIK there's no special magic about
3162 ;;; these which requires them to be in the 38xx range. They're just
3163 ;;; arbitrary words, tested not for being in a particular range but just
3164 ;;; for equality. However, if you ever need to look at a .core file and
3165 ;;; figure out what's going on, it's slightly convenient that they're
3166 ;;; all in an easily recognizable range, and displacing the range away from
3167 ;;; zero seems likely to reduce the chance that random garbage will be
3168 ;;; misinterpreted as a .core file.)
3169 (defconstant build-id-core-entry-type-code
3860)
3170 (defconstant new-directory-core-entry-type-code
3861)
3171 (defconstant initial-fun-core-entry-type-code
3863)
3172 (defconstant page-table-core-entry-type-code
3880)
3173 (defconstant end-core-entry-type-code
3840)
3175 (declaim (ftype (function (sb!vm
:word
) sb
!vm
:word
) write-word
))
3176 (defun write-word (num)
3177 (ecase sb
!c
:*backend-byte-order
*
3179 (dotimes (i sb
!vm
:n-word-bytes
)
3180 (write-byte (ldb (byte 8 (* i
8)) num
) *core-file
*)))
3182 (dotimes (i sb
!vm
:n-word-bytes
)
3183 (write-byte (ldb (byte 8 (* (- (1- sb
!vm
:n-word-bytes
) i
) 8)) num
)
3187 (defun advance-to-page ()
3188 (force-output *core-file
*)
3189 (file-position *core-file
*
3190 (round-up (file-position *core-file
*)
3191 sb
!c
:*backend-page-bytes
*)))
3193 (defun output-gspace (gspace)
3194 (force-output *core-file
*)
3195 (let* ((posn (file-position *core-file
*))
3196 (bytes (* (gspace-free-word-index gspace
) sb
!vm
:n-word-bytes
))
3197 (pages (ceiling bytes sb
!c
:*backend-page-bytes
*))
3198 (total-bytes (* pages sb
!c
:*backend-page-bytes
*)))
3200 (file-position *core-file
*
3201 (* sb
!c
:*backend-page-bytes
* (1+ *data-page
*)))
3203 "writing ~S byte~:P [~S page~:P] from ~S~%"
3209 ;; Note: It is assumed that the GSPACE allocation routines always
3210 ;; allocate whole pages (of size *target-page-size*) and that any
3211 ;; empty gspace between the free pointer and the end of page will
3212 ;; be zero-filled. This will always be true under Mach on machines
3213 ;; where the page size is equal. (RT is 4K, PMAX is 4K, Sun 3 is
3215 (write-bigvec-as-sequence (gspace-bytes gspace
)
3219 (force-output *core-file
*)
3220 (file-position *core-file
* posn
)
3222 ;; Write part of a (new) directory entry which looks like this:
3223 ;; GSPACE IDENTIFIER
3228 (write-word (gspace-identifier gspace
))
3229 (write-word (gspace-free-word-index gspace
))
3230 (write-word *data-page
*)
3231 (multiple-value-bind (floor rem
)
3232 (floor (gspace-byte-address gspace
) sb
!c
:*backend-page-bytes
*)
3237 (incf *data-page
* pages
)))
3239 ;;; Create a core file created from the cold loaded image. (This is
3240 ;;; the "initial core file" because core files could be created later
3241 ;;; by executing SAVE-LISP in a running system, perhaps after we've
3242 ;;; added some functionality to the system.)
3243 (declaim (ftype (function (string)) write-initial-core-file
))
3244 (defun write-initial-core-file (filename)
3246 (let ((filenamestring (namestring filename
))
3250 "[building initial core file in ~S: ~%"
3254 (with-open-file (*core-file
* filenamestring
3256 :element-type
'(unsigned-byte 8)
3257 :if-exists
:rename-and-delete
)
3259 ;; Write the magic number.
3260 (write-word core-magic
)
3262 ;; Write the build ID.
3263 (write-word build-id-core-entry-type-code
)
3264 (let ((build-id (with-open-file (s "output/build-id.tmp")
3266 (declare (type simple-string build-id
))
3267 (/show build-id
(length build-id
))
3268 ;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE
3269 ;; word, this length word, and one word for each char of BUILD-ID.
3270 (write-word (+ 2 (length build-id
)))
3271 (dovector (char build-id
)
3272 ;; (We write each character as a word in order to avoid
3273 ;; having to think about word alignment issues in the
3274 ;; sbcl-0.7.8 version of coreparse.c.)
3275 (write-word (sb!xc
:char-code char
))))
3277 ;; Write the New Directory entry header.
3278 (write-word new-directory-core-entry-type-code
)
3279 (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header.
3281 (output-gspace *read-only
*)
3282 (output-gspace *static
*)
3283 (output-gspace *dynamic
*)
3285 ;; Write the initial function.
3286 (write-word initial-fun-core-entry-type-code
)
3288 (let* ((cold-name (cold-intern '!cold-init
))
3289 (cold-fdefn (cold-fdefinition-object cold-name
))
3290 (initial-fun (read-wordindexed cold-fdefn
3291 sb
!vm
:fdefn-fun-slot
)))
3293 "~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%"
3294 (descriptor-bits initial-fun
))
3295 (write-word (descriptor-bits initial-fun
)))
3297 ;; Write the End entry.
3298 (write-word end-core-entry-type-code
)
3301 (format t
"done]~%")
3303 (/show
"leaving WRITE-INITIAL-CORE-FILE")
3306 ;;;; the actual GENESIS function
3308 ;;; Read the FASL files in OBJECT-FILE-NAMES and produce a Lisp core,
3309 ;;; and/or information about a Lisp core, therefrom.
3311 ;;; input file arguments:
3312 ;;; SYMBOL-TABLE-FILE-NAME names a UNIX-style .nm file *with* *any*
3313 ;;; *tab* *characters* *converted* *to* *spaces*. (We push
3314 ;;; responsibility for removing tabs out to the caller it's
3315 ;;; trivial to remove them using UNIX command line tools like
3316 ;;; sed, whereas it's a headache to do it portably in Lisp because
3317 ;;; #\TAB is not a STANDARD-CHAR.) If this file is not supplied,
3318 ;;; a core file cannot be built (but a C header file can be).
3320 ;;; output files arguments (any of which may be NIL to suppress output):
3321 ;;; CORE-FILE-NAME gets a Lisp core.
3322 ;;; C-HEADER-FILE-NAME gets a C header file, traditionally called
3323 ;;; internals.h, which is used by the C compiler when constructing
3324 ;;; the executable which will load the core.
3325 ;;; MAP-FILE-NAME gets (?) a map file. (dunno about this -- WHN 19990815)
3327 ;;; FIXME: GENESIS doesn't belong in SB!VM. Perhaps in %KERNEL for now,
3328 ;;; perhaps eventually in SB-LD or SB-BOOT.
3329 (defun sb!vm
:genesis
(&key
3331 symbol-table-file-name
3335 #+nil
(list-objects t
))
3337 (declare (ignorable symbol-table-file-name
))
3340 "~&beginning GENESIS, ~A~%"
3342 ;; Note: This output summarizing what we're doing is
3343 ;; somewhat telegraphic in style, not meant to imply that
3344 ;; we're not e.g. also creating a header file when we
3346 (format nil
"creating core ~S" core-file-name
)
3347 (format nil
"creating headers in ~S" c-header-dir-name
)))
3349 (let ((*cold-foreign-symbol-table
* (make-hash-table :test
'equal
)))
3352 (when core-file-name
3353 (if symbol-table-file-name
3354 (load-cold-foreign-symbol-table symbol-table-file-name
)
3355 (error "can't output a core file without symbol table file input")))
3359 (setf (gethash (extern-alien-name "undefined_tramp")
3360 *cold-foreign-symbol-table
*)
3361 (dyncore-note-symbol "undefined_tramp" nil
))
3362 (dyncore-note-symbol "undefined_alien_function" nil
))
3364 ;; Now that we've successfully read our only input file (by
3365 ;; loading the symbol table, if any), it's a good time to ensure
3366 ;; that there'll be someplace for our output files to go when
3368 (flet ((frob (filename)
3370 (ensure-directories-exist filename
:verbose t
))))
3371 (frob core-file-name
)
3372 (frob map-file-name
))
3374 ;; (This shouldn't matter in normal use, since GENESIS normally
3375 ;; only runs once in any given Lisp image, but it could reduce
3376 ;; confusion if we ever experiment with running, tweaking, and
3377 ;; rerunning genesis interactively.)
3378 (do-all-symbols (sym)
3379 (remprop sym
'cold-intern-info
))
3383 (let* ((*foreign-symbol-placeholder-value
* (if core-file-name nil
0))
3384 (*load-time-value-counter
* 0)
3385 (*cold-fdefn-objects
* (make-hash-table :test
'equal
))
3386 (*cold-symbols
* (make-hash-table :test
'eql
)) ; integer keys
3387 (*cold-package-symbols
* (make-hash-table :test
'equal
)) ; string keys
3388 (pkg-metadata (sb-cold:read-from-file
"package-data-list.lisp-expr"))
3389 (*read-only
* (make-gspace :read-only
3390 read-only-core-space-id
3391 sb
!vm
:read-only-space-start
))
3392 (*static
* (make-gspace :static
3393 static-core-space-id
3394 sb
!vm
:static-space-start
))
3395 (*dynamic
* (make-gspace :dynamic
3396 dynamic-core-space-id
3397 #!+gencgc sb
!vm
:dynamic-space-start
3398 #!-gencgc sb
!vm
:dynamic-0-space-start
))
3399 ;; There's a cyclic dependency here: NIL refers to a package;
3400 ;; a package needs its layout which needs others layouts
3401 ;; which refer to NIL, which refers to a package ...
3402 ;; Break the cycle by preallocating packages without a layout.
3403 ;; This avoids having to track any symbols created prior to
3404 ;; creation of packages, since packages are primordial.
3406 (dolist (name (list* "COMMON-LISP" "COMMON-LISP-USER" "KEYWORD"
3407 (mapcar #'sb-cold
:package-data-name
3409 (gethash "COMMON-LISP" *cold-package-symbols
*))
3410 (setf (gethash name
*cold-package-symbols
*)
3411 (cons (allocate-structure-object
3412 *dynamic
* (layout-length (find-layout 'package
))
3413 (make-fixnum-descriptor 0))
3414 (cons nil nil
))))) ; (externals . internals)
3415 (*nil-descriptor
* (make-nil-descriptor target-cl-pkg-info
))
3416 (*current-reversed-cold-toplevels
* *nil-descriptor
*)
3417 (*current-debug-sources
* *nil-descriptor
*)
3418 (*unbound-marker
* (make-other-immediate-descriptor
3420 sb
!vm
:unbound-marker-widetag
))
3421 *cold-assembler-fixups
*
3422 *cold-assembler-routines
*
3423 #!+x86
(*load-time-code-fixups
* (make-hash-table)))
3425 ;; Prepare for cold load.
3426 (initialize-non-nil-symbols)
3427 (initialize-layouts)
3428 (initialize-packages
3429 ;; docstrings are set in src/cold/warm. It would work to do it here,
3430 ;; but seems preferable not to saddle Genesis with such responsibility.
3431 (list* (sb-cold:make-package-data
:name
"COMMON-LISP" :doc nil
)
3432 (sb-cold:make-package-data
:name
"KEYWORD" :doc nil
)
3433 (sb-cold:make-package-data
:name
"COMMON-LISP-USER" :doc nil
3434 :use
'("COMMON-LISP"
3435 ;; ANSI encourages us to put extension packages
3436 ;; in the USE list of COMMON-LISP-USER.
3437 "SB!ALIEN" "SB!DEBUG" "SB!EXT" "SB!GRAY" "SB!PROFILE"))
3439 (initialize-static-fns)
3441 ;; Initialize the *COLD-SYMBOLS* system with the information
3442 ;; from common-lisp-exports.lisp-expr.
3443 ;; Packages whose names match SB!THING were set up on the host according
3444 ;; to "package-data-list.lisp-expr" which expresses the desired target
3445 ;; package configuration, so we can just mirror the host into the target.
3446 ;; But by waiting to observe calls to COLD-INTERN that occur during the
3447 ;; loading of the cross-compiler's outputs, it is possible to rid the
3448 ;; target of accidental leftover symbols, not that it wouldn't also be
3449 ;; a good idea to clean up package-data-list once in a while.
3450 (dolist (exported-name
3451 (sb-cold:read-from-file
"common-lisp-exports.lisp-expr"))
3452 (cold-intern (intern exported-name
*cl-package
*) :access
:external
))
3455 (dolist (file-name object-file-names
)
3456 (write-line (namestring file-name
))
3457 (cold-load file-name
))
3459 ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
3460 (resolve-assembler-fixups)
3461 #!+x86
(output-load-time-code-fixups)
3462 (foreign-symbols-to-core)
3464 (/show
"back from FINISH-SYMBOLS")
3465 (finalize-load-time-value-noise)
3467 ;; Tell the target Lisp how much stuff we've allocated.
3468 (cold-set 'sb
!vm
:*read-only-space-free-pointer
*
3469 (allocate-cold-descriptor *read-only
*
3471 sb
!vm
:even-fixnum-lowtag
))
3472 (cold-set 'sb
!vm
:*static-space-free-pointer
*
3473 (allocate-cold-descriptor *static
*
3475 sb
!vm
:even-fixnum-lowtag
))
3476 (/show
"done setting free pointers")
3478 ;; Write results to files.
3480 ;; FIXME: I dislike this approach of redefining
3481 ;; *STANDARD-OUTPUT* instead of putting the new stream in a
3482 ;; lexical variable, and it's annoying to have WRITE-MAP (to
3483 ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE
3484 ;; (to a stream explicitly passed as an argument).
3485 (macrolet ((out-to (name &body body
)
3486 `(let ((fn (format nil
"~A/~A.h" c-header-dir-name
,name
)))
3487 (ensure-directories-exist fn
)
3488 (with-open-file (*standard-output
* fn
3489 :if-exists
:supersede
:direction
:output
)
3491 (let ((n (c-name (string-upcase ,name
))))
3494 "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"
3498 "#endif /* SBCL_GENESIS_~A */~%"
3499 (string-upcase ,name
))))))
3501 (with-open-file (*standard-output
* map-file-name
3503 :if-exists
:supersede
)
3505 (out-to "config" (write-config-h))
3506 (out-to "constants" (write-constants-h))
3508 (out-to "tagnames" (write-tagnames-h))
3509 (let ((structs (sort (copy-list sb
!vm
:*primitive-objects
*) #'string
<
3512 (sb!vm
:primitive-object-name obj
))))))
3513 (dolist (obj structs
)
3515 (string-downcase (string (sb!vm
:primitive-object-name obj
)))
3516 (write-primitive-object obj
)))
3517 (out-to "primitive-objects"
3518 (dolist (obj structs
)
3519 (format t
"~&#include \"~A.h\"~%"
3521 (string (sb!vm
:primitive-object-name obj
)))))))
3522 (dolist (class '(hash-table
3524 sb
!c
::compiled-debug-info
3525 sb
!c
::compiled-debug-fun
3528 (string-downcase (string class
))
3529 (write-structure-object
3530 (layout-info (find-layout class
)))))
3531 (out-to "static-symbols" (write-static-symbols))
3533 (let ((fn (format nil
"~A/Makefile.features" c-header-dir-name
)))
3534 (ensure-directories-exist fn
)
3535 (with-open-file (*standard-output
* fn
:if-exists
:supersede
3537 (write-makefile-features)))
3539 (when core-file-name
3540 (write-initial-core-file core-file-name
))))))