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