Allow bignum raw slot bitmap in genesis.
[sbcl.git] / src / compiler / generic / genesis.lisp
blob6e1a40158a9769e9b351c6e2045095e6c5100fb8
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.)
20 ;;;; This software is part of the SBCL system. See the README file for
21 ;;;; more information.
22 ;;;;
23 ;;;; This software is derived from the CMU CL system, which was
24 ;;;; written at Carnegie Mellon University and released into the
25 ;;;; public domain. The software is in the public domain and is
26 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
27 ;;;; files for more information.
29 (in-package "SB!FASL")
31 ;;; a magic number used to identify our core files
32 (defconstant core-magic
33 (logior (ash (sb!xc:char-code #\S) 24)
34 (ash (sb!xc:char-code #\B) 16)
35 (ash (sb!xc:char-code #\C) 8)
36 (sb!xc:char-code #\L)))
38 (defun round-up (number size)
39 "Round NUMBER up to be an integral multiple of SIZE."
40 (* size (ceiling number size)))
42 ;;;; implementing the concept of "vector" in (almost) portable
43 ;;;; Common Lisp
44 ;;;;
45 ;;;; "If you only need to do such simple things, it doesn't really
46 ;;;; matter which language you use." -- _ANSI Common Lisp_, p. 1, Paul
47 ;;;; Graham (evidently not considering the abstraction "vector" to be
48 ;;;; such a simple thing:-)
50 (eval-when (:compile-toplevel :load-toplevel :execute)
51 (defconstant +smallvec-length+
52 (expt 2 16)))
54 ;;; an element of a BIGVEC -- a vector small enough that we have
55 ;;; a good chance of it being portable to other Common Lisps
56 (deftype smallvec ()
57 `(simple-array (unsigned-byte 8) (,+smallvec-length+)))
59 (defun make-smallvec ()
60 (make-array +smallvec-length+ :element-type '(unsigned-byte 8)
61 :initial-element 0))
63 ;;; a big vector, implemented as a vector of SMALLVECs
64 ;;;
65 ;;; KLUDGE: This implementation seems portable enough for our
66 ;;; purposes, since realistically every modern implementation is
67 ;;; likely to support vectors of at least 2^16 elements. But if you're
68 ;;; masochistic enough to read this far into the contortions imposed
69 ;;; on us by ANSI and the Lisp community, for daring to use the
70 ;;; abstraction of a large linearly addressable memory space, which is
71 ;;; after all only directly supported by the underlying hardware of at
72 ;;; least 99% of the general-purpose computers in use today, then you
73 ;;; may be titillated to hear that in fact this code isn't really
74 ;;; portable, because as of sbcl-0.7.4 we need somewhat more than
75 ;;; 16Mbytes to represent a core, and ANSI only guarantees that
76 ;;; ARRAY-DIMENSION-LIMIT is not less than 1024. -- WHN 2002-06-13
77 (defstruct bigvec
78 (outer-vector (vector (make-smallvec)) :type (vector smallvec)))
80 ;;; analogous to SVREF, but into a BIGVEC
81 (defun bvref (bigvec index)
82 (multiple-value-bind (outer-index inner-index)
83 (floor index +smallvec-length+)
84 (aref (the smallvec
85 (svref (bigvec-outer-vector bigvec) outer-index))
86 inner-index)))
87 (defun (setf bvref) (new-value bigvec index)
88 (multiple-value-bind (outer-index inner-index)
89 (floor index +smallvec-length+)
90 (setf (aref (the smallvec
91 (svref (bigvec-outer-vector bigvec) outer-index))
92 inner-index)
93 new-value)))
95 ;;; analogous to LENGTH, but for a BIGVEC
96 ;;;
97 ;;; the length of BIGVEC, measured in the number of BVREFable bytes it
98 ;;; can hold
99 (defun bvlength (bigvec)
100 (* (length (bigvec-outer-vector bigvec))
101 +smallvec-length+))
103 ;;; analogous to WRITE-SEQUENCE, but for a BIGVEC
104 (defun write-bigvec-as-sequence (bigvec stream &key (start 0) end pad-with-zeros)
105 (let* ((bvlength (bvlength bigvec))
106 (data-length (min (or end bvlength) bvlength)))
107 (loop for i of-type index from start below data-length do
108 (write-byte (bvref bigvec i)
109 stream))
110 (when (and pad-with-zeros (< bvlength data-length))
111 (loop repeat (- data-length bvlength) do (write-byte 0 stream)))))
113 ;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC
114 (defun read-bigvec-as-sequence-or-die (bigvec stream &key (start 0) end)
115 (loop for i of-type index from start below (or end (bvlength bigvec)) do
116 (setf (bvref bigvec i)
117 (read-byte stream))))
119 ;;; Grow BIGVEC (exponentially, so that large increases in size have
120 ;;; asymptotic logarithmic cost per byte).
121 (defun expand-bigvec (bigvec)
122 (let* ((old-outer-vector (bigvec-outer-vector bigvec))
123 (length-old-outer-vector (length old-outer-vector))
124 (new-outer-vector (make-array (* 2 length-old-outer-vector))))
125 (dotimes (i length-old-outer-vector)
126 (setf (svref new-outer-vector i)
127 (svref old-outer-vector i)))
128 (loop for i from length-old-outer-vector below (length new-outer-vector) do
129 (setf (svref new-outer-vector i)
130 (make-smallvec)))
131 (setf (bigvec-outer-vector bigvec)
132 new-outer-vector))
133 bigvec)
135 ;;;; looking up bytes and multi-byte values in a BIGVEC (considering
136 ;;;; it as an image of machine memory on the cross-compilation target)
138 ;;; BVREF-32 and friends. These are like SAP-REF-n, except that
139 ;;; instead of a SAP we use a BIGVEC.
140 (macrolet ((make-bvref-n
142 (let* ((name (intern (format nil "BVREF-~A" n)))
143 (number-octets (/ n 8))
144 (ash-list-le
145 (loop for i from 0 to (1- number-octets)
146 collect `(ash (bvref bigvec (+ byte-index ,i))
147 ,(* i 8))))
148 (ash-list-be
149 (loop for i from 0 to (1- number-octets)
150 collect `(ash (bvref bigvec
151 (+ byte-index
152 ,(- number-octets 1 i)))
153 ,(* i 8))))
154 (setf-list-le
155 (loop for i from 0 to (1- number-octets)
156 append
157 `((bvref bigvec (+ byte-index ,i))
158 (ldb (byte 8 ,(* i 8)) new-value))))
159 (setf-list-be
160 (loop for i from 0 to (1- number-octets)
161 append
162 `((bvref bigvec (+ byte-index ,i))
163 (ldb (byte 8 ,(- n 8 (* i 8))) new-value)))))
164 `(progn
165 (defun ,name (bigvec byte-index)
166 (logior ,@(ecase sb!c:*backend-byte-order*
167 (:little-endian ash-list-le)
168 (:big-endian ash-list-be))))
169 (defun (setf ,name) (new-value bigvec byte-index)
170 (setf ,@(ecase sb!c:*backend-byte-order*
171 (:little-endian setf-list-le)
172 (:big-endian setf-list-be))))))))
173 (make-bvref-n 8)
174 (make-bvref-n 16)
175 (make-bvref-n 32)
176 (make-bvref-n 64))
178 ;; lispobj-sized word, whatever that may be
179 ;; hopefully nobody ever wants a 128-bit SBCL...
180 #!+64-bit
181 (progn
182 (defun bvref-word (bytes index)
183 (bvref-64 bytes index))
184 (defun (setf bvref-word) (new-val bytes index)
185 (setf (bvref-64 bytes index) new-val)))
187 #!-64-bit
188 (progn
189 (defun bvref-word (bytes index)
190 (bvref-32 bytes index))
191 (defun (setf bvref-word) (new-val bytes index)
192 (setf (bvref-32 bytes index) new-val)))
195 ;;;; representation of spaces in the core
197 ;;; If there is more than one dynamic space in memory (i.e., if a
198 ;;; copying GC is in use), then only the active dynamic space gets
199 ;;; dumped to core.
200 (defvar *dynamic*)
201 (defconstant dynamic-core-space-id 1)
203 (defvar *static*)
204 (defconstant static-core-space-id 2)
206 (defvar *read-only*)
207 (defconstant read-only-core-space-id 3)
209 (defconstant max-core-space-id 3)
210 (defconstant deflated-core-space-id-flag 4)
212 ;; This is somewhat arbitrary as there is no concept of the the
213 ;; number of bits in the "low" part of a descriptor any more.
214 (defconstant target-space-alignment (ash 1 16)
215 "the alignment requirement for spaces in the target.")
217 ;;; a GENESIS-time representation of a memory space (e.g. read-only
218 ;;; space, dynamic space, or static space)
219 (defstruct (gspace (:constructor %make-gspace)
220 (:copier nil))
221 ;; name and identifier for this GSPACE
222 (name (missing-arg) :type symbol :read-only t)
223 (identifier (missing-arg) :type fixnum :read-only t)
224 ;; the word address where the data will be loaded
225 (word-address (missing-arg) :type unsigned-byte :read-only t)
226 ;; the data themselves. (Note that in CMU CL this was a pair of
227 ;; fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
228 ;; (And then in SBCL this was a VECTOR, but turned out to be
229 ;; unportable too, since ANSI doesn't think that arrays longer than
230 ;; 1024 (!) should needed by portable CL code...)
231 (bytes (make-bigvec) :read-only t)
232 ;; the index of the next unwritten word (i.e. chunk of
233 ;; SB!VM:N-WORD-BYTES bytes) in BYTES, or equivalently the number of
234 ;; words actually written in BYTES. In order to convert to an actual
235 ;; index into BYTES, thus must be multiplied by SB!VM:N-WORD-BYTES.
236 (free-word-index 0))
238 (defun gspace-byte-address (gspace)
239 (ash (gspace-word-address gspace) sb!vm:word-shift))
241 (cl:defmethod print-object ((gspace gspace) stream)
242 (print-unreadable-object (gspace stream :type t)
243 (format stream "~S" (gspace-name gspace))))
245 (defun make-gspace (name identifier byte-address)
246 (unless (zerop (rem byte-address target-space-alignment))
247 (error "The byte address #X~X is not aligned on a #X~X-byte boundary."
248 byte-address
249 target-space-alignment))
250 (%make-gspace :name name
251 :identifier identifier
252 :word-address (ash byte-address (- sb!vm:word-shift))))
254 ;;;; representation of descriptors
256 (declaim (inline is-fixnum-lowtag))
257 (defun is-fixnum-lowtag (lowtag)
258 (zerop (logand lowtag sb!vm:fixnum-tag-mask)))
260 (defun is-other-immediate-lowtag (lowtag)
261 ;; The other-immediate lowtags are similar to the fixnum lowtags, in
262 ;; that they have an "effective length" that is shorter than is used
263 ;; for the pointer lowtags. Unlike the fixnum lowtags, however, the
264 ;; other-immediate lowtags are always effectively two bits wide.
265 (= (logand lowtag 3) sb!vm:other-immediate-0-lowtag))
267 (defstruct (descriptor
268 (:constructor make-descriptor (bits &optional gspace word-offset))
269 (:copier nil))
270 ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
271 (gspace nil :type (or gspace (eql :load-time-value) null))
272 ;; the offset in words from the start of GSPACE, or NIL if not set yet
273 (word-offset nil :type (or sb!vm:word null))
274 (bits 0 :read-only t :type (unsigned-byte #.sb!vm:n-machine-word-bits)))
276 (declaim (inline descriptor=))
277 (defun descriptor= (a b) (eql (descriptor-bits a) (descriptor-bits b)))
279 ;; FIXME: most uses of MAKE-RANDOM-DESCRIPTOR are abuses for writing a raw word
280 ;; into target memory as if it were a descriptor, because there is no variant
281 ;; of WRITE-WORDINDEXED taking a non-descriptor value.
282 ;; As an intermediary step, perhaps this should be renamed to MAKE-RAW-BITS.
283 (defun make-random-descriptor (bits)
284 (make-descriptor (logand bits sb!ext:most-positive-word)))
286 (declaim (inline descriptor-lowtag))
287 (defun descriptor-lowtag (des)
288 "the lowtag bits for DES"
289 (logand (descriptor-bits des) sb!vm:lowtag-mask))
291 (cl:defmethod print-object ((des descriptor) stream)
292 (let ((lowtag (descriptor-lowtag des)))
293 (print-unreadable-object (des stream :type t)
294 (cond ((eq (descriptor-gspace des) :load-time-value)
295 (format stream "for LTV ~D" (descriptor-word-offset des)))
296 ((is-fixnum-lowtag lowtag)
297 (format stream "for fixnum: ~W" (descriptor-fixnum des)))
298 ((is-other-immediate-lowtag lowtag)
299 (format stream
300 "for other immediate: #X~X, type #b~8,'0B"
301 (ash (descriptor-bits des) (- sb!vm:n-widetag-bits))
302 (logand (descriptor-bits des) sb!vm:widetag-mask)))
304 (format stream
305 "for pointer: #X~X, lowtag #b~v,'0B, ~A"
306 (logandc2 (descriptor-bits des) sb!vm:lowtag-mask)
307 sb!vm:n-lowtag-bits lowtag
308 (let ((gspace (descriptor-gspace des)))
309 (if gspace
310 (gspace-name gspace)
311 "unknown"))))))))
313 ;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The
314 ;;; free word index is boosted as necessary, and if additional memory
315 ;;; is needed, we grow the GSPACE. The descriptor returned is a
316 ;;; pointer of type LOWTAG.
317 (defun allocate-cold-descriptor (gspace length lowtag)
318 (let* ((bytes (round-up length (ash 1 sb!vm:n-lowtag-bits)))
319 (old-free-word-index (gspace-free-word-index gspace))
320 (new-free-word-index (+ old-free-word-index
321 (ash bytes (- sb!vm:word-shift)))))
322 ;; Grow GSPACE as necessary until it's big enough to handle
323 ;; NEW-FREE-WORD-INDEX.
324 (do ()
325 ((>= (bvlength (gspace-bytes gspace))
326 (* new-free-word-index sb!vm:n-word-bytes)))
327 (expand-bigvec (gspace-bytes gspace)))
328 ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it.
329 (setf (gspace-free-word-index gspace) new-free-word-index)
330 (let ((ptr (+ (gspace-word-address gspace) old-free-word-index)))
331 (make-descriptor (logior (ash ptr sb!vm:word-shift) lowtag)
332 gspace
333 old-free-word-index))))
335 (defun descriptor-fixnum (des)
336 (unless (is-fixnum-lowtag (descriptor-lowtag des))
337 (error "descriptor-fixnum called on non-fixnum ~S" des))
338 (let* ((descriptor-bits (descriptor-bits des))
339 (bits (ash descriptor-bits (- sb!vm:n-fixnum-tag-bits))))
340 (if (logbitp (1- sb!vm:n-word-bits) descriptor-bits)
341 (logior bits (ash -1 (1+ sb!vm:n-positive-fixnum-bits)))
342 bits)))
344 (defun descriptor-word-sized-integer (des)
345 ;; Extract an (unsigned-byte 32), from either its fixnum or bignum
346 ;; representation.
347 (let ((lowtag (descriptor-lowtag des)))
348 (if (is-fixnum-lowtag lowtag)
349 (make-random-descriptor (descriptor-fixnum des))
350 (read-wordindexed des 1))))
352 ;;; common idioms
353 (defun descriptor-bytes (des)
354 (gspace-bytes (descriptor-intuit-gspace des)))
355 (defun descriptor-byte-offset (des)
356 (ash (descriptor-word-offset des) sb!vm:word-shift))
358 ;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise,
359 ;;; figure out a GSPACE which corresponds to DES, set it into
360 ;;; (DESCRIPTOR-GSPACE DES), set a consistent value into
361 ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
362 (declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace))
363 (defun descriptor-intuit-gspace (des)
364 (or (descriptor-gspace des)
366 ;; gspace wasn't set, now we have to search for it.
367 (let* ((lowtag (descriptor-lowtag des))
368 (abs-word-addr (ash (- (descriptor-bits des) lowtag)
369 (- sb!vm:word-shift))))
371 ;; Non-pointer objects don't have a gspace.
372 (unless (or (eql lowtag sb!vm:fun-pointer-lowtag)
373 (eql lowtag sb!vm:instance-pointer-lowtag)
374 (eql lowtag sb!vm:list-pointer-lowtag)
375 (eql lowtag sb!vm:other-pointer-lowtag))
376 (error "don't even know how to look for a GSPACE for ~S" des))
378 (dolist (gspace (list *dynamic* *static* *read-only*)
379 (error "couldn't find a GSPACE for ~S" des))
380 ;; Bounds-check the descriptor against the allocated area
381 ;; within each gspace.
382 (when (and (<= (gspace-word-address gspace)
383 abs-word-addr
384 (+ (gspace-word-address gspace)
385 (gspace-free-word-index gspace))))
386 ;; Update the descriptor with the correct gspace and the
387 ;; offset within the gspace and return the gspace.
388 (setf (descriptor-word-offset des)
389 (- abs-word-addr (gspace-word-address gspace)))
390 (return (setf (descriptor-gspace des) gspace)))))))
392 (defun %fixnum-descriptor-if-possible (num)
393 (and (typep num '(signed-byte #.sb!vm:n-fixnum-bits))
394 (make-random-descriptor (ash num sb!vm:n-fixnum-tag-bits))))
396 (defun make-fixnum-descriptor (num)
397 (or (%fixnum-descriptor-if-possible num)
398 (error "~W is too big for a fixnum." num)))
400 (defun make-other-immediate-descriptor (data type)
401 (make-descriptor (logior (ash data sb!vm:n-widetag-bits) type)))
403 (defun make-character-descriptor (data)
404 (make-other-immediate-descriptor data sb!vm:character-widetag))
406 (defun descriptor-beyond (des offset lowtag)
407 ;; OFFSET is in bytes and relative to the descriptor as a native pointer,
408 ;; not the tagged address. Then we slap on a new lowtag.
409 (make-descriptor
410 (logior (+ offset (logandc2 (descriptor-bits des) sb!vm:lowtag-mask))
411 lowtag)))
413 ;;;; miscellaneous variables and other noise
415 ;;; a numeric value to be returned for undefined foreign symbols, or NIL if
416 ;;; undefined foreign symbols are to be treated as an error.
417 ;;; (In the first pass of GENESIS, needed to create a header file before
418 ;;; the C runtime can be built, various foreign symbols will necessarily
419 ;;; be undefined, but we don't need actual values for them anyway, and
420 ;;; we can just use 0 or some other placeholder. In the second pass of
421 ;;; GENESIS, all foreign symbols should be defined, so any undefined
422 ;;; foreign symbol is a problem.)
424 ;;; KLUDGE: It would probably be cleaner to rewrite GENESIS so that it
425 ;;; never tries to look up foreign symbols in the first place unless
426 ;;; it's actually creating a core file (as in the second pass) instead
427 ;;; of using this hack to allow it to go through the motions without
428 ;;; causing an error. -- WHN 20000825
429 (defvar *foreign-symbol-placeholder-value*)
431 ;;; a handle on the trap object
432 (defvar *unbound-marker*)
433 ;; was: (make-other-immediate-descriptor 0 sb!vm:unbound-marker-widetag)
435 ;;; a handle on the NIL object
436 (defvar *nil-descriptor*)
438 ;;; the head of a list of TOPLEVEL-THINGs describing stuff to be done
439 ;;; when the target Lisp starts up
441 ;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or
442 ;;; loadtime value, represented by (CONS KEYWORD ..).
443 (declaim (special *!cold-toplevels* *!cold-defconstants* *!cold-defuns*))
445 ;;; the head of a list of DEBUG-SOURCEs which need to be patched when
446 ;;; the cold core starts up
447 (defvar *current-debug-sources*)
449 ;;; foreign symbol references
450 (defparameter *cold-foreign-undefined-symbols* nil)
452 ;;;; miscellaneous stuff to read and write the core memory
454 ;;; FIXME: should be DEFINE-MODIFY-MACRO
455 (defmacro cold-push (thing list) ; for making a target list held in a host symbol
456 "Push THING onto the given cold-load LIST."
457 `(setq ,list (cold-cons ,thing ,list)))
459 ;; Like above, but the list is held in the target's image of the host symbol,
460 ;; not the host's value of the symbol.
461 (defun cold-target-push (cold-thing host-symbol)
462 (cold-set host-symbol (cold-cons cold-thing (cold-symbol-value host-symbol))))
464 (declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed))
465 (macrolet ((read-bits ()
466 `(bvref-word (descriptor-bytes address)
467 (ash (+ index (descriptor-word-offset address))
468 sb!vm:word-shift))))
469 (defun read-bits-wordindexed (address index)
470 (read-bits))
471 (defun read-wordindexed (address index)
472 "Return the value which is displaced by INDEX words from ADDRESS."
473 (make-random-descriptor (read-bits))))
475 (declaim (ftype (function (descriptor) descriptor) read-memory))
476 (defun read-memory (address)
477 "Return the value at ADDRESS."
478 (read-wordindexed address 0))
480 (declaim (ftype (function (descriptor
481 (integer #.(- sb!vm:list-pointer-lowtag)
482 #.sb!ext:most-positive-word)
483 descriptor)
484 (values))
485 note-load-time-value-reference))
486 (defun note-load-time-value-reference (address offset marker)
487 (push (cold-list (cold-intern :load-time-value-fixup)
488 address
489 (number-to-core offset)
490 (number-to-core (descriptor-word-offset marker)))
491 *!cold-toplevels*)
492 (values))
494 (declaim (ftype (function (descriptor sb!vm:word (or symbol descriptor))) write-wordindexed))
495 (defun write-wordindexed (address index value)
496 "Write VALUE displaced INDEX words from ADDRESS."
497 ;; If we're passed a symbol as a value then it needs to be interned.
498 (let ((value (cond ((symbolp value) (cold-intern value))
499 (t value))))
500 (if (eql (descriptor-gspace value) :load-time-value)
501 (note-load-time-value-reference address
502 (- (ash index sb!vm:word-shift)
503 (logand (descriptor-bits address)
504 sb!vm:lowtag-mask))
505 value)
506 (let* ((bytes (descriptor-bytes address))
507 (byte-index (ash (+ index (descriptor-word-offset address))
508 sb!vm:word-shift)))
509 (setf (bvref-word bytes byte-index) (descriptor-bits value))))))
511 (declaim (ftype (function (descriptor (or symbol descriptor))) write-memory))
512 (defun write-memory (address value)
513 "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
514 (write-wordindexed address 0 value))
516 ;;;; allocating images of primitive objects in the cold core
518 (defun write-header-word (des header-data widetag)
519 (write-memory des (make-other-immediate-descriptor header-data widetag)))
521 ;;; There are three kinds of blocks of memory in the type system:
522 ;;; * Boxed objects (cons cells, structures, etc): These objects have no
523 ;;; header as all slots are descriptors.
524 ;;; * Unboxed objects (bignums): There is a single header word that contains
525 ;;; the length.
526 ;;; * Vector objects: There is a header word with the type, then a word for
527 ;;; the length, then the data.
528 (defun allocate-object (gspace length lowtag)
529 "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
530 pointing to them."
531 (allocate-cold-descriptor gspace (ash length sb!vm:word-shift) lowtag))
532 (defun allocate-header+object (gspace length widetag)
533 "Allocate LENGTH words plus a header word in GSPACE and
534 return an ``other-pointer'' descriptor to them. Initialize the header word
535 with the resultant length and WIDETAG."
536 (let ((des (allocate-cold-descriptor gspace
537 (ash (1+ length) sb!vm:word-shift)
538 sb!vm:other-pointer-lowtag)))
539 (write-header-word des length widetag)
540 des))
541 (defun allocate-vector-object (gspace element-bits length widetag)
542 "Allocate LENGTH units of ELEMENT-BITS size plus a header plus a length slot in
543 GSPACE and return an ``other-pointer'' descriptor to them. Initialize the
544 header word with WIDETAG and the length slot with LENGTH."
545 ;; ALLOCATE-COLD-DESCRIPTOR will take any rational number of bytes
546 ;; and round up to a double-word. This doesn't need to use CEILING.
547 (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits))
548 (des (allocate-cold-descriptor gspace
549 (+ bytes (* 2 sb!vm:n-word-bytes))
550 sb!vm:other-pointer-lowtag)))
551 (write-header-word des 0 widetag)
552 (write-wordindexed des
553 sb!vm:vector-length-slot
554 (make-fixnum-descriptor length))
555 des))
557 ;;; the hosts's representation of LAYOUT-of-LAYOUT
558 (eval-when (:compile-toplevel :load-toplevel :execute)
559 (defvar *host-layout-of-layout* (find-layout 'layout)))
561 (defun cold-layout-length (layout)
562 (descriptor-fixnum (read-slot layout *host-layout-of-layout* :length)))
564 ;; Make a structure and set the header word and layout.
565 ;; LAYOUT-LENGTH is as returned by the like-named function.
566 (defun allocate-struct
567 (gspace layout &optional (layout-length (cold-layout-length layout)))
568 ;; The math in here is best illustrated by two examples:
569 ;; even: size 4 => request to allocate 5 => rounds up to 6, logior => 5
570 ;; odd : size 5 => request to allocate 6 => no rounding up, logior => 5
571 ;; In each case, the length of the memory block is even.
572 ;; ALLOCATE-OBJECT performs the rounding. It must be supplied
573 ;; the number of words minimally needed, counting the header itself.
574 ;; The number written into the header (%INSTANCE-LENGTH) is always odd.
575 (let ((des (allocate-object gspace (1+ layout-length)
576 sb!vm:instance-pointer-lowtag)))
577 (write-header-word des (logior layout-length 1)
578 sb!vm:instance-header-widetag)
579 (write-wordindexed des sb!vm:instance-slots-offset layout)
580 des))
582 ;;;; copying simple objects into the cold core
584 (defun base-string-to-core (string &optional (gspace *dynamic*))
585 "Copy STRING (which must only contain STANDARD-CHARs) into the cold
586 core and return a descriptor to it."
587 ;; (Remember that the system convention for storage of strings leaves an
588 ;; extra null byte at the end to aid in call-out to C.)
589 (let* ((length (length string))
590 (des (allocate-vector-object gspace
591 sb!vm:n-byte-bits
592 (1+ length)
593 sb!vm:simple-base-string-widetag))
594 (bytes (gspace-bytes gspace))
595 (offset (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
596 (descriptor-byte-offset des))))
597 (write-wordindexed des
598 sb!vm:vector-length-slot
599 (make-fixnum-descriptor length))
600 (dotimes (i length)
601 (setf (bvref bytes (+ offset i))
602 (sb!xc:char-code (aref string i))))
603 (setf (bvref bytes (+ offset length))
604 0) ; null string-termination character for C
605 des))
607 (defun base-string-from-core (descriptor)
608 (let* ((len (descriptor-fixnum
609 (read-wordindexed descriptor sb!vm:vector-length-slot)))
610 (str (make-string len))
611 (bytes (descriptor-bytes descriptor)))
612 (dotimes (i len str)
613 (setf (aref str i)
614 (code-char (bvref bytes
615 (+ (descriptor-byte-offset descriptor)
616 (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
617 i)))))))
619 (defun bignum-to-core (n)
620 "Copy a bignum to the cold core."
621 (let* ((words (ceiling (1+ (integer-length n)) sb!vm:n-word-bits))
622 (handle
623 (allocate-header+object *dynamic* words sb!vm:bignum-widetag)))
624 (declare (fixnum words))
625 (do ((index 1 (1+ index))
626 (remainder n (ash remainder (- sb!vm:n-word-bits))))
627 ((> index words)
628 (unless (zerop (integer-length remainder))
629 ;; FIXME: Shouldn't this be a fatal error?
630 (warn "~W words of ~W were written, but ~W bits were left over."
631 words n remainder)))
632 ;; FIXME: this is disgusting. there should be WRITE-BITS-WORDINDEXED.
633 (write-wordindexed handle index
634 (make-random-descriptor
635 (ldb (byte sb!vm:n-word-bits 0) remainder))))
636 handle))
638 (defun bignum-from-core (descriptor)
639 (let ((n-words (ash (descriptor-bits (read-memory descriptor))
640 (- sb!vm:n-widetag-bits)))
641 (val 0))
642 (dotimes (i n-words val)
643 (let ((bits (read-bits-wordindexed descriptor
644 (+ i sb!vm:bignum-digits-offset))))
645 ;; sign-extend the highest word
646 (when (and (= i (1- n-words)) (logbitp (1- sb!vm:n-word-bits) bits))
647 (setq bits (dpb bits (byte sb!vm:n-word-bits 0) -1)))
648 (setq val (logior (ash bits (* i sb!vm:n-word-bits)) val))))))
650 (defun number-pair-to-core (first second type)
651 "Makes a number pair of TYPE (ratio or complex) and fills it in."
652 (let ((des (allocate-header+object *dynamic* 2 type)))
653 (write-wordindexed des 1 first)
654 (write-wordindexed des 2 second)
655 des))
657 (defun write-double-float-bits (address index x)
658 (let ((hi (double-float-high-bits x))
659 (lo (double-float-low-bits x)))
660 (ecase sb!vm::n-word-bits
662 ;; As noted in BIGNUM-TO-CORE, this idiom is unclear - the things
663 ;; aren't descriptors. Same for COMPLEX-foo-TO-CORE
664 (let ((high-bits (make-random-descriptor hi))
665 (low-bits (make-random-descriptor lo)))
666 (ecase sb!c:*backend-byte-order*
667 (:little-endian
668 (write-wordindexed address index low-bits)
669 (write-wordindexed address (1+ index) high-bits))
670 (:big-endian
671 (write-wordindexed address index high-bits)
672 (write-wordindexed address (1+ index) low-bits)))))
674 (let ((bits (make-random-descriptor
675 (ecase sb!c:*backend-byte-order*
676 (:little-endian (logior lo (ash hi 32)))
677 ;; Just guessing.
678 #+nil (:big-endian (logior (logand hi #xffffffff)
679 (ash lo 32)))))))
680 (write-wordindexed address index bits))))
681 address))
683 (defun float-to-core (x)
684 (etypecase x
685 (single-float
686 ;; 64-bit platforms have immediate single-floats.
687 #!+64-bit
688 (make-random-descriptor (logior (ash (single-float-bits x) 32)
689 sb!vm::single-float-widetag))
690 #!-64-bit
691 (let ((des (allocate-header+object *dynamic*
692 (1- sb!vm:single-float-size)
693 sb!vm:single-float-widetag)))
694 (write-wordindexed des
695 sb!vm:single-float-value-slot
696 (make-random-descriptor (single-float-bits x)))
697 des))
698 (double-float
699 (let ((des (allocate-header+object *dynamic*
700 (1- sb!vm:double-float-size)
701 sb!vm:double-float-widetag)))
702 (write-double-float-bits des sb!vm:double-float-value-slot x)))))
704 (defun complex-single-float-to-core (num)
705 (declare (type (complex single-float) num))
706 (let ((des (allocate-header+object *dynamic*
707 (1- sb!vm:complex-single-float-size)
708 sb!vm:complex-single-float-widetag)))
709 #!-64-bit
710 (progn
711 (write-wordindexed des sb!vm:complex-single-float-real-slot
712 (make-random-descriptor (single-float-bits (realpart num))))
713 (write-wordindexed des sb!vm:complex-single-float-imag-slot
714 (make-random-descriptor (single-float-bits (imagpart num)))))
715 #!+64-bit
716 (write-wordindexed des sb!vm:complex-single-float-data-slot
717 (make-random-descriptor
718 (logior (ldb (byte 32 0) (single-float-bits (realpart num)))
719 (ash (single-float-bits (imagpart num)) 32))))
720 des))
722 (defun complex-double-float-to-core (num)
723 (declare (type (complex double-float) num))
724 (let ((des (allocate-header+object *dynamic*
725 (1- sb!vm:complex-double-float-size)
726 sb!vm:complex-double-float-widetag)))
727 (write-double-float-bits des sb!vm:complex-double-float-real-slot
728 (realpart num))
729 (write-double-float-bits des sb!vm:complex-double-float-imag-slot
730 (imagpart num))))
732 ;;; Copy the given number to the core.
733 (defun number-to-core (number)
734 (typecase number
735 (integer (or (%fixnum-descriptor-if-possible number)
736 (bignum-to-core number)))
737 (ratio (number-pair-to-core (number-to-core (numerator number))
738 (number-to-core (denominator number))
739 sb!vm:ratio-widetag))
740 ((complex single-float) (complex-single-float-to-core number))
741 ((complex double-float) (complex-double-float-to-core number))
742 #!+long-float
743 ((complex long-float)
744 (error "~S isn't a cold-loadable number at all!" number))
745 (complex (number-pair-to-core (number-to-core (realpart number))
746 (number-to-core (imagpart number))
747 sb!vm:complex-widetag))
748 (float (float-to-core number))
749 (t (error "~S isn't a cold-loadable number at all!" number))))
751 (declaim (ftype (function (sb!vm:word) descriptor) sap-int-to-core))
752 (defun sap-int-to-core (sap-int)
753 (let ((des (allocate-header+object *dynamic* (1- sb!vm:sap-size)
754 sb!vm:sap-widetag)))
755 (write-wordindexed des
756 sb!vm:sap-pointer-slot
757 (make-random-descriptor sap-int))
758 des))
760 ;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
761 (defun cold-cons (car cdr &optional (gspace *dynamic*))
762 (let ((dest (allocate-object gspace 2 sb!vm:list-pointer-lowtag)))
763 (write-wordindexed dest sb!vm:cons-car-slot car)
764 (write-wordindexed dest sb!vm:cons-cdr-slot cdr)
765 dest))
766 (defun list-to-core (list)
767 (let ((head *nil-descriptor*)
768 (tail nil))
769 ;; A recursive algorithm would have the first cons at the highest
770 ;; address. This way looks nicer when viewed in ldb.
771 (loop
772 (unless list (return head))
773 (let ((cons (cold-cons (pop list) *nil-descriptor*)))
774 (if tail (cold-rplacd tail cons) (setq head cons))
775 (setq tail cons)))))
776 (defun cold-list (&rest args) (list-to-core args))
777 (defun cold-list-length (list) ; but no circularity detection
778 ;; a recursive implementation uses too much stack for some Lisps
779 (let ((n 0))
780 (loop (if (cold-null list) (return n))
781 (incf n)
782 (setq list (cold-cdr list)))))
784 ;;; Make a simple-vector on the target that holds the specified
785 ;;; OBJECTS, and return its descriptor.
786 ;;; This is really "vectorify-list-into-core" but that's too wordy,
787 ;;; so historically it was "vector-in-core" which is a fine name.
788 (defun vector-in-core (objects &optional (gspace *dynamic*))
789 (let* ((size (length objects))
790 (result (allocate-vector-object gspace sb!vm:n-word-bits size
791 sb!vm:simple-vector-widetag)))
792 (dotimes (index size)
793 (write-wordindexed result (+ index sb!vm:vector-data-offset)
794 (pop objects)))
795 result))
796 (defun cold-svset (vector index value)
797 (let ((i (if (integerp index) index (descriptor-fixnum index))))
798 (write-wordindexed vector (+ i sb!vm:vector-data-offset) value)))
800 (setf (get 'vector :sb-cold-funcall-handler/for-value)
801 (lambda (&rest args) (vector-in-core args)))
803 (declaim (inline cold-vector-len cold-svref))
804 (defun cold-vector-len (vector)
805 (descriptor-fixnum (read-wordindexed vector sb!vm:vector-length-slot)))
806 (defun cold-svref (vector i)
807 (read-wordindexed vector (+ (if (integerp i) i (descriptor-fixnum i))
808 sb!vm:vector-data-offset)))
809 (defun cold-vector-elements-eq (a b)
810 (and (eql (cold-vector-len a) (cold-vector-len b))
811 (dotimes (k (cold-vector-len a) t)
812 (unless (descriptor= (cold-svref a k) (cold-svref b k))
813 (return nil)))))
814 (defun vector-from-core (descriptor &optional (transform #'identity))
815 (let* ((len (cold-vector-len descriptor))
816 (vector (make-array len)))
817 (dotimes (i len vector)
818 (setf (aref vector i) (funcall transform (cold-svref descriptor i))))))
820 ;;;; symbol magic
822 ;; Simulate *FREE-TLS-INDEX*. This is a count, not a displacement.
823 ;; In C, sizeof counts 1 word for the variable-length interrupt_contexts[]
824 ;; but primitive-object-size counts 0, so add 1, though in fact the C code
825 ;; implies that it might have overcounted by 1. We could make this agnostic
826 ;; of MAX-INTERRUPTS by moving the thread base register up by TLS-SIZE words,
827 ;; using negative offsets for all dynamically assigned indices.
828 (defvar *genesis-tls-counter*
829 (+ 1 sb!vm::max-interrupts
830 (sb!vm:primitive-object-size
831 (find 'sb!vm::thread sb!vm:*primitive-objects*
832 :key #'sb!vm:primitive-object-name))))
834 #!+sb-thread
835 (progn
836 ;; Assign SYMBOL the tls-index INDEX. SYMBOL must be a descriptor.
837 ;; This is a backend support routine, but the style within this file
838 ;; is to conditionalize by the target features.
839 (defun cold-assign-tls-index (symbol index)
840 #!+64-bit
841 (let ((header-word
842 (logior (ash index 32)
843 (descriptor-bits (read-memory symbol)))))
844 (write-wordindexed symbol 0 (make-random-descriptor header-word)))
845 #!-64-bit
846 (write-wordindexed symbol sb!vm:symbol-tls-index-slot
847 (make-random-descriptor index)))
849 ;; Return SYMBOL's tls-index,
850 ;; choosing a new index if it doesn't have one yet.
851 (defun ensure-symbol-tls-index (symbol)
852 (let* ((cold-sym (cold-intern symbol))
853 (tls-index
854 #!+64-bit
855 (ldb (byte 32 32) (descriptor-bits (read-memory cold-sym)))
856 #!-64-bit
857 (descriptor-bits
858 (read-wordindexed cold-sym sb!vm:symbol-tls-index-slot))))
859 (unless (plusp tls-index)
860 (let ((next (prog1 *genesis-tls-counter* (incf *genesis-tls-counter*))))
861 (setq tls-index (ash next sb!vm:word-shift))
862 (cold-assign-tls-index cold-sym tls-index)))
863 tls-index)))
865 ;; A table of special variable names which get known TLS indices.
866 ;; Some of them are mapped onto 'struct thread' and have pre-determined offsets.
867 ;; Others are static symbols used with bind_variable() in the C runtime,
868 ;; and might not, in the absence of this table, get an index assigned by genesis
869 ;; depending on whether the cross-compiler used the BIND vop on them.
870 ;; Indices for those static symbols can be chosen arbitrarily, which is to say
871 ;; the value doesn't matter but must update the tls-counter correctly.
872 ;; All symbols other than the ones in this table get the indices assigned
873 ;; by the fasloader on demand.
874 #!+sb-thread
875 (defvar *known-tls-symbols*
876 ;; FIXME: no mechanism exists to determine which static symbols C code will
877 ;; dynamically bind. TLS is a finite resource, and wasting indices for all
878 ;; static symbols isn't the best idea. This list was hand-made with 'grep'.
879 '(sb!vm:*alloc-signal*
880 sb!sys:*allow-with-interrupts*
881 sb!vm:*current-catch-block*
882 sb!vm::*current-unwind-protect-block*
883 sb!kernel:*free-interrupt-context-index*
884 sb!kernel:*gc-inhibit*
885 sb!kernel:*gc-pending*
886 sb!impl::*gc-safe*
887 sb!impl::*in-safepoint*
888 sb!sys:*interrupt-pending*
889 sb!sys:*interrupts-enabled*
890 sb!vm::*pinned-objects*
891 sb!kernel:*restart-clusters*
892 sb!kernel:*stop-for-gc-pending*
893 #!+sb-thruption
894 sb!sys:*thruption-pending*))
896 ;;; Symbol print names are coalesced by string=.
897 ;;; This is valid because it is an error to modify a print name.
898 (defvar *symbol-name-strings* (make-hash-table :test 'equal))
900 ;;; Allocate (and initialize) a symbol.
901 (defun allocate-symbol (name &key (gspace *dynamic*))
902 (declare (simple-string name))
903 (let ((symbol (allocate-header+object gspace (1- sb!vm:symbol-size)
904 sb!vm:symbol-header-widetag)))
905 (write-wordindexed symbol sb!vm:symbol-value-slot *unbound-marker*)
906 (write-wordindexed symbol sb!vm:symbol-hash-slot (make-fixnum-descriptor 0))
907 (write-wordindexed symbol sb!vm:symbol-info-slot *nil-descriptor*)
908 (write-wordindexed symbol sb!vm:symbol-name-slot
909 (or (gethash name *symbol-name-strings*)
910 (setf (gethash name *symbol-name-strings*)
911 (base-string-to-core name *dynamic*))))
912 (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
913 symbol))
915 #!+sb-thread
916 (defun assign-tls-index (symbol cold-symbol)
917 (let ((index (info :variable :wired-tls symbol)))
918 (cond ((integerp index) ; thread slot
919 (cold-assign-tls-index cold-symbol index))
920 ((memq symbol *known-tls-symbols*)
921 ;; symbols without which the C runtime could not start
922 (shiftf index *genesis-tls-counter* (1+ *genesis-tls-counter*))
923 (cold-assign-tls-index cold-symbol (ash index sb!vm:word-shift))))))
925 ;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a
926 ;;; descriptor of a cold symbol or (in an abbreviation for the
927 ;;; most common usage pattern) an ordinary symbol, which will be
928 ;;; automatically cold-interned.
929 (declaim (ftype (function ((or symbol descriptor) descriptor)) cold-set))
930 (defun cold-set (symbol-or-symbol-des value)
931 (let ((symbol-des (etypecase symbol-or-symbol-des
932 (descriptor symbol-or-symbol-des)
933 (symbol (cold-intern symbol-or-symbol-des)))))
934 (write-wordindexed symbol-des sb!vm:symbol-value-slot value)))
935 (defun cold-symbol-value (symbol)
936 (let ((val (read-wordindexed (cold-intern symbol) sb!vm:symbol-value-slot)))
937 (if (= (descriptor-bits val) sb!vm:unbound-marker-widetag)
938 (unbound-cold-symbol-handler symbol)
939 val)))
940 (defun cold-fdefn-fun (cold-fdefn)
941 (read-wordindexed cold-fdefn sb!vm:fdefn-fun-slot))
943 (defun unbound-cold-symbol-handler (symbol)
944 (let ((host-val (and (boundp symbol) (symbol-value symbol))))
945 (if (typep host-val 'sb!kernel:named-type)
946 (let ((target-val (ctype-to-core (sb!kernel:named-type-name host-val)
947 host-val)))
948 ;; Though it looks complicated to assign cold symbols on demand,
949 ;; it avoids writing code to build the layout of NAMED-TYPE in the
950 ;; way we build other primordial stuff such as layout-of-layout.
951 (cold-set symbol target-val)
952 target-val)
953 (error "Taking Cold-symbol-value of unbound symbol ~S" symbol))))
955 ;;;; layouts and type system pre-initialization
957 ;;; Since we want to be able to dump structure constants and
958 ;;; predicates with reference layouts, we need to create layouts at
959 ;;; cold-load time. We use the name to intern layouts by, and dump a
960 ;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system
961 ;;; initialization can find them. The only thing that's tricky [sic --
962 ;;; WHN 19990816] is initializing layout's layout, which must point to
963 ;;; itself.
965 ;;; a map from name as a host symbol to the descriptor of its target layout
966 (defvar *cold-layouts* (make-hash-table :test 'equal))
968 ;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting
969 ;;; mapping
970 (defvar *cold-layout-names* (make-hash-table :test 'eql))
972 ;;; FIXME: *COLD-LAYOUTS* and *COLD-LAYOUT-NAMES* should be
973 ;;; initialized by binding in GENESIS.
975 ;;; the descriptor for layout's layout (needed when making layouts)
976 (defvar *layout-layout*)
977 ;;; the descriptor for PACKAGE's layout (needed when making packages)
978 (defvar *package-layout*)
980 (defvar *known-structure-classoids*)
982 (defconstant target-layout-length
983 ;; LAYOUT-LENGTH counts the number of words in an instance,
984 ;; including the layout itself as 1 word
985 (layout-length *host-layout-of-layout*))
987 ;;; Return a list of names created from the cold layout INHERITS data
988 ;;; in X.
989 (defun listify-cold-inherits (x)
990 (map 'list (lambda (des)
991 (or (gethash (descriptor-bits des) *cold-layout-names*)
992 (error "~S is not the descriptor of a cold-layout" des)))
993 (vector-from-core x)))
995 ;;; COLD-DD-SLOTS is a cold descriptor for the list of slots
996 ;;; in a cold defstruct-description. INDEX is a DSD-INDEX.
997 ;;; Return the host's accessor name for the host image of that slot.
998 (defun dsd-accessor-from-cold-slots (cold-dd-slots desired-index)
999 (let* ((dsd-slots (dd-slots
1000 (find-defstruct-description 'defstruct-slot-description)))
1001 (index-slot
1002 (dsd-index (find 'sb!kernel::index dsd-slots :key #'dsd-name)))
1003 (accessor-fun-name-slot
1004 (dsd-index (find 'sb!kernel::accessor-name dsd-slots :key #'dsd-name))))
1005 (do ((list cold-dd-slots (cold-cdr list)))
1006 ((cold-null list))
1007 (when (= (descriptor-fixnum
1008 (read-wordindexed (cold-car list)
1009 (+ sb!vm:instance-slots-offset index-slot)))
1010 desired-index)
1011 (return
1012 (warm-symbol
1013 (read-wordindexed (cold-car list)
1014 (+ sb!vm:instance-slots-offset
1015 accessor-fun-name-slot))))))))
1017 (flet ((get-slots (host-layout-or-type)
1018 (etypecase host-layout-or-type
1019 (layout (dd-slots (layout-info host-layout-or-type)))
1020 (symbol (dd-slots-from-core host-layout-or-type))))
1021 (get-slot-index (slots initarg)
1022 (+ sb!vm:instance-slots-offset
1023 (if (descriptor-p slots)
1024 (do ((dsd-layout (find-layout 'defstruct-slot-description))
1025 (slots slots (cold-cdr slots)))
1026 ((cold-null slots) (error "No slot for ~S" initarg))
1027 (let* ((dsd (cold-car slots))
1028 (slot-name (read-slot dsd dsd-layout :name)))
1029 (when (eq (keywordicate (warm-symbol slot-name)) initarg)
1030 ;; Untagged slots are not accessible during cold-load
1031 (aver (eql (descriptor-fixnum
1032 (read-slot dsd dsd-layout :%raw-type)) -1))
1033 (return (descriptor-fixnum
1034 (read-slot dsd dsd-layout :index))))))
1035 (let ((dsd (find initarg slots
1036 :test (lambda (x y)
1037 (eq x (keywordicate (dsd-name y)))))))
1038 (aver (eq (dsd-raw-type dsd) t)) ; Same as above: no can do.
1039 (dsd-index dsd))))))
1040 (defun write-slots (cold-object host-layout-or-type &rest assignments)
1041 (aver (evenp (length assignments)))
1042 (let ((slots (get-slots host-layout-or-type)))
1043 (loop for (initarg value) on assignments by #'cddr
1044 do (write-wordindexed
1045 cold-object (get-slot-index slots initarg) value)))
1046 cold-object)
1048 ;; For symmetry, the reader takes an initarg, not a slot name.
1049 (defun read-slot (cold-object host-layout-or-type slot-initarg)
1050 (let ((slots (get-slots host-layout-or-type)))
1051 (read-wordindexed cold-object (get-slot-index slots slot-initarg)))))
1053 ;; Given a TYPE-NAME of a structure-class, find its defstruct-description
1054 ;; as a target descriptor, and return the slot list as a target descriptor.
1055 (defun dd-slots-from-core (type-name)
1056 (let* ((host-dd-layout (find-layout 'defstruct-description))
1057 (target-dd
1058 ;; This is inefficient, but not enough so to worry about.
1059 (or (car (assoc (cold-intern type-name) *known-structure-classoids*
1060 :key (lambda (x) (read-slot x host-dd-layout :name))
1061 :test #'descriptor=))
1062 (error "No known layout for ~S" type-name))))
1063 (read-slot target-dd host-dd-layout :slots)))
1065 (defvar *simple-vector-0-descriptor*)
1066 (defvar *vacuous-slot-table*)
1067 (declaim (ftype (function (symbol descriptor descriptor descriptor descriptor)
1068 descriptor)
1069 make-cold-layout))
1070 (defun make-cold-layout (name length inherits depthoid metadata)
1071 (let ((result (allocate-struct *dynamic* *layout-layout*
1072 target-layout-length)))
1073 ;; Don't set the CLOS hash value: done in cold-init instead.
1075 ;; Set other slot values.
1077 ;; leave CLASSOID uninitialized for now
1078 (multiple-value-call
1079 #'write-slots result *host-layout-of-layout*
1080 :invalid *nil-descriptor*
1081 :inherits inherits
1082 :depthoid depthoid
1083 :length length
1084 :info *nil-descriptor*
1085 :pure *nil-descriptor*
1086 #!-interleaved-raw-slots
1087 (values :n-untagged-slots metadata)
1088 #!+interleaved-raw-slots
1089 (values :untagged-bitmap metadata
1090 ;; Nothing in cold-init needs to call EQUALP on a structure with raw slots,
1091 ;; but for type-correctness this slot needs to be a simple-vector.
1092 :equalp-tests (if (boundp '*simple-vector-0-descriptor*)
1093 *simple-vector-0-descriptor*
1094 (setq *simple-vector-0-descriptor*
1095 (vector-in-core nil))))
1096 :source-location *nil-descriptor*
1097 :%for-std-class-b (make-fixnum-descriptor 0)
1098 :slot-list *nil-descriptor*
1099 (if (member name '(null list symbol))
1100 ;; Assign an empty slot-table. Why this is done only for three
1101 ;; classoids is ... too complicated to explain here in a few words,
1102 ;; but revision 18c239205d9349abc017b07e7894a710835c5205 broke it.
1103 ;; Keep this in sync with MAKE-SLOT-TABLE in pcl/slots-boot.
1104 (values :slot-table (if (boundp '*vacuous-slot-table*)
1105 *vacuous-slot-table*
1106 (setq *vacuous-slot-table*
1107 (host-constant-to-core '#(1 nil)))))
1108 (values)))
1110 (setf (gethash (descriptor-bits result) *cold-layout-names*) name
1111 (gethash name *cold-layouts*) result)))
1113 ;;; Convert SPECIFIER (equivalently OBJ) to its representation as a ctype
1114 ;;; in the cold core.
1115 (defvar *ctype-cache*)
1117 (defvar *ctype-nullified-slots* nil)
1118 (defvar *built-in-classoid-nullified-slots* nil)
1120 ;; This function is memoized because it's essentially a constant,
1121 ;; but *nil-descriptor* isn't initialized by the time it's defined.
1122 (defun get-exceptional-slots (obj-type)
1123 (flet ((index (classoid-name slot-name)
1124 (dsd-index (find slot-name
1125 (dd-slots (find-defstruct-description classoid-name))
1126 :key #'dsd-name))))
1127 (case obj-type
1128 (built-in-classoid
1129 (or *built-in-classoid-nullified-slots*
1130 (setq *built-in-classoid-nullified-slots*
1131 (append (get-exceptional-slots 'ctype)
1132 (list (cons (index 'built-in-classoid 'sb!kernel::subclasses)
1133 *nil-descriptor*)
1134 (cons (index 'built-in-classoid 'layout)
1135 *nil-descriptor*))))))
1137 (or *ctype-nullified-slots*
1138 (setq *ctype-nullified-slots*
1139 (list (cons (index 'ctype 'sb!kernel::class-info)
1140 *nil-descriptor*))))))))
1142 (defun ctype-to-core (specifier obj)
1143 (declare (type ctype obj))
1144 (if (classoid-p obj)
1145 (let* ((cell (cold-find-classoid-cell (classoid-name obj) :create t))
1146 (cold-classoid
1147 (read-slot cell (find-layout 'sb!kernel::classoid-cell) :classoid)))
1148 (unless (cold-null cold-classoid)
1149 (return-from ctype-to-core cold-classoid)))
1150 ;; CTYPEs can't be TYPE=-hashed, but specifiers can be EQUAL-hashed.
1151 ;; Don't check the cache for classoids though; that would be wrong.
1152 ;; e.g. named-type T and classoid T both unparse to T.
1153 (awhen (gethash specifier *ctype-cache*)
1154 (return-from ctype-to-core it)))
1155 (let ((result
1156 (ctype-to-core-helper
1158 (lambda (obj)
1159 (typecase obj
1160 (xset (ctype-to-core-helper obj nil nil))
1161 (ctype (ctype-to-core (type-specifier obj) obj))))
1162 (get-exceptional-slots (type-of obj)))))
1163 (let ((type-class-vector
1164 (cold-symbol-value 'sb!kernel::*type-classes*))
1165 (index (position (sb!kernel::type-class-info obj)
1166 sb!kernel::*type-classes*)))
1167 ;; Push this instance into the list of fixups for its type class
1168 (cold-svset type-class-vector index
1169 (cold-cons result (cold-svref type-class-vector index))))
1170 (if (classoid-p obj)
1171 ;; Place this classoid into its clasoid-cell.
1172 (let ((cell (cold-find-classoid-cell (classoid-name obj) :create t)))
1173 (write-slots cell (find-layout 'sb!kernel::classoid-cell)
1174 :classoid result))
1175 ;; Otherwise put it in the general cache
1176 (setf (gethash specifier *ctype-cache*) result))
1177 result))
1179 (defun ctype-to-core-helper (obj obj-to-core-helper exceptional-slots)
1180 (let* ((host-type (type-of obj))
1181 (target-layout (or (gethash host-type *cold-layouts*)
1182 (error "No target layout for ~S" obj)))
1183 (result (allocate-struct *dynamic* target-layout))
1184 (cold-dd-slots (dd-slots-from-core host-type)))
1185 (aver (zerop (layout-raw-slot-metadata (find-layout host-type))))
1186 ;; Dump the slots.
1187 (do ((len (cold-layout-length target-layout))
1188 (index 1 (1+ index)))
1189 ((= index len) result)
1190 (write-wordindexed
1191 result
1192 (+ sb!vm:instance-slots-offset index)
1193 (acond ((assq index exceptional-slots) (cdr it))
1194 (t (host-constant-to-core
1195 (funcall (dsd-accessor-from-cold-slots cold-dd-slots index)
1196 obj)
1197 obj-to-core-helper)))))))
1199 ;; This is called to backpatch three small sets of objects:
1200 ;; - layouts which are made before layout-of-layout is made (4 of them)
1201 ;; - packages, which are made before layout-of-package is made (all of them)
1202 ;; - a small number of classoid-cells (probably 3 or 4).
1203 (defun patch-instance-layout (thing layout)
1204 ;; Layout pointer is in the word following the header
1205 (write-wordindexed thing sb!vm:instance-slots-offset layout))
1207 (defun cold-layout-of (cold-struct)
1208 (read-wordindexed cold-struct sb!vm:instance-slots-offset))
1210 (defun initialize-layouts ()
1211 (clrhash *cold-layouts*)
1212 ;; This assertion is due to the fact that MAKE-COLD-LAYOUT does not
1213 ;; know how to set any raw slots.
1214 (aver (= 0 (layout-raw-slot-metadata *host-layout-of-layout*)))
1215 (setq *layout-layout* (make-fixnum-descriptor 0))
1216 (flet ((chill-layout (name &rest inherits)
1217 ;; Check that the number of specified INHERITS matches
1218 ;; the length of the layout's inherits in the cross-compiler.
1219 (let ((warm-layout (classoid-layout (find-classoid name))))
1220 (assert (eql (length (layout-inherits warm-layout))
1221 (length inherits)))
1222 (make-cold-layout
1223 name
1224 (number-to-core (layout-length warm-layout))
1225 (vector-in-core inherits)
1226 (number-to-core (layout-depthoid warm-layout))
1227 (number-to-core (layout-raw-slot-metadata warm-layout))))))
1228 (let* ((t-layout (chill-layout 't))
1229 (s-o-layout (chill-layout 'structure-object t-layout))
1230 (s!o-layout (chill-layout 'structure!object t-layout s-o-layout)))
1231 (setf *layout-layout*
1232 (chill-layout 'layout t-layout s-o-layout s!o-layout))
1233 (dolist (layout (list t-layout s-o-layout s!o-layout *layout-layout*))
1234 (patch-instance-layout layout *layout-layout*))
1235 (setf *package-layout*
1236 (chill-layout 'package t-layout s-o-layout)))))
1238 ;;;; interning symbols in the cold image
1240 ;;; a map from package name as a host string to
1241 ;;; (cold-package-descriptor . (external-symbols . internal-symbols))
1242 (defvar *cold-package-symbols*)
1243 (declaim (type hash-table *cold-package-symbols*))
1245 (setf (get 'find-package :sb-cold-funcall-handler/for-value)
1246 (lambda (descriptor &aux (name (base-string-from-core descriptor)))
1247 (or (car (gethash name *cold-package-symbols*))
1248 (error "Genesis could not find a target package named ~S" name))))
1250 (defvar *classoid-cells*)
1251 (defun cold-find-classoid-cell (name &key create)
1252 (aver (eq create t))
1253 (or (gethash name *classoid-cells*)
1254 (let ((layout (gethash 'sb!kernel::classoid-cell *cold-layouts*)) ; ok if nil
1255 (host-layout (find-layout 'sb!kernel::classoid-cell)))
1256 (setf (gethash name *classoid-cells*)
1257 (write-slots (allocate-struct *dynamic* layout
1258 (layout-length host-layout))
1259 host-layout
1260 :name name
1261 :pcl-class *nil-descriptor*
1262 :classoid *nil-descriptor*)))))
1264 (setf (get 'find-classoid-cell :sb-cold-funcall-handler/for-value)
1265 #'cold-find-classoid-cell)
1267 ;;; a map from descriptors to symbols, so that we can back up. The key
1268 ;;; is the address in the target core.
1269 (defvar *cold-symbols*)
1270 (declaim (type hash-table *cold-symbols*))
1272 (defun initialize-packages (package-data-list)
1273 (let ((package-layout (find-layout 'package))
1274 (target-pkg-list nil))
1275 (labels ((init-cold-package (name &optional docstring)
1276 (let ((cold-package (car (gethash name *cold-package-symbols*))))
1277 ;; patch in the layout
1278 (patch-instance-layout cold-package *package-layout*)
1279 ;; Initialize string slots
1280 (write-slots cold-package package-layout
1281 :%name (base-string-to-core
1282 (target-package-name name))
1283 :%nicknames (chill-nicknames name)
1284 :doc-string (if docstring
1285 (base-string-to-core docstring)
1286 *nil-descriptor*)
1287 :%use-list *nil-descriptor*)
1288 ;; the cddr of this will accumulate the 'used-by' package list
1289 (push (list name cold-package) target-pkg-list)))
1290 (target-package-name (string)
1291 (if (eql (mismatch string "SB!") 3)
1292 (concatenate 'string "SB-" (subseq string 3))
1293 string))
1294 (chill-nicknames (pkg-name)
1295 (let ((result *nil-descriptor*))
1296 ;; Make the package nickname lists for the standard packages
1297 ;; be the minimum specified by ANSI, regardless of what value
1298 ;; the cross-compilation host happens to use.
1299 ;; For packages other than the standard packages, the nickname
1300 ;; list was specified by our package setup code, and we can just
1301 ;; propagate the current state into the target.
1302 (dolist (nickname
1303 (cond ((string= pkg-name "COMMON-LISP") '("CL"))
1304 ((string= pkg-name "COMMON-LISP-USER")
1305 '("CL-USER"))
1306 ((string= pkg-name "KEYWORD") '())
1308 ;; 'package-data-list' contains no nicknames.
1309 ;; (See comment in 'set-up-cold-packages')
1310 (aver (null (package-nicknames
1311 (find-package pkg-name))))
1312 nil))
1313 result)
1314 (cold-push (base-string-to-core nickname) result))))
1315 (find-cold-package (name)
1316 (cadr (find-package-cell name)))
1317 (find-package-cell (name)
1318 (or (assoc (if (string= name "CL") "COMMON-LISP" name)
1319 target-pkg-list :test #'string=)
1320 (error "No cold package named ~S" name))))
1321 ;; pass 1: make all proto-packages
1322 (dolist (pd package-data-list)
1323 (init-cold-package (sb-cold:package-data-name pd)
1324 #!+sb-doc(sb-cold::package-data-doc pd)))
1325 ;; pass 2: set the 'use' lists and collect the 'used-by' lists
1326 (dolist (pd package-data-list)
1327 (let ((this (find-cold-package (sb-cold:package-data-name pd)))
1328 (use nil))
1329 (dolist (that (sb-cold:package-data-use pd))
1330 (let ((cell (find-package-cell that)))
1331 (push (cadr cell) use)
1332 (push this (cddr cell))))
1333 (write-slots this package-layout
1334 :%use-list (list-to-core (nreverse use)))))
1335 ;; pass 3: set the 'used-by' lists
1336 (dolist (cell target-pkg-list)
1337 (write-slots (cadr cell) package-layout
1338 :%used-by-list (list-to-core (cddr cell)))))))
1340 ;;; sanity check for a symbol we're about to create on the target
1342 ;;; Make sure that the symbol has an appropriate package. In
1343 ;;; particular, catch the so-easy-to-make error of typing something
1344 ;;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really
1345 ;;; need is SB!KERNEL:%BYTE-BLT.
1346 (defun package-ok-for-target-symbol-p (package)
1347 (let ((package-name (package-name package)))
1349 ;; Cold interning things in these standard packages is OK. (Cold
1350 ;; interning things in the other standard package, CL-USER, isn't
1351 ;; OK. We just use CL-USER to expose symbols whose homes are in
1352 ;; other packages. Thus, trying to cold intern a symbol whose
1353 ;; home package is CL-USER probably means that a coding error has
1354 ;; been made somewhere.)
1355 (find package-name '("COMMON-LISP" "KEYWORD") :test #'string=)
1356 ;; Cold interning something in one of our target-code packages,
1357 ;; which are ever-so-rigorously-and-elegantly distinguished by
1358 ;; this prefix on their names, is OK too.
1359 (string= package-name "SB!" :end1 3 :end2 3)
1360 ;; This one is OK too, since it ends up being COMMON-LISP on the
1361 ;; target.
1362 (string= package-name "SB-XC")
1363 ;; Anything else looks bad. (maybe COMMON-LISP-USER? maybe an extension
1364 ;; package in the xc host? something we can't think of
1365 ;; a valid reason to cold intern, anyway...)
1368 ;;; like SYMBOL-PACKAGE, but safe for symbols which end up on the target
1370 ;;; Most host symbols we dump onto the target are created by SBCL
1371 ;;; itself, so that as long as we avoid gratuitously
1372 ;;; cross-compilation-unfriendly hacks, it just happens that their
1373 ;;; SYMBOL-PACKAGE in the host system corresponds to their
1374 ;;; SYMBOL-PACKAGE in the target system. However, that's not the case
1375 ;;; in the COMMON-LISP package, where we don't get to create the
1376 ;;; symbols but instead have to use the ones that the xc host created.
1377 ;;; In particular, while ANSI specifies which symbols are exported
1378 ;;; from COMMON-LISP, it doesn't specify that their home packages are
1379 ;;; COMMON-LISP, so the xc host can keep them in random packages which
1380 ;;; don't exist on the target (e.g. CLISP keeping some CL-exported
1381 ;;; symbols in the CLOS package).
1382 (defun symbol-package-for-target-symbol (symbol)
1383 ;; We want to catch weird symbols like CLISP's
1384 ;; CL:FIND-METHOD=CLOS::FIND-METHOD, but we don't want to get
1385 ;; sidetracked by ordinary symbols like :CHARACTER which happen to
1386 ;; have the same SYMBOL-NAME as exports from COMMON-LISP.
1387 (multiple-value-bind (cl-symbol cl-status)
1388 (find-symbol (symbol-name symbol) *cl-package*)
1389 (if (and (eq symbol cl-symbol)
1390 (eq cl-status :external))
1391 ;; special case, to work around possible xc host weirdness
1392 ;; in COMMON-LISP package
1393 *cl-package*
1394 ;; ordinary case
1395 (let ((result (symbol-package symbol)))
1396 (unless (package-ok-for-target-symbol-p result)
1397 (bug "~A in bad package for target: ~A" symbol result))
1398 result))))
1400 (defvar *uninterned-symbol-table* (make-hash-table :test #'equal))
1401 ;; This coalesces references to uninterned symbols, which is allowed because
1402 ;; "similar-as-constant" is defined by string comparison, and since we only have
1403 ;; base-strings during Genesis, there is no concern about upgraded array type.
1404 ;; There is a subtlety of whether coalescing may occur across files
1405 ;; - the target compiler doesn't and couldn't - but here it doesn't matter.
1406 (defun get-uninterned-symbol (name)
1407 (or (gethash name *uninterned-symbol-table*)
1408 (let ((cold-symbol (allocate-symbol name)))
1409 (setf (gethash name *uninterned-symbol-table*) cold-symbol))))
1411 ;;; Dump the target representation of HOST-VALUE,
1412 ;;; the type of which is in a restrictive set.
1413 (defun host-constant-to-core (host-value &optional helper)
1414 (let ((visited (make-hash-table :test #'eq)))
1415 (named-let target-representation ((value host-value))
1416 (unless (typep value '(or symbol number descriptor))
1417 (let ((found (gethash value visited)))
1418 (cond ((eq found :pending)
1419 (bug "circular constant?")) ; Circularity not permitted
1420 (found
1421 (return-from target-representation found))))
1422 (setf (gethash value visited) :pending))
1423 (setf (gethash value visited)
1424 (typecase value
1425 (descriptor value)
1426 (symbol (if (symbol-package value)
1427 (cold-intern value)
1428 (get-uninterned-symbol (string value))))
1429 (number (number-to-core value))
1430 (string (base-string-to-core value))
1431 (cons (cold-cons (target-representation (car value))
1432 (target-representation (cdr value))))
1433 (simple-vector
1434 (vector-in-core (map 'list #'target-representation value)))
1436 (or (and helper (funcall helper value))
1437 (error "host-constant-to-core: can't convert ~S"
1438 value))))))))
1440 ;; Look up the target's descriptor for #'FUN where FUN is a host symbol.
1441 (defun target-symbol-function (symbol)
1442 (let ((f (cold-fdefn-fun (cold-fdefinition-object symbol))))
1443 ;; It works only if DEFUN F was seen first.
1444 (aver (not (cold-null f)))
1447 ;;; Create the effect of executing a (MAKE-ARRAY) call on the target.
1448 ;;; This is for initializing a restricted set of vector constants
1449 ;;; whose contents are typically function pointers.
1450 (defun emulate-target-make-array (form)
1451 (destructuring-bind (size-expr &key initial-element) (cdr form)
1452 (let* ((size (eval size-expr))
1453 (result (allocate-vector-object *dynamic* sb!vm:n-word-bits size
1454 sb!vm:simple-vector-widetag)))
1455 (aver (integerp size))
1456 (unless (eql initial-element 0)
1457 (let ((target-initial-element
1458 (etypecase initial-element
1459 ((cons (eql function) (cons symbol null))
1460 (target-symbol-function (second initial-element)))
1461 (null *nil-descriptor*)
1462 ;; Insert more types here ...
1464 (dotimes (index size)
1465 (cold-svset result (make-fixnum-descriptor index)
1466 target-initial-element))))
1467 result)))
1469 ;; Return a target object produced by emulating evaluation of EXPR
1470 ;; with *package* set to ORIGINAL-PACKAGE.
1471 (defun emulate-target-eval (expr original-package)
1472 (let ((*package* (find-package original-package)))
1473 ;; For most things, just call EVAL and dump the host object's
1474 ;; target representation. But with MAKE-ARRAY we allow that the
1475 ;; initial-element might not be evaluable in the host.
1476 ;; Embedded MAKE-ARRAY is kept as-is because we don't "look into"
1477 ;; the EXPR, just hope that it works.
1478 (if (typep expr '(cons (eql make-array)))
1479 (emulate-target-make-array expr)
1480 (host-constant-to-core (eval expr)))))
1482 ;;; Return a handle on an interned symbol. If necessary allocate the
1483 ;;; symbol and record its home package.
1484 (defun cold-intern (symbol
1485 &key (access nil)
1486 (gspace *dynamic*)
1487 &aux (package (symbol-package-for-target-symbol symbol)))
1488 (aver (package-ok-for-target-symbol-p package))
1490 ;; Anything on the cross-compilation host which refers to the target
1491 ;; machinery through the host SB-XC package should be translated to
1492 ;; something on the target which refers to the same machinery
1493 ;; through the target COMMON-LISP package.
1494 (let ((p (find-package "SB-XC")))
1495 (when (eq package p)
1496 (setf package *cl-package*))
1497 (when (eq (symbol-package symbol) p)
1498 (setf symbol (intern (symbol-name symbol) *cl-package*))))
1500 (or (get symbol 'cold-intern-info)
1501 (let ((pkg-info (gethash (package-name package) *cold-package-symbols*))
1502 (handle (allocate-symbol (symbol-name symbol) :gspace gspace)))
1503 ;; maintain reverse map from target descriptor to host symbol
1504 (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
1505 (unless pkg-info
1506 (error "No target package descriptor for ~S" package))
1507 (record-accessibility
1508 (or access (nth-value 1 (find-symbol (symbol-name symbol) package)))
1509 handle pkg-info symbol package t)
1510 #!+sb-thread
1511 (assign-tls-index symbol handle)
1512 (acond ((eq package *keyword-package*)
1513 (setq access :external)
1514 (cold-set handle handle))
1515 ((assoc symbol sb-cold:*symbol-values-for-genesis*)
1516 (cold-set handle (destructuring-bind (expr . package) (cdr it)
1517 (emulate-target-eval expr package)))))
1518 (setf (get symbol 'cold-intern-info) handle))))
1520 (defun record-accessibility (accessibility symbol-descriptor target-pkg-info
1521 host-symbol host-package &optional set-home-p)
1522 (when set-home-p
1523 (write-wordindexed symbol-descriptor sb!vm:symbol-package-slot
1524 (car target-pkg-info)))
1525 (let ((access-lists (cdr target-pkg-info)))
1526 (case accessibility
1527 (:external (push symbol-descriptor (car access-lists)))
1528 (:internal (push symbol-descriptor (cdr access-lists)))
1529 (t (error "~S inaccessible in package ~S" host-symbol host-package)))))
1531 ;;; Construct and return a value for use as *NIL-DESCRIPTOR*.
1532 ;;; It might be nice to put NIL on a readonly page by itself to prevent unsafe
1533 ;;; code from destroying the world with (RPLACx nil 'kablooey)
1534 (defun make-nil-descriptor (target-cl-pkg-info)
1535 (let* ((des (allocate-header+object *static* sb!vm:symbol-size 0))
1536 (result (make-descriptor (+ (descriptor-bits des)
1537 (* 2 sb!vm:n-word-bytes)
1538 (- sb!vm:list-pointer-lowtag
1539 sb!vm:other-pointer-lowtag)))))
1540 (write-wordindexed des
1542 (make-other-immediate-descriptor
1544 sb!vm:symbol-header-widetag))
1545 (write-wordindexed des
1546 (+ 1 sb!vm:symbol-value-slot)
1547 result)
1548 (write-wordindexed des
1549 (+ 2 sb!vm:symbol-value-slot) ; = 1 + symbol-hash-slot
1550 result)
1551 (write-wordindexed des
1552 (+ 1 sb!vm:symbol-info-slot)
1553 (cold-cons result result)) ; NIL's info is (nil . nil)
1554 (write-wordindexed des
1555 (+ 1 sb!vm:symbol-name-slot)
1556 ;; NIL's name is in dynamic space because any extra
1557 ;; bytes allocated in static space would need to
1558 ;; be accounted for by STATIC-SYMBOL-OFFSET.
1559 (base-string-to-core "NIL" *dynamic*))
1560 ;; RECORD-ACCESSIBILITY can't assign to the package slot
1561 ;; due to NIL's base address and lowtag being nonstandard.
1562 (write-wordindexed des
1563 (+ 1 sb!vm:symbol-package-slot)
1564 (car target-cl-pkg-info))
1565 (record-accessibility :external result target-cl-pkg-info nil *cl-package*)
1566 (setf (gethash (descriptor-bits result) *cold-symbols*) nil
1567 (get nil 'cold-intern-info) result)))
1569 ;;; Since the initial symbols must be allocated before we can intern
1570 ;;; anything else, we intern those here. We also set the value of T.
1571 (defun initialize-non-nil-symbols ()
1572 "Initialize the cold load symbol-hacking data structures."
1573 ;; Intern the others.
1574 (dolist (symbol sb!vm:*static-symbols*)
1575 (let* ((des (cold-intern symbol :gspace *static*))
1576 (offset-wanted (sb!vm:static-symbol-offset symbol))
1577 (offset-found (- (descriptor-bits des)
1578 (descriptor-bits *nil-descriptor*))))
1579 (unless (= offset-wanted offset-found)
1580 ;; FIXME: should be fatal
1581 (warn "Offset from ~S to ~S is ~W, not ~W"
1582 symbol
1584 offset-found
1585 offset-wanted))))
1586 ;; Establish the value of T.
1587 (let ((t-symbol (cold-intern t :gspace *static*)))
1588 (cold-set t-symbol t-symbol))
1589 ;; Establish the value of *PSEUDO-ATOMIC-BITS* so that the
1590 ;; allocation sequences that expect it to be zero upon entrance
1591 ;; actually find it to be so.
1592 #!+(or x86-64 x86)
1593 (let ((p-a-a-symbol (cold-intern '*pseudo-atomic-bits*
1594 :gspace *static*)))
1595 (cold-set p-a-a-symbol (make-fixnum-descriptor 0))))
1597 ;;; Sort *COLD-LAYOUTS* to return them in a deterministic order.
1598 (defun sort-cold-layouts ()
1599 (sort (%hash-table-alist *cold-layouts*) #'<
1600 :key (lambda (x) (descriptor-bits (cdr x)))))
1602 ;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
1603 ;;; to be stored in *!INITIAL-LAYOUTS*.
1604 (defun cold-list-all-layouts ()
1605 (let ((result *nil-descriptor*))
1606 (dolist (layout (sort-cold-layouts) result)
1607 (cold-push (cold-cons (cold-intern (car layout)) (cdr layout))
1608 result))))
1610 ;;; Establish initial values for magic symbols.
1612 (defun finish-symbols ()
1614 ;; Everything between this preserved-for-posterity comment down to
1615 ;; the assignment of *CURRENT-CATCH-BLOCK* could be entirely deleted,
1616 ;; including the list of *C-CALLABLE-STATIC-SYMBOLS* itself,
1617 ;; if it is GC-safe for the C runtime to have its own implementation
1618 ;; of the INFO-VECTOR-FDEFN function in a multi-threaded build.
1620 ;; "I think the point of setting these functions into SYMBOL-VALUEs
1621 ;; here, instead of using SYMBOL-FUNCTION, is that in CMU CL
1622 ;; SYMBOL-FUNCTION reduces to FDEFINITION, which is a pretty
1623 ;; hairy operation (involving globaldb.lisp etc.) which we don't
1624 ;; want to invoke early in cold init. -- WHN 2001-12-05"
1626 ;; So... that's no longer true. We _do_ associate symbol -> fdefn in genesis.
1627 ;; Additionally, the INFO-VECTOR-FDEFN function is extremely simple and could
1628 ;; easily be implemented in C. However, info-vectors are inevitably
1629 ;; reallocated when new info is attached to a symbol, so the vectors can't be
1630 ;; in static space; they'd gradually become permanent garbage if they did.
1631 ;; That's the real reason for preserving the approach of storing an #<fdefn>
1632 ;; in a symbol's value cell - that location is static, the symbol-info is not.
1634 ;; FIXME: So OK, that's a reasonable reason to do something weird like
1635 ;; this, but this is still a weird thing to do, and we should change
1636 ;; the names to highlight that something weird is going on. Perhaps
1637 ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
1638 ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...
1639 (dolist (symbol sb!vm::*c-callable-static-symbols*)
1640 (cold-set symbol (cold-fdefinition-object (cold-intern symbol))))
1642 (cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0))
1643 (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))
1645 (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0))
1647 (cold-set '*!initial-layouts* (cold-list-all-layouts))
1649 #!+sb-thread
1650 (cold-set 'sb!vm::*free-tls-index*
1651 (make-descriptor (ash *genesis-tls-counter* sb!vm:word-shift)))
1653 (dolist (symbol sb!impl::*cache-vector-symbols*)
1654 (cold-set symbol *nil-descriptor*))
1656 ;; Symbols for which no call to COLD-INTERN would occur - due to not being
1657 ;; referenced until warm init - must be artificially cold-interned.
1658 ;; Inasmuch as the "offending" things are compiled by ordinary target code
1659 ;; and not cold-init, I think we should use an ordinary DEFPACKAGE for
1660 ;; the added-on bits. What I've done is somewhat of a fragile kludge.
1661 (let (syms)
1662 (with-package-iterator (iter '("SB!PCL" "SB!MOP" "SB!GRAY" "SB!SEQUENCE"
1663 "SB!PROFILE" "SB!EXT" "SB!VM"
1664 "SB!C" "SB!FASL" "SB!DEBUG")
1665 :external)
1666 (loop
1667 (multiple-value-bind (foundp sym accessibility package) (iter)
1668 (declare (ignore accessibility))
1669 (cond ((not foundp) (return))
1670 ((eq (symbol-package sym) package) (push sym syms))))))
1671 (setf syms (stable-sort syms #'string<))
1672 (dolist (sym syms)
1673 (cold-intern sym)))
1675 (let ((cold-pkg-inits *nil-descriptor*)
1676 cold-package-symbols-list)
1677 (maphash (lambda (name info)
1678 (push (cons name info) cold-package-symbols-list))
1679 *cold-package-symbols*)
1680 (setf cold-package-symbols-list
1681 (sort cold-package-symbols-list #'string< :key #'car))
1682 (dolist (pkgcons cold-package-symbols-list)
1683 (destructuring-bind (pkg-name . pkg-info) pkgcons
1684 (let ((shadow
1685 ;; Record shadowing symbols (except from SB-XC) in SB! packages.
1686 (when (eql (mismatch pkg-name "SB!") 3)
1687 ;; Be insensitive to the host's ordering.
1688 (sort (remove (find-package "SB-XC")
1689 (package-shadowing-symbols (find-package pkg-name))
1690 :key #'symbol-package) #'string<))))
1691 (write-slots (car (gethash pkg-name *cold-package-symbols*)) ; package
1692 (find-layout 'package)
1693 :%shadowing-symbols (list-to-core
1694 (mapcar 'cold-intern shadow))))
1695 (unless (member pkg-name '("COMMON-LISP" "KEYWORD") :test 'string=)
1696 (let ((host-pkg (find-package pkg-name))
1697 (sb-xc-pkg (find-package "SB-XC"))
1698 syms)
1699 ;; Now for each symbol directly present in this host-pkg,
1700 ;; i.e. accessible but not :INHERITED, figure out if the symbol
1701 ;; came from a different package, and if so, make a note of it.
1702 (with-package-iterator (iter host-pkg :internal :external)
1703 (loop (multiple-value-bind (foundp sym accessibility) (iter)
1704 (unless foundp (return))
1705 (unless (or (eq (symbol-package sym) host-pkg)
1706 (eq (symbol-package sym) sb-xc-pkg))
1707 (push (cons sym accessibility) syms)))))
1708 (dolist (symcons (sort syms #'string< :key #'car))
1709 (destructuring-bind (sym . accessibility) symcons
1710 (record-accessibility accessibility (cold-intern sym)
1711 pkg-info sym host-pkg)))))
1712 (cold-push (cold-cons (car pkg-info)
1713 (cold-cons (vector-in-core (cadr pkg-info))
1714 (vector-in-core (cddr pkg-info))))
1715 cold-pkg-inits)))
1716 (cold-set 'sb!impl::*!initial-symbols* cold-pkg-inits))
1718 (dump-symbol-info-vectors
1719 (attach-fdefinitions-to-symbols
1720 (attach-classoid-cells-to-symbols (make-hash-table :test #'eq))))
1722 (cold-set '*!initial-debug-sources* *current-debug-sources*)
1724 #!+(or x86 x86-64)
1725 (progn
1726 (cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0))
1727 (cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0))
1728 (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0))
1729 (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0))))
1731 ;;;; functions and fdefinition objects
1733 ;;; a hash table mapping from fdefinition names to descriptors of cold
1734 ;;; objects
1736 ;;; Note: Since fdefinition names can be lists like '(SETF FOO), and
1737 ;;; we want to have only one entry per name, this must be an 'EQUAL
1738 ;;; hash table, not the default 'EQL.
1739 (defvar *cold-fdefn-objects*)
1741 (defvar *cold-fdefn-gspace* nil)
1743 ;;; Given a cold representation of a symbol, return a warm
1744 ;;; representation.
1745 (defun warm-symbol (des)
1746 ;; Note that COLD-INTERN is responsible for keeping the
1747 ;; *COLD-SYMBOLS* table up to date, so if DES happens to refer to an
1748 ;; uninterned symbol, the code below will fail. But as long as we
1749 ;; don't need to look up uninterned symbols during bootstrapping,
1750 ;; that's OK..
1751 (multiple-value-bind (symbol found-p)
1752 (gethash (descriptor-bits des) *cold-symbols*)
1753 (declare (type symbol symbol))
1754 (unless found-p
1755 (error "no warm symbol"))
1756 symbol))
1758 ;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values
1759 (defun cold-car (des)
1760 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
1761 (read-wordindexed des sb!vm:cons-car-slot))
1762 (defun cold-cdr (des)
1763 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
1764 (read-wordindexed des sb!vm:cons-cdr-slot))
1765 (defun cold-rplacd (des newval)
1766 (aver (= (descriptor-lowtag des) sb!vm:list-pointer-lowtag))
1767 (write-wordindexed des sb!vm:cons-cdr-slot newval)
1768 des)
1769 (defun cold-null (des)
1770 (= (descriptor-bits des)
1771 (descriptor-bits *nil-descriptor*)))
1773 ;;; Given a cold representation of a function name, return a warm
1774 ;;; representation.
1775 (declaim (ftype (function ((or symbol descriptor)) (or symbol list)) warm-fun-name))
1776 (defun warm-fun-name (des)
1777 (let ((result
1778 (if (symbolp des)
1779 ;; This parallels the logic at the start of COLD-INTERN
1780 ;; which re-homes symbols in SB-XC to COMMON-LISP.
1781 (if (eq (symbol-package des) (find-package "SB-XC"))
1782 (intern (symbol-name des) *cl-package*)
1783 des)
1784 (ecase (descriptor-lowtag des)
1785 (#.sb!vm:list-pointer-lowtag
1786 (aver (not (cold-null des))) ; function named NIL? please no..
1787 ;; Do cold (DESTRUCTURING-BIND (COLD-CAR COLD-CADR) DES ..).
1788 (let* ((car-des (cold-car des))
1789 (cdr-des (cold-cdr des))
1790 (cadr-des (cold-car cdr-des))
1791 (cddr-des (cold-cdr cdr-des)))
1792 (aver (cold-null cddr-des))
1793 (list (warm-symbol car-des)
1794 (warm-symbol cadr-des))))
1795 (#.sb!vm:other-pointer-lowtag
1796 (warm-symbol des))))))
1797 (legal-fun-name-or-type-error result)
1798 result))
1800 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
1801 (declare (type (or symbol descriptor) cold-name))
1802 (/noshow0 "/cold-fdefinition-object")
1803 (let ((warm-name (warm-fun-name cold-name)))
1804 (or (gethash warm-name *cold-fdefn-objects*)
1805 (let ((fdefn (allocate-header+object (or *cold-fdefn-gspace* *dynamic*)
1806 (1- sb!vm:fdefn-size)
1807 sb!vm:fdefn-widetag)))
1808 (setf (gethash warm-name *cold-fdefn-objects*) fdefn)
1809 (write-wordindexed fdefn sb!vm:fdefn-name-slot cold-name)
1810 (unless leave-fn-raw
1811 (write-wordindexed fdefn sb!vm:fdefn-fun-slot *nil-descriptor*)
1812 (write-wordindexed fdefn
1813 sb!vm:fdefn-raw-addr-slot
1814 (make-random-descriptor
1815 (cold-foreign-symbol-address "undefined_tramp"))))
1816 fdefn))))
1818 ;;; Handle the at-cold-init-time, fset-for-static-linkage operation.
1819 ;;; "static" is sort of a misnomer. It's just ordinary fdefinition linkage.
1820 (defun static-fset (cold-name defn)
1821 (declare (type (or symbol descriptor) cold-name))
1822 (let ((fdefn (cold-fdefinition-object cold-name t))
1823 (type (logand (descriptor-bits (read-memory defn)) sb!vm:widetag-mask)))
1824 (write-wordindexed fdefn sb!vm:fdefn-fun-slot defn)
1825 (write-wordindexed fdefn
1826 sb!vm:fdefn-raw-addr-slot
1827 (ecase type
1828 (#.sb!vm:simple-fun-header-widetag
1829 (/noshow0 "static-fset (simple-fun)")
1830 #!+(or sparc arm)
1831 defn
1832 #!-(or sparc arm)
1833 (make-random-descriptor
1834 (+ (logandc2 (descriptor-bits defn)
1835 sb!vm:lowtag-mask)
1836 (ash sb!vm:simple-fun-code-offset
1837 sb!vm:word-shift))))
1838 (#.sb!vm:closure-header-widetag
1839 ;; There's no way to create a closure.
1840 (bug "FSET got closure-header-widetag")
1841 (/show0 "/static-fset (closure)")
1842 (make-random-descriptor
1843 (cold-foreign-symbol-address "closure_tramp")))))
1844 fdefn))
1846 ;;; the names of things which have had COLD-FSET used on them already
1847 ;;; (used to make sure that we don't try to statically link a name to
1848 ;;; more than one definition)
1849 (defparameter *cold-fset-warm-names*
1850 (make-hash-table :test 'equal)) ; names can be conses, e.g. (SETF CAR)
1852 (defun cold-fset (name compiled-lambda source-loc &optional inline-expansion)
1853 ;; SOURCE-LOC can be ignored, because functions intrinsically store
1854 ;; their location as part of the code component.
1855 ;; The argument is supplied here only to provide context for
1856 ;; a redefinition warning, which can't happen in cold load.
1857 (declare (ignore source-loc))
1858 (multiple-value-bind (cold-name warm-name)
1859 ;; (SETF f) was descriptorized when dumped, symbols were not,
1860 ;; Figure out what kind of name we're looking at.
1861 (if (symbolp name)
1862 (values (cold-intern name) name)
1863 (values name (warm-fun-name name)))
1864 (when (gethash warm-name *cold-fset-warm-names*)
1865 (error "duplicate COLD-FSET for ~S" warm-name))
1866 (setf (gethash warm-name *cold-fset-warm-names*) t)
1867 (push (cold-cons cold-name inline-expansion) *!cold-defuns*)
1868 (static-fset cold-name compiled-lambda)))
1870 (defun initialize-static-fns ()
1871 (let ((*cold-fdefn-gspace* *static*))
1872 (dolist (sym sb!vm:*static-funs*)
1873 (let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
1874 (offset (- (+ (- (descriptor-bits fdefn)
1875 sb!vm:other-pointer-lowtag)
1876 (* sb!vm:fdefn-raw-addr-slot sb!vm:n-word-bytes))
1877 (descriptor-bits *nil-descriptor*)))
1878 (desired (sb!vm:static-fun-offset sym)))
1879 (unless (= offset desired)
1880 ;; FIXME: should be fatal
1881 (error "Offset from FDEFN ~S to ~S is ~W, not ~W."
1882 sym nil offset desired))))))
1884 (defun attach-classoid-cells-to-symbols (hashtable)
1885 (let ((num (sb!c::meta-info-number (sb!c::meta-info :type :classoid-cell)))
1886 (layout (gethash 'sb!kernel::classoid-cell *cold-layouts*)))
1887 (when (plusp (hash-table-count *classoid-cells*))
1888 (aver layout))
1889 ;; Iteration order is immaterial. The symbols will get sorted later.
1890 (maphash (lambda (symbol cold-classoid-cell)
1891 ;; Some classoid-cells are dumped before the cold layout
1892 ;; of classoid-cell has been made, so fix those cases now.
1893 ;; Obviously it would be better if, in general, ALLOCATE-STRUCT
1894 ;; knew when something later must backpatch a cold layout
1895 ;; so that it could make a note to itself to do those ASAP
1896 ;; after the cold layout became known.
1897 (when (cold-null (cold-layout-of cold-classoid-cell))
1898 (patch-instance-layout cold-classoid-cell layout))
1899 (setf (gethash symbol hashtable)
1900 (packed-info-insert
1901 (gethash symbol hashtable +nil-packed-infos+)
1902 sb!c::+no-auxilliary-key+ num cold-classoid-cell)))
1903 *classoid-cells*))
1904 hashtable)
1906 ;; Create pointer from SYMBOL and/or (SETF SYMBOL) to respective fdefinition
1908 (defun attach-fdefinitions-to-symbols (hashtable)
1909 ;; Collect fdefinitions that go with one symbol, e.g. CAR and (SETF CAR),
1910 ;; using the host's code for manipulating a packed info-vector.
1911 (maphash (lambda (warm-name cold-fdefn)
1912 (with-globaldb-name (key1 key2) warm-name
1913 :hairy (error "Hairy fdefn name in genesis: ~S" warm-name)
1914 :simple
1915 (setf (gethash key1 hashtable)
1916 (packed-info-insert
1917 (gethash key1 hashtable +nil-packed-infos+)
1918 key2 +fdefn-info-num+ cold-fdefn))))
1919 *cold-fdefn-objects*)
1920 hashtable)
1922 (defun dump-symbol-info-vectors (hashtable)
1923 ;; Emit in the same order symbols reside in core to avoid
1924 ;; sensitivity to the iteration order of host's maphash.
1925 (loop for (warm-sym . info)
1926 in (sort (%hash-table-alist hashtable) #'<
1927 :key (lambda (x) (descriptor-bits (cold-intern (car x)))))
1928 do (write-wordindexed
1929 (cold-intern warm-sym) sb!vm:symbol-info-slot
1930 ;; Each vector will have one fixnum, possibly the symbol SETF,
1931 ;; and one or two #<fdefn> objects in it, and/or a classoid-cell.
1932 (vector-in-core
1933 (map 'list (lambda (elt)
1934 (etypecase elt
1935 (symbol (cold-intern elt))
1936 (fixnum (make-fixnum-descriptor elt))
1937 (descriptor elt)))
1938 info)))))
1941 ;;;; fixups and related stuff
1943 ;;; an EQUAL hash table
1944 (defvar *cold-foreign-symbol-table*)
1945 (declaim (type hash-table *cold-foreign-symbol-table*))
1947 ;; Read the sbcl.nm file to find the addresses for foreign-symbols in
1948 ;; the C runtime.
1949 (defun load-cold-foreign-symbol-table (filename)
1950 (/show "load-cold-foreign-symbol-table" filename)
1951 (with-open-file (file filename)
1952 (loop for line = (read-line file nil nil)
1953 while line do
1954 ;; UNIX symbol tables might have tabs in them, and tabs are
1955 ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
1956 ;; nice portable way to deal with them within Lisp, alas.
1957 ;; Fortunately, it's easy to use UNIX command line tools like
1958 ;; sed to remove the problem, so it's not too painful for us
1959 ;; to push responsibility for converting tabs to spaces out to
1960 ;; the caller.
1962 ;; Other non-STANDARD-CHARs are problematic for the same reason.
1963 ;; Make sure that there aren't any..
1964 (let ((ch (find-if (lambda (char)
1965 (not (typep char 'standard-char)))
1966 line)))
1967 (when ch
1968 (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
1970 line)))
1971 (setf line (string-trim '(#\space) line))
1972 (let ((p1 (position #\space line :from-end nil))
1973 (p2 (position #\space line :from-end t)))
1974 (if (not (and p1 p2 (< p1 p2)))
1975 ;; KLUDGE: It's too messy to try to understand all
1976 ;; possible output from nm, so we just punt the lines we
1977 ;; don't recognize. We realize that there's some chance
1978 ;; that might get us in trouble someday, so we warn
1979 ;; about it.
1980 (warn "ignoring unrecognized line ~S in ~A" line filename)
1981 (multiple-value-bind (value name)
1982 (if (string= "0x" line :end2 2)
1983 (values (parse-integer line :start 2 :end p1 :radix 16)
1984 (subseq line (1+ p2)))
1985 (values (parse-integer line :end p1 :radix 16)
1986 (subseq line (1+ p2))))
1987 ;; KLUDGE CLH 2010-05-31: on darwin, nm gives us
1988 ;; _function but dlsym expects us to look up
1989 ;; function, without the leading _ . Therefore, we
1990 ;; strip it off here.
1991 #!+darwin
1992 (when (equal (char name 0) #\_)
1993 (setf name (subseq name 1)))
1994 (multiple-value-bind (old-value found)
1995 (gethash name *cold-foreign-symbol-table*)
1996 (when (and found
1997 (not (= old-value value)))
1998 (warn "redefining ~S from #X~X to #X~X"
1999 name old-value value)))
2000 (/show "adding to *cold-foreign-symbol-table*:" name value)
2001 (setf (gethash name *cold-foreign-symbol-table*) value)
2002 #!+win32
2003 (let ((at-position (position #\@ name)))
2004 (when at-position
2005 (let ((name (subseq name 0 at-position)))
2006 (multiple-value-bind (old-value found)
2007 (gethash name *cold-foreign-symbol-table*)
2008 (when (and found
2009 (not (= old-value value)))
2010 (warn "redefining ~S from #X~X to #X~X"
2011 name old-value value)))
2012 (setf (gethash name *cold-foreign-symbol-table*)
2013 value)))))))))
2014 (values)) ;; PROGN
2016 (defun cold-foreign-symbol-address (name)
2017 (or (find-foreign-symbol-in-table name *cold-foreign-symbol-table*)
2018 *foreign-symbol-placeholder-value*
2019 (progn
2020 (format *error-output* "~&The foreign symbol table is:~%")
2021 (maphash (lambda (k v)
2022 (format *error-output* "~&~S = #X~8X~%" k v))
2023 *cold-foreign-symbol-table*)
2024 (error "The foreign symbol ~S is undefined." name))))
2026 (defvar *cold-assembler-routines*)
2028 (defvar *cold-assembler-fixups*)
2030 (defun record-cold-assembler-routine (name address)
2031 (/xhow "in RECORD-COLD-ASSEMBLER-ROUTINE" name address)
2032 (push (cons name address)
2033 *cold-assembler-routines*))
2035 (defun record-cold-assembler-fixup (routine
2036 code-object
2037 offset
2038 &optional
2039 (kind :both))
2040 (push (list routine code-object offset kind)
2041 *cold-assembler-fixups*))
2043 (defun lookup-assembler-reference (symbol)
2044 (let ((value (cdr (assoc symbol *cold-assembler-routines*))))
2045 ;; FIXME: Should this be ERROR instead of WARN?
2046 (unless value
2047 (warn "Assembler routine ~S not defined." symbol))
2048 value))
2050 ;;; Unlike in the target, FOP-KNOWN-FUN sometimes has to backpatch.
2051 (defvar *deferred-known-fun-refs*)
2053 ;;; The x86 port needs to store code fixups along with code objects if
2054 ;;; they are to be moved, so fixups for code objects in the dynamic
2055 ;;; heap need to be noted.
2056 #!+x86
2057 (defvar *load-time-code-fixups*)
2059 #!+x86
2060 (defun note-load-time-code-fixup (code-object offset)
2061 ;; If CODE-OBJECT might be moved
2062 (when (= (gspace-identifier (descriptor-intuit-gspace code-object))
2063 dynamic-core-space-id)
2064 (push offset (gethash (descriptor-bits code-object)
2065 *load-time-code-fixups*
2066 nil)))
2067 (values))
2069 #!+x86
2070 (defun output-load-time-code-fixups ()
2071 (let ((fixup-infos nil))
2072 (maphash
2073 (lambda (code-object-address fixup-offsets)
2074 (push (cons code-object-address fixup-offsets) fixup-infos))
2075 *load-time-code-fixups*)
2076 (setq fixup-infos (sort fixup-infos #'< :key #'car))
2077 (dolist (fixup-info fixup-infos)
2078 (let ((code-object-address (car fixup-info))
2079 (fixup-offsets (cdr fixup-info)))
2080 (let ((fixup-vector
2081 (allocate-vector-object
2082 *dynamic* sb!vm:n-word-bits (length fixup-offsets)
2083 sb!vm:simple-array-unsigned-byte-32-widetag)))
2084 (do ((index sb!vm:vector-data-offset (1+ index))
2085 (fixups fixup-offsets (cdr fixups)))
2086 ((null fixups))
2087 (write-wordindexed fixup-vector index
2088 (make-random-descriptor (car fixups))))
2089 ;; KLUDGE: The fixup vector is stored as the first constant,
2090 ;; not as a separately-named slot.
2091 (write-wordindexed (make-random-descriptor code-object-address)
2092 sb!vm:code-constants-offset
2093 fixup-vector))))))
2095 ;;; Given a pointer to a code object and an offset relative to the
2096 ;;; tail of the code object's header, return an offset relative to the
2097 ;;; (beginning of the) code object.
2099 ;;; FIXME: It might be clearer to reexpress
2100 ;;; (LET ((X (CALC-OFFSET CODE-OBJECT OFFSET0))) ..)
2101 ;;; as
2102 ;;; (LET ((X (+ OFFSET0 (CODE-OBJECT-HEADER-N-BYTES CODE-OBJECT)))) ..).
2103 (declaim (ftype (function (descriptor sb!vm:word)) calc-offset))
2104 (defun calc-offset (code-object offset-from-tail-of-header)
2105 (let* ((header (read-memory code-object))
2106 (header-n-words (ash (descriptor-bits header)
2107 (- sb!vm:n-widetag-bits)))
2108 (header-n-bytes (ash header-n-words sb!vm:word-shift))
2109 (result (+ offset-from-tail-of-header header-n-bytes)))
2110 result))
2112 (declaim (ftype (function (descriptor sb!vm:word sb!vm:word keyword))
2113 do-cold-fixup))
2114 (defun do-cold-fixup (code-object after-header value kind)
2115 (let* ((offset-within-code-object (calc-offset code-object after-header))
2116 (gspace-bytes (descriptor-bytes code-object))
2117 (gspace-byte-offset (+ (descriptor-byte-offset code-object)
2118 offset-within-code-object))
2119 (gspace-byte-address (gspace-byte-address
2120 (descriptor-gspace code-object))))
2121 ;; There's just a ton of code here that gets deleted,
2122 ;; inhibiting the view of the the forest through the trees.
2123 ;; Use of #+sbcl would say "probable bug in read-time conditional"
2124 #+#.(cl:if (cl:member :sbcl cl:*features*) '(and) '(or))
2125 (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
2126 (ecase +backend-fasl-file-implementation+
2127 ;; See CMU CL source for other formerly-supported architectures
2128 ;; (and note that you have to rewrite them to use BVREF-X
2129 ;; instead of SAP-REF).
2130 (:alpha
2131 (ecase kind
2132 (:jmp-hint
2133 (assert (zerop (ldb (byte 2 0) value))))
2134 (:bits-63-48
2135 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
2136 (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
2137 (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
2138 (setf (bvref-8 gspace-bytes gspace-byte-offset)
2139 (ldb (byte 8 48) value)
2140 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
2141 (ldb (byte 8 56) value))))
2142 (:bits-47-32
2143 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
2144 (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
2145 (setf (bvref-8 gspace-bytes gspace-byte-offset)
2146 (ldb (byte 8 32) value)
2147 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
2148 (ldb (byte 8 40) value))))
2149 (:ldah
2150 (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
2151 (setf (bvref-8 gspace-bytes gspace-byte-offset)
2152 (ldb (byte 8 16) value)
2153 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
2154 (ldb (byte 8 24) value))))
2155 (:lda
2156 (setf (bvref-8 gspace-bytes gspace-byte-offset)
2157 (ldb (byte 8 0) value)
2158 (bvref-8 gspace-bytes (1+ gspace-byte-offset))
2159 (ldb (byte 8 8) value)))))
2160 (:arm
2161 (ecase kind
2162 (:absolute
2163 (setf (bvref-32 gspace-bytes gspace-byte-offset) value))))
2164 (:arm64
2165 (ecase kind
2166 (:absolute
2167 (setf (bvref-64 gspace-bytes gspace-byte-offset) value))
2168 (:cond-branch
2169 (setf (ldb (byte 19 5)
2170 (bvref-32 gspace-bytes gspace-byte-offset))
2171 (ash (- value (+ gspace-byte-address gspace-byte-offset))
2172 -2)))
2173 (:uncond-branch
2174 (setf (ldb (byte 26 0)
2175 (bvref-32 gspace-bytes gspace-byte-offset))
2176 (ash (- value (+ gspace-byte-address gspace-byte-offset))
2177 -2)))))
2178 (:hppa
2179 (ecase kind
2180 (:absolute
2181 (setf (bvref-32 gspace-bytes gspace-byte-offset) value))
2182 (:load
2183 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2184 (logior (mask-field (byte 18 14)
2185 (bvref-32 gspace-bytes gspace-byte-offset))
2186 (if (< value 0)
2187 (1+ (ash (ldb (byte 13 0) value) 1))
2188 (ash (ldb (byte 13 0) value) 1)))))
2189 (:load11u
2190 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2191 (logior (mask-field (byte 18 14)
2192 (bvref-32 gspace-bytes gspace-byte-offset))
2193 (if (< value 0)
2194 (1+ (ash (ldb (byte 10 0) value) 1))
2195 (ash (ldb (byte 11 0) value) 1)))))
2196 (:load-short
2197 (let ((low-bits (ldb (byte 11 0) value)))
2198 (assert (<= 0 low-bits (1- (ash 1 4)))))
2199 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2200 (logior (ash (dpb (ldb (byte 4 0) value)
2201 (byte 4 1)
2202 (ldb (byte 1 4) value)) 17)
2203 (logand (bvref-32 gspace-bytes gspace-byte-offset)
2204 #xffe0ffff))))
2205 (:hi
2206 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2207 (logior (mask-field (byte 11 21)
2208 (bvref-32 gspace-bytes gspace-byte-offset))
2209 (ash (ldb (byte 5 13) value) 16)
2210 (ash (ldb (byte 2 18) value) 14)
2211 (ash (ldb (byte 2 11) value) 12)
2212 (ash (ldb (byte 11 20) value) 1)
2213 (ldb (byte 1 31) value))))
2214 (:branch
2215 (let ((bits (ldb (byte 9 2) value)))
2216 (assert (zerop (ldb (byte 2 0) value)))
2217 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2218 (logior (ash bits 3)
2219 (mask-field (byte 1 1) (bvref-32 gspace-bytes gspace-byte-offset))
2220 (mask-field (byte 3 13) (bvref-32 gspace-bytes gspace-byte-offset))
2221 (mask-field (byte 11 21) (bvref-32 gspace-bytes gspace-byte-offset))))))))
2222 (:mips
2223 (ecase kind
2224 (:jump
2225 (assert (zerop (ash value -28)))
2226 (setf (ldb (byte 26 0)
2227 (bvref-32 gspace-bytes gspace-byte-offset))
2228 (ash value -2)))
2229 (:lui
2230 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2231 (logior (mask-field (byte 16 16)
2232 (bvref-32 gspace-bytes gspace-byte-offset))
2233 (ash (1+ (ldb (byte 17 15) value)) -1))))
2234 (:addi
2235 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2236 (logior (mask-field (byte 16 16)
2237 (bvref-32 gspace-bytes gspace-byte-offset))
2238 (ldb (byte 16 0) value))))))
2239 ;; FIXME: PowerPC Fixups are not fully implemented. The bit
2240 ;; here starts to set things up to work properly, but there
2241 ;; needs to be corresponding code in ppc-vm.lisp
2242 (:ppc
2243 (ecase kind
2244 (:ba
2245 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2246 (dpb (ash value -2) (byte 24 2)
2247 (bvref-32 gspace-bytes gspace-byte-offset))))
2248 (:ha
2249 (let* ((un-fixed-up (bvref-16 gspace-bytes
2250 (+ gspace-byte-offset 2)))
2251 (fixed-up (+ un-fixed-up value))
2252 (h (ldb (byte 16 16) fixed-up))
2253 (l (ldb (byte 16 0) fixed-up)))
2254 (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
2255 (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
2257 (let* ((un-fixed-up (bvref-16 gspace-bytes
2258 (+ gspace-byte-offset 2)))
2259 (fixed-up (+ un-fixed-up value)))
2260 (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
2261 (ldb (byte 16 0) fixed-up))))))
2262 (:sparc
2263 (ecase kind
2264 (:call
2265 (error "can't deal with call fixups yet"))
2266 (:sethi
2267 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2268 (dpb (ldb (byte 22 10) value)
2269 (byte 22 0)
2270 (bvref-32 gspace-bytes gspace-byte-offset))))
2271 (:add
2272 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2273 (dpb (ldb (byte 10 0) value)
2274 (byte 10 0)
2275 (bvref-32 gspace-bytes gspace-byte-offset))))))
2276 ((:x86 :x86-64)
2277 ;; XXX: Note that un-fixed-up is read via bvref-word, which is
2278 ;; 64 bits wide on x86-64, but the fixed-up value is written
2279 ;; via bvref-32. This would make more sense if we supported
2280 ;; :absolute64 fixups, but apparently the cross-compiler
2281 ;; doesn't dump them.
2282 (let* ((un-fixed-up (bvref-word gspace-bytes
2283 gspace-byte-offset))
2284 (code-object-start-addr (logandc2 (descriptor-bits code-object)
2285 sb!vm:lowtag-mask)))
2286 (assert (= code-object-start-addr
2287 (+ gspace-byte-address
2288 (descriptor-byte-offset code-object))))
2289 (ecase kind
2290 (:absolute
2291 (let ((fixed-up (+ value un-fixed-up)))
2292 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2293 fixed-up)
2294 ;; comment from CMU CL sources:
2296 ;; Note absolute fixups that point within the object.
2297 ;; KLUDGE: There seems to be an implicit assumption in
2298 ;; the old CMU CL code here, that if it doesn't point
2299 ;; before the object, it must point within the object
2300 ;; (not beyond it). It would be good to add an
2301 ;; explanation of why that's true, or an assertion that
2302 ;; it's really true, or both.
2304 ;; One possible explanation is that all absolute fixups
2305 ;; point either within the code object, within the
2306 ;; runtime, within read-only or static-space, or within
2307 ;; the linkage-table space. In all x86 configurations,
2308 ;; these areas are prior to the start of dynamic space,
2309 ;; where all the code-objects are loaded.
2310 #!+x86
2311 (unless (< fixed-up code-object-start-addr)
2312 (note-load-time-code-fixup code-object
2313 after-header))))
2314 (:relative ; (used for arguments to X86 relative CALL instruction)
2315 (let ((fixed-up (- (+ value un-fixed-up)
2316 gspace-byte-address
2317 gspace-byte-offset
2318 4))) ; "length of CALL argument"
2319 (setf (bvref-32 gspace-bytes gspace-byte-offset)
2320 fixed-up)
2321 ;; Note relative fixups that point outside the code
2322 ;; object, which is to say all relative fixups, since
2323 ;; relative addressing within a code object never needs
2324 ;; a fixup.
2325 #!+x86
2326 (note-load-time-code-fixup code-object
2327 after-header))))))))
2328 (values))
2330 (defun resolve-assembler-fixups ()
2331 (dolist (fixup *cold-assembler-fixups*)
2332 (let* ((routine (car fixup))
2333 (value (lookup-assembler-reference routine)))
2334 (when value
2335 (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
2337 #!+sb-dynamic-core
2338 (progn
2339 (defparameter *dyncore-address* sb!vm::linkage-table-space-start)
2340 (defparameter *dyncore-linkage-keys* nil)
2341 (defparameter *dyncore-table* (make-hash-table :test 'equal))
2343 (defun dyncore-note-symbol (symbol-name datap)
2344 "Register a symbol and return its address in proto-linkage-table."
2345 (let ((key (cons symbol-name datap)))
2346 (symbol-macrolet ((entry (gethash key *dyncore-table*)))
2347 (or entry
2348 (setf entry
2349 (prog1 *dyncore-address*
2350 (push key *dyncore-linkage-keys*)
2351 (incf *dyncore-address* sb!vm::linkage-table-entry-size))))))))
2353 ;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in
2354 ;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to
2355 ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
2356 ;;; target-load.lisp refers to.
2357 (defun foreign-symbols-to-core ()
2358 (let ((result *nil-descriptor*))
2359 #!-sb-dynamic-core
2360 (dolist (symbol (sort (%hash-table-alist *cold-foreign-symbol-table*)
2361 #'string< :key #'car))
2362 (cold-push (cold-cons (base-string-to-core (car symbol))
2363 (number-to-core (cdr symbol)))
2364 result))
2365 (cold-set '*!initial-foreign-symbols* result)
2366 #!+sb-dynamic-core
2367 (let ((runtime-linking-list *nil-descriptor*))
2368 (dolist (symbol *dyncore-linkage-keys*)
2369 (cold-push (cold-cons (base-string-to-core (car symbol))
2370 (cdr symbol))
2371 runtime-linking-list))
2372 (cold-set 'sb!vm::*required-runtime-c-symbols*
2373 runtime-linking-list)))
2374 (let ((result *nil-descriptor*))
2375 (dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car))
2376 (cold-push (cold-cons (cold-intern (car rtn))
2377 (number-to-core (cdr rtn)))
2378 result))
2379 (cold-set '*!initial-assembler-routines* result)))
2382 ;;;; general machinery for cold-loading FASL files
2384 (defun pop-fop-stack (stack)
2385 (let ((top (svref stack 0)))
2386 (declare (type index top))
2387 (when (eql 0 top)
2388 (error "FOP stack empty"))
2389 (setf (svref stack 0) (1- top))
2390 (svref stack top)))
2392 ;;; Cause a fop to have a special definition for cold load.
2394 ;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version
2395 ;;; looks up the encoding for this name (created by a previous DEFINE-FOP)
2396 ;;; instead of creating a new encoding.
2397 (defmacro define-cold-fop ((name &optional arglist) &rest forms)
2398 (let* ((code (get name 'opcode))
2399 (argp (plusp (sbit (car **fop-signatures**) (ash code -2))))
2400 (fname (symbolicate "COLD-" name)))
2401 (unless code
2402 (error "~S is not a defined FOP." name))
2403 (when (and argp (not (singleton-p arglist)))
2404 (error "~S must take one argument" name))
2405 `(progn
2406 (defun ,fname (.fasl-input. ,@arglist)
2407 (declare (ignorable .fasl-input.))
2408 (macrolet ((fasl-input () '(the fasl-input .fasl-input.))
2409 (fasl-input-stream () '(%fasl-input-stream (fasl-input)))
2410 (pop-stack ()
2411 '(pop-fop-stack (%fasl-input-stack (fasl-input)))))
2412 ,@forms))
2413 ;; We simply overwrite elements of **FOP-FUNS** since the contents
2414 ;; of the host are never propagated directly into the target core.
2415 ,@(loop for i from code to (logior code (if argp 3 0))
2416 collect `(setf (svref **fop-funs** ,i) #',fname)))))
2418 ;;; Cause a fop to be undefined in cold load.
2419 (defmacro not-cold-fop (name)
2420 `(define-cold-fop (,name)
2421 (error "The fop ~S is not supported in cold load." ',name)))
2423 ;;; COLD-LOAD loads stuff into the core image being built by calling
2424 ;;; LOAD-AS-FASL with the fop function table rebound to a table of cold
2425 ;;; loading functions.
2426 (defun cold-load (filename)
2427 "Load the file named by FILENAME into the cold load image being built."
2428 (with-open-file (s filename :element-type '(unsigned-byte 8))
2429 (load-as-fasl s nil nil)))
2431 ;;;; miscellaneous cold fops
2433 (define-cold-fop (fop-misc-trap) *unbound-marker*)
2435 (define-cold-fop (fop-character (c))
2436 (make-character-descriptor c))
2438 (define-cold-fop (fop-empty-list) nil)
2439 (define-cold-fop (fop-truth) t)
2441 (define-cold-fop (fop-struct (size)) ; n-words incl. layout, excluding header
2442 (let* ((layout (pop-stack))
2443 (result (allocate-struct *dynamic* layout size))
2444 (metadata
2445 (descriptor-fixnum
2446 (read-slot layout *host-layout-of-layout*
2447 #!-interleaved-raw-slots :n-untagged-slots
2448 #!+interleaved-raw-slots :untagged-bitmap)))
2449 #!-interleaved-raw-slots (ntagged (- size metadata))
2451 ;; Raw slots can not possibly work because dump-struct uses
2452 ;; %RAW-INSTANCE-REF/WORD which does not exist in the cross-compiler.
2453 ;; Remove this assertion if that problem is somehow circumvented.
2454 (unless (= metadata 0)
2455 (error "Raw slots not working in genesis."))
2457 (do ((index 1 (1+ index)))
2458 ((eql index size))
2459 (declare (fixnum index))
2460 (write-wordindexed result
2461 (+ index sb!vm:instance-slots-offset)
2462 (if #!-interleaved-raw-slots (>= index ntagged)
2463 #!+interleaved-raw-slots (logbitp index metadata)
2464 (descriptor-word-sized-integer (pop-stack))
2465 (pop-stack))))
2466 result))
2468 (define-cold-fop (fop-layout)
2469 (let* ((metadata-des (pop-stack))
2470 (length-des (pop-stack))
2471 (depthoid-des (pop-stack))
2472 (cold-inherits (pop-stack))
2473 (name (pop-stack))
2474 (old-layout-descriptor (gethash name *cold-layouts*)))
2475 (declare (type descriptor length-des depthoid-des cold-inherits))
2476 (declare (type symbol name))
2477 ;; If a layout of this name has been defined already
2478 (if old-layout-descriptor
2479 ;; Enforce consistency between the previous definition and the
2480 ;; current definition, then return the previous definition.
2481 (flet ((get-slot (keyword)
2482 (read-slot old-layout-descriptor *host-layout-of-layout* keyword)))
2483 (let ((old-length (descriptor-fixnum (get-slot :length)))
2484 (old-depthoid (descriptor-fixnum (get-slot :depthoid)))
2485 (old-metadata
2486 (host-object-from-core
2487 (get-slot #!-interleaved-raw-slots :n-untagged-slots
2488 #!+interleaved-raw-slots :untagged-bitmap)))
2489 (length (descriptor-fixnum length-des))
2490 (depthoid (descriptor-fixnum depthoid-des))
2491 (metadata (host-object-from-core metadata-des)))
2492 (unless (= length old-length)
2493 (error "cold loading a reference to class ~S when the compile~%~
2494 time length was ~S and current length is ~S"
2495 name
2496 length
2497 old-length))
2498 (unless (cold-vector-elements-eq cold-inherits (get-slot :inherits))
2499 (error "cold loading a reference to class ~S when the compile~%~
2500 time inherits were ~S~%~
2501 and current inherits are ~S"
2502 name
2503 (listify-cold-inherits cold-inherits)
2504 (listify-cold-inherits (get-slot :inherits))))
2505 (unless (= depthoid old-depthoid)
2506 (error "cold loading a reference to class ~S when the compile~%~
2507 time inheritance depthoid was ~S and current inheritance~%~
2508 depthoid is ~S"
2509 name
2510 depthoid
2511 old-depthoid))
2512 (unless (= metadata old-metadata)
2513 (error "cold loading a reference to class ~S when the compile~%~
2514 time raw-slot-metadata was ~S and is currently ~S"
2515 name
2516 metadata
2517 old-metadata)))
2518 old-layout-descriptor)
2519 ;; Make a new definition from scratch.
2520 (make-cold-layout name length-des cold-inherits depthoid-des
2521 metadata-des))))
2523 ;;;; cold fops for loading symbols
2525 ;;; Load a symbol SIZE characters long from FASL-INPUT, and
2526 ;;; intern that symbol in PACKAGE.
2527 (defun cold-load-symbol (size package fasl-input)
2528 (let ((string (make-string size)))
2529 (read-string-as-bytes (%fasl-input-stream fasl-input) string)
2530 (push-fop-table (intern string package) fasl-input)))
2532 ;; I don't feel like hacking up DEFINE-COLD-FOP any more than necessary,
2533 ;; so this code is handcrafted to accept two operands.
2534 (flet ((fop-cold-symbol-in-package-save (fasl-input index pname-len)
2535 (cold-load-symbol pname-len (ref-fop-table fasl-input index)
2536 fasl-input)))
2537 (dotimes (i 16) ; occupies 16 cells in the dispatch table
2538 (setf (svref **fop-funs** (+ (get 'fop-symbol-in-package-save 'opcode) i))
2539 #'fop-cold-symbol-in-package-save)))
2541 (define-cold-fop (fop-lisp-symbol-save (namelen))
2542 (cold-load-symbol namelen *cl-package* (fasl-input)))
2544 (define-cold-fop (fop-keyword-symbol-save (namelen))
2545 (cold-load-symbol namelen *keyword-package* (fasl-input)))
2547 (define-cold-fop (fop-uninterned-symbol-save (namelen))
2548 (let ((name (make-string namelen)))
2549 (read-string-as-bytes (fasl-input-stream) name)
2550 (push-fop-table (get-uninterned-symbol name) (fasl-input))))
2552 (define-cold-fop (fop-copy-symbol-save (index))
2553 (let* ((symbol (ref-fop-table (fasl-input) index))
2554 (name
2555 (if (symbolp symbol)
2556 (symbol-name symbol)
2557 (base-string-from-core
2558 (read-wordindexed symbol sb!vm:symbol-name-slot)))))
2559 ;; Genesis performs additional coalescing of uninterned symbols
2560 (push-fop-table (get-uninterned-symbol name) (fasl-input))))
2562 ;;;; cold fops for loading packages
2564 (define-cold-fop (fop-named-package-save (namelen))
2565 (let ((name (make-string namelen)))
2566 (read-string-as-bytes (fasl-input-stream) name)
2567 (push-fop-table (find-package name) (fasl-input))))
2569 ;;;; cold fops for loading lists
2571 ;;; Make a list of the top LENGTH things on the fop stack. The last
2572 ;;; cdr of the list is set to LAST.
2573 (defmacro cold-stack-list (length last)
2574 `(do* ((index ,length (1- index))
2575 (result ,last (cold-cons (pop-stack) result)))
2576 ((= index 0) result)
2577 (declare (fixnum index))))
2579 (define-cold-fop (fop-list)
2580 (cold-stack-list (read-byte-arg (fasl-input-stream)) *nil-descriptor*))
2581 (define-cold-fop (fop-list*)
2582 (cold-stack-list (read-byte-arg (fasl-input-stream)) (pop-stack)))
2583 (define-cold-fop (fop-list-1)
2584 (cold-stack-list 1 *nil-descriptor*))
2585 (define-cold-fop (fop-list-2)
2586 (cold-stack-list 2 *nil-descriptor*))
2587 (define-cold-fop (fop-list-3)
2588 (cold-stack-list 3 *nil-descriptor*))
2589 (define-cold-fop (fop-list-4)
2590 (cold-stack-list 4 *nil-descriptor*))
2591 (define-cold-fop (fop-list-5)
2592 (cold-stack-list 5 *nil-descriptor*))
2593 (define-cold-fop (fop-list-6)
2594 (cold-stack-list 6 *nil-descriptor*))
2595 (define-cold-fop (fop-list-7)
2596 (cold-stack-list 7 *nil-descriptor*))
2597 (define-cold-fop (fop-list-8)
2598 (cold-stack-list 8 *nil-descriptor*))
2599 (define-cold-fop (fop-list*-1)
2600 (cold-stack-list 1 (pop-stack)))
2601 (define-cold-fop (fop-list*-2)
2602 (cold-stack-list 2 (pop-stack)))
2603 (define-cold-fop (fop-list*-3)
2604 (cold-stack-list 3 (pop-stack)))
2605 (define-cold-fop (fop-list*-4)
2606 (cold-stack-list 4 (pop-stack)))
2607 (define-cold-fop (fop-list*-5)
2608 (cold-stack-list 5 (pop-stack)))
2609 (define-cold-fop (fop-list*-6)
2610 (cold-stack-list 6 (pop-stack)))
2611 (define-cold-fop (fop-list*-7)
2612 (cold-stack-list 7 (pop-stack)))
2613 (define-cold-fop (fop-list*-8)
2614 (cold-stack-list 8 (pop-stack)))
2616 ;;;; cold fops for loading vectors
2618 (define-cold-fop (fop-base-string (len))
2619 (let ((string (make-string len)))
2620 (read-string-as-bytes (fasl-input-stream) string)
2621 (base-string-to-core string)))
2623 #!+sb-unicode
2624 (define-cold-fop (fop-character-string (len))
2625 (bug "CHARACTER-STRING[~D] dumped by cross-compiler." len))
2627 (define-cold-fop (fop-vector (size))
2628 (let* ((result (allocate-vector-object *dynamic*
2629 sb!vm:n-word-bits
2630 size
2631 sb!vm:simple-vector-widetag)))
2632 (do ((index (1- size) (1- index)))
2633 ((minusp index))
2634 (declare (fixnum index))
2635 (write-wordindexed result
2636 (+ index sb!vm:vector-data-offset)
2637 (pop-stack)))
2638 result))
2640 (define-cold-fop (fop-spec-vector)
2641 (let* ((len (read-word-arg (fasl-input-stream)))
2642 (type (read-byte-arg (fasl-input-stream)))
2643 (sizebits (aref **saetp-bits-per-length** type))
2644 (result (progn (aver (< sizebits 255))
2645 (allocate-vector-object *dynamic* sizebits len type)))
2646 (start (+ (descriptor-byte-offset result)
2647 (ash sb!vm:vector-data-offset sb!vm:word-shift)))
2648 (end (+ start
2649 (ceiling (* len sizebits)
2650 sb!vm:n-byte-bits))))
2651 (read-bigvec-as-sequence-or-die (descriptor-bytes result)
2652 (fasl-input-stream)
2653 :start start
2654 :end end)
2655 result))
2657 (not-cold-fop fop-array)
2658 #+nil
2659 ;; This code is unexercised. The only use of FOP-ARRAY is from target-dump.
2660 ;; It would be a shame to delete it though, as it might come in handy.
2661 (define-cold-fop (fop-array)
2662 (let* ((rank (read-word-arg (fasl-input-stream)))
2663 (data-vector (pop-stack))
2664 (result (allocate-object *dynamic*
2665 (+ sb!vm:array-dimensions-offset rank)
2666 sb!vm:other-pointer-lowtag)))
2667 (write-header-word result rank sb!vm:simple-array-widetag)
2668 (write-wordindexed result sb!vm:array-fill-pointer-slot *nil-descriptor*)
2669 (write-wordindexed result sb!vm:array-data-slot data-vector)
2670 (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
2671 (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)
2672 (write-wordindexed result sb!vm:array-displaced-from-slot *nil-descriptor*)
2673 (let ((total-elements 1))
2674 (dotimes (axis rank)
2675 (let ((dim (pop-stack)))
2676 (unless (is-fixnum-lowtag (descriptor-lowtag dim))
2677 (error "non-fixnum dimension? (~S)" dim))
2678 (setf total-elements (* total-elements (descriptor-fixnum dim)))
2679 (write-wordindexed result
2680 (+ sb!vm:array-dimensions-offset axis)
2681 dim)))
2682 (write-wordindexed result
2683 sb!vm:array-elements-slot
2684 (make-fixnum-descriptor total-elements)))
2685 result))
2688 ;;;; cold fops for loading numbers
2690 (defmacro define-cold-number-fop (fop &optional arglist)
2691 ;; Invoke the ordinary warm version of this fop to cons the number.
2692 `(define-cold-fop (,fop ,arglist)
2693 (number-to-core (,fop (fasl-input) ,@arglist))))
2695 (define-cold-number-fop fop-single-float)
2696 (define-cold-number-fop fop-double-float)
2697 (define-cold-number-fop fop-word-integer)
2698 (define-cold-number-fop fop-byte-integer)
2699 (define-cold-number-fop fop-complex-single-float)
2700 (define-cold-number-fop fop-complex-double-float)
2701 (define-cold-number-fop fop-integer (n-bytes))
2703 (define-cold-fop (fop-ratio)
2704 (let ((den (pop-stack)))
2705 (number-pair-to-core (pop-stack) den sb!vm:ratio-widetag)))
2707 (define-cold-fop (fop-complex)
2708 (let ((im (pop-stack)))
2709 (number-pair-to-core (pop-stack) im sb!vm:complex-widetag)))
2711 ;;;; cold fops for calling (or not calling)
2713 (not-cold-fop fop-eval)
2714 (not-cold-fop fop-eval-for-effect)
2716 (defvar *load-time-value-counter*)
2718 (flet ((pop-args (fasl-input)
2719 (let ((args)
2720 (stack (%fasl-input-stack fasl-input)))
2721 (dotimes (i (read-byte-arg (%fasl-input-stream fasl-input))
2722 (values (pop-fop-stack stack) args))
2723 (push (pop-fop-stack stack) args))))
2724 (call (fun-name handler-name args)
2725 (acond ((get fun-name handler-name) (apply it args))
2726 (t (error "Can't ~S ~S in cold load" handler-name fun-name)))))
2728 (define-cold-fop (fop-funcall)
2729 (multiple-value-bind (fun args) (pop-args (fasl-input))
2730 (if args
2731 (case fun
2732 (fdefinition
2733 ;; Special form #'F fopcompiles into `(FDEFINITION ,f)
2734 (aver (and (singleton-p args) (symbolp (car args))))
2735 (target-symbol-function (car args)))
2736 (cons (cold-cons (first args) (second args)))
2737 (symbol-global-value (cold-symbol-value (first args)))
2738 (t (call fun :sb-cold-funcall-handler/for-value args)))
2739 (let ((counter *load-time-value-counter*))
2740 (push (cold-list (cold-intern :load-time-value) fun
2741 (number-to-core counter)) *!cold-toplevels*)
2742 (setf *load-time-value-counter* (1+ counter))
2743 (make-descriptor 0 :load-time-value counter)))))
2745 (define-cold-fop (fop-funcall-for-effect)
2746 (multiple-value-bind (fun args) (pop-args (fasl-input))
2747 (if (not args)
2748 (push fun *!cold-toplevels*)
2749 (case fun
2750 (sb!impl::%defun (apply #'cold-fset args))
2751 (sb!kernel::%defstruct
2752 (push args *known-structure-classoids*)
2753 (push (apply #'cold-list (cold-intern 'defstruct) args)
2754 *!cold-toplevels*))
2755 (sb!c::%defconstant
2756 (destructuring-bind (name val . rest) args
2757 (cold-set name (if (symbolp val) (cold-intern val) val))
2758 (push (cold-cons (cold-intern name) (list-to-core rest))
2759 *!cold-defconstants*)))
2760 (set
2761 (aver (= (length args) 2))
2762 (cold-set (first args)
2763 (let ((val (second args)))
2764 (if (symbolp val) (cold-intern val) val))))
2765 (%svset (apply 'cold-svset args))
2766 (t (call fun :sb-cold-funcall-handler/for-effect args)))))))
2768 (defun finalize-load-time-value-noise ()
2769 (cold-set '*!load-time-values*
2770 (allocate-vector-object *dynamic*
2771 sb!vm:n-word-bits
2772 *load-time-value-counter*
2773 sb!vm:simple-vector-widetag)))
2776 ;;;; cold fops for fixing up circularities
2778 (define-cold-fop (fop-rplaca)
2779 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
2780 (idx (read-word-arg (fasl-input-stream))))
2781 (write-memory (cold-nthcdr idx obj) (pop-stack))))
2783 (define-cold-fop (fop-rplacd)
2784 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
2785 (idx (read-word-arg (fasl-input-stream))))
2786 (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack))))
2788 (define-cold-fop (fop-svset)
2789 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
2790 (idx (read-word-arg (fasl-input-stream))))
2791 (write-wordindexed obj
2792 (+ idx
2793 (ecase (descriptor-lowtag obj)
2794 (#.sb!vm:instance-pointer-lowtag 1)
2795 (#.sb!vm:other-pointer-lowtag 2)))
2796 (pop-stack))))
2798 (define-cold-fop (fop-structset)
2799 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
2800 (idx (read-word-arg (fasl-input-stream))))
2801 (write-wordindexed obj (+ idx sb!vm:instance-slots-offset) (pop-stack))))
2803 (define-cold-fop (fop-nthcdr)
2804 (cold-nthcdr (read-word-arg (fasl-input-stream)) (pop-stack)))
2806 (defun cold-nthcdr (index obj)
2807 (dotimes (i index)
2808 (setq obj (read-wordindexed obj sb!vm:cons-cdr-slot)))
2809 obj)
2811 ;;;; cold fops for loading code objects and functions
2813 (define-cold-fop (fop-note-debug-source)
2814 (let ((debug-source (pop-stack)))
2815 (cold-push debug-source *current-debug-sources*)))
2817 (define-cold-fop (fop-fdefn)
2818 (cold-fdefinition-object (pop-stack)))
2820 (define-cold-fop (fop-known-fun)
2821 (let* ((name (pop-stack))
2822 (fun (cold-fdefn-fun (cold-fdefinition-object name))))
2823 (if (cold-null fun) `(:known-fun . ,name) fun)))
2825 #!-(or x86 x86-64)
2826 (define-cold-fop (fop-sanctify-for-execution)
2827 (pop-stack))
2829 ;;; Setting this variable shows what code looks like before any
2830 ;;; fixups (or function headers) are applied.
2831 #!+sb-show (defvar *show-pre-fixup-code-p* nil)
2833 (defun cold-load-code (fasl-input nconst code-size)
2834 (macrolet ((pop-stack () '(pop-fop-stack (%fasl-input-stack fasl-input))))
2835 (let* ((raw-header-n-words (+ sb!vm:code-constants-offset nconst))
2836 (header-n-words
2837 ;; Note: we round the number of constants up to ensure
2838 ;; that the code vector will be properly aligned.
2839 (round-up raw-header-n-words 2))
2840 (des (allocate-cold-descriptor *dynamic*
2841 (+ (ash header-n-words
2842 sb!vm:word-shift)
2843 code-size)
2844 sb!vm:other-pointer-lowtag)))
2845 (write-header-word des header-n-words sb!vm:code-header-widetag)
2846 (write-wordindexed des
2847 sb!vm:code-code-size-slot
2848 (make-fixnum-descriptor code-size))
2849 (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
2850 (write-wordindexed des sb!vm:code-debug-info-slot (pop-stack))
2851 (when (oddp raw-header-n-words)
2852 (write-wordindexed des raw-header-n-words (make-descriptor 0)))
2853 (do ((index (1- raw-header-n-words) (1- index)))
2854 ((< index sb!vm:code-constants-offset))
2855 (let ((obj (pop-stack)))
2856 (if (and (consp obj) (eq (car obj) :known-fun))
2857 (push (list* (cdr obj) des index) *deferred-known-fun-refs*)
2858 (write-wordindexed des index obj))))
2859 (let* ((start (+ (descriptor-byte-offset des)
2860 (ash header-n-words sb!vm:word-shift)))
2861 (end (+ start code-size)))
2862 (read-bigvec-as-sequence-or-die (descriptor-bytes des)
2863 (%fasl-input-stream fasl-input)
2864 :start start
2865 :end end)
2866 #!+sb-show
2867 (when *show-pre-fixup-code-p*
2868 (format *trace-output*
2869 "~&/raw code from code-fop ~W ~W:~%"
2870 nconst
2871 code-size)
2872 (do ((i start (+ i sb!vm:n-word-bytes)))
2873 ((>= i end))
2874 (format *trace-output*
2875 "/#X~8,'0x: #X~8,'0x~%"
2876 (+ i (gspace-byte-address (descriptor-gspace des)))
2877 (bvref-32 (descriptor-bytes des) i)))))
2878 des)))
2880 (dotimes (i 16) ; occupies 16 cells in the dispatch table
2881 (setf (svref **fop-funs** (+ (get 'fop-code 'opcode) i))
2882 #'cold-load-code))
2884 (defun resolve-deferred-known-funs ()
2885 (dolist (item *deferred-known-fun-refs*)
2886 (let ((fun (cold-fdefn-fun (cold-fdefinition-object (car item)))))
2887 (aver (not (cold-null fun)))
2888 (let ((place (cdr item)))
2889 (write-wordindexed (car place) (cdr place) fun)))))
2891 (define-cold-fop (fop-alter-code (slot))
2892 (let ((value (pop-stack))
2893 (code (pop-stack)))
2894 (write-wordindexed code slot value)))
2896 (defvar *simple-fun-metadata* (make-hash-table :test 'equalp))
2898 ;; Return an expression that can be used to coalesce type-specifiers
2899 ;; and lambda lists attached to simple-funs. It doesn't have to be
2900 ;; a "correct" host representation, just something that preserves EQUAL-ness.
2901 (defun make-equal-comparable-thing (descriptor)
2902 (labels ((recurse (x)
2903 (cond ((cold-null x) (return-from recurse nil))
2904 ((is-fixnum-lowtag (descriptor-lowtag x))
2905 (return-from recurse (descriptor-fixnum x)))
2906 #!+64-bit
2907 ((is-other-immediate-lowtag (descriptor-lowtag x))
2908 (let ((bits (descriptor-bits x)))
2909 (when (= (logand bits sb!vm:widetag-mask)
2910 sb!vm:single-float-widetag)
2911 (return-from recurse `(:ffloat-bits ,bits))))))
2912 (ecase (descriptor-lowtag x)
2913 (#.sb!vm:list-pointer-lowtag
2914 (cons (recurse (cold-car x)) (recurse (cold-cdr x))))
2915 (#.sb!vm:other-pointer-lowtag
2916 (ecase (logand (descriptor-bits (read-memory x)) sb!vm:widetag-mask)
2917 (#.sb!vm:symbol-header-widetag
2918 (if (cold-null (read-wordindexed x sb!vm:symbol-package-slot))
2919 (get-or-make-uninterned-symbol
2920 (base-string-from-core
2921 (read-wordindexed x sb!vm:symbol-name-slot)))
2922 (warm-symbol x)))
2923 #!-64-bit
2924 (#.sb!vm:single-float-widetag
2925 `(:ffloat-bits
2926 ,(read-bits-wordindexed x sb!vm:single-float-value-slot)))
2927 (#.sb!vm:double-float-widetag
2928 `(:dfloat-bits
2929 ,(read-bits-wordindexed x sb!vm:double-float-value-slot)
2930 #!-64-bit
2931 ,(read-bits-wordindexed
2932 x (1+ sb!vm:double-float-value-slot))))
2933 (#.sb!vm:bignum-widetag
2934 (bignum-from-core x))
2935 (#.sb!vm:simple-base-string-widetag
2936 (base-string-from-core x))
2937 ;; Why do function lambda lists have simple-vectors in them?
2938 ;; Because we expose all &OPTIONAL and &KEY default forms.
2939 ;; I think this is abstraction leakage, except possibly for
2940 ;; advertised constant defaults of NIL and such.
2941 ;; How one expresses a value as a sexpr should otherwise
2942 ;; be of no concern to a user of the code.
2943 (#.sb!vm:simple-vector-widetag
2944 (vector-from-core x #'recurse))))))
2945 ;; Return a warm symbol whose name is similar to NAME, coaelescing
2946 ;; all occurrences of #:.WHOLE. across all files, e.g.
2947 (get-or-make-uninterned-symbol (name)
2948 (let ((key `(:uninterned-symbol ,name)))
2949 (or (gethash key *simple-fun-metadata*)
2950 (let ((symbol (make-symbol name)))
2951 (setf (gethash key *simple-fun-metadata*) symbol))))))
2952 (recurse descriptor)))
2954 (define-cold-fop (fop-fun-entry)
2955 (let* ((info (pop-stack))
2956 (type (pop-stack))
2957 (arglist (pop-stack))
2958 (name (pop-stack))
2959 (code-object (pop-stack))
2960 (offset (calc-offset code-object (read-word-arg (fasl-input-stream))))
2961 (fn (descriptor-beyond code-object
2962 offset
2963 sb!vm:fun-pointer-lowtag))
2964 (next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
2965 (unless (zerop (logand offset sb!vm:lowtag-mask))
2966 (error "unaligned function entry: ~S at #X~X" name offset))
2967 (write-wordindexed code-object sb!vm:code-entry-points-slot fn)
2968 (write-memory fn
2969 (make-other-immediate-descriptor
2970 (ash offset (- sb!vm:word-shift))
2971 sb!vm:simple-fun-header-widetag))
2972 (write-wordindexed fn
2973 sb!vm:simple-fun-self-slot
2974 ;; KLUDGE: Wiring decisions like this in at
2975 ;; this level ("if it's an x86") instead of a
2976 ;; higher level of abstraction ("if it has such
2977 ;; and such relocation peculiarities (which
2978 ;; happen to be confined to the x86)") is bad.
2979 ;; It would be nice if the code were instead
2980 ;; conditional on some more descriptive
2981 ;; feature, :STICKY-CODE or
2982 ;; :LOAD-GC-INTERACTION or something.
2984 ;; FIXME: The X86 definition of the function
2985 ;; self slot breaks everything object.tex says
2986 ;; about it. (As far as I can tell, the X86
2987 ;; definition makes it a pointer to the actual
2988 ;; code instead of a pointer back to the object
2989 ;; itself.) Ask on the mailing list whether
2990 ;; this is documented somewhere, and if not,
2991 ;; try to reverse engineer some documentation.
2992 #!-(or x86 x86-64)
2993 ;; a pointer back to the function object, as
2994 ;; described in CMU CL
2995 ;; src/docs/internals/object.tex
2997 #!+(or x86 x86-64)
2998 ;; KLUDGE: a pointer to the actual code of the
2999 ;; object, as described nowhere that I can find
3000 ;; -- WHN 19990907
3001 (make-descriptor ; raw bits that look like fixnum
3002 (+ (descriptor-bits fn)
3003 (- (ash sb!vm:simple-fun-code-offset
3004 sb!vm:word-shift)
3005 ;; FIXME: We should mask out the type
3006 ;; bits, not assume we know what they
3007 ;; are and subtract them out this way.
3008 sb!vm:fun-pointer-lowtag))))
3009 (write-wordindexed fn sb!vm:simple-fun-next-slot next)
3010 (write-wordindexed fn sb!vm:simple-fun-name-slot name)
3011 (flet ((coalesce (sexpr) ; a warm symbol or a cold cons tree
3012 (if (symbolp sexpr) ; will be cold-interned automatically
3013 sexpr
3014 (let ((representation (make-equal-comparable-thing sexpr)))
3015 (or (gethash representation *simple-fun-metadata*)
3016 (setf (gethash representation *simple-fun-metadata*)
3017 sexpr))))))
3018 (write-wordindexed fn sb!vm:simple-fun-arglist-slot (coalesce arglist))
3019 (write-wordindexed fn sb!vm:simple-fun-type-slot (coalesce type)))
3020 (write-wordindexed fn sb!vm::simple-fun-info-slot info)
3021 fn))
3023 #!+sb-thread
3024 (define-cold-fop (fop-symbol-tls-fixup)
3025 (let* ((symbol (pop-stack))
3026 (kind (pop-stack))
3027 (code-object (pop-stack)))
3028 (do-cold-fixup code-object
3029 (read-word-arg (fasl-input-stream))
3030 (ensure-symbol-tls-index symbol) kind)
3031 code-object))
3033 (define-cold-fop (fop-foreign-fixup)
3034 (let* ((kind (pop-stack))
3035 (code-object (pop-stack))
3036 (len (read-byte-arg (fasl-input-stream)))
3037 (sym (make-string len)))
3038 (read-string-as-bytes (fasl-input-stream) sym)
3039 #!+sb-dynamic-core
3040 (let ((offset (read-word-arg (fasl-input-stream)))
3041 (value (dyncore-note-symbol sym nil)))
3042 (do-cold-fixup code-object offset value kind))
3043 #!- (and) (format t "Bad non-plt fixup: ~S~S~%" sym code-object)
3044 #!-sb-dynamic-core
3045 (let ((offset (read-word-arg (fasl-input-stream)))
3046 (value (cold-foreign-symbol-address sym)))
3047 (do-cold-fixup code-object offset value kind))
3048 code-object))
3050 #!+linkage-table
3051 (define-cold-fop (fop-foreign-dataref-fixup)
3052 (let* ((kind (pop-stack))
3053 (code-object (pop-stack))
3054 (len (read-byte-arg (fasl-input-stream)))
3055 (sym (make-string len)))
3056 #!-sb-dynamic-core (declare (ignore code-object))
3057 (read-string-as-bytes (fasl-input-stream) sym)
3058 #!+sb-dynamic-core
3059 (let ((offset (read-word-arg (fasl-input-stream)))
3060 (value (dyncore-note-symbol sym t)))
3061 (do-cold-fixup code-object offset value kind)
3062 code-object)
3063 #!-sb-dynamic-core
3064 (progn
3065 (maphash (lambda (k v)
3066 (format *error-output* "~&~S = #X~8X~%" k v))
3067 *cold-foreign-symbol-table*)
3068 (error "shared foreign symbol in cold load: ~S (~S)" sym kind))))
3070 (define-cold-fop (fop-assembler-code)
3071 (let* ((length (read-word-arg (fasl-input-stream)))
3072 (header-n-words
3073 ;; Note: we round the number of constants up to ensure that
3074 ;; the code vector will be properly aligned.
3075 (round-up sb!vm:code-constants-offset 2))
3076 (des (allocate-cold-descriptor *read-only*
3077 (+ (ash header-n-words
3078 sb!vm:word-shift)
3079 length)
3080 sb!vm:other-pointer-lowtag)))
3081 (write-header-word des header-n-words sb!vm:code-header-widetag)
3082 (write-wordindexed des
3083 sb!vm:code-code-size-slot
3084 (make-fixnum-descriptor length))
3085 (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
3086 (write-wordindexed des sb!vm:code-debug-info-slot *nil-descriptor*)
3088 (let* ((start (+ (descriptor-byte-offset des)
3089 (ash header-n-words sb!vm:word-shift)))
3090 (end (+ start length)))
3091 (read-bigvec-as-sequence-or-die (descriptor-bytes des)
3092 (fasl-input-stream)
3093 :start start
3094 :end end))
3095 des))
3097 (define-cold-fop (fop-assembler-routine)
3098 (let* ((routine (pop-stack))
3099 (des (pop-stack))
3100 (offset (calc-offset des (read-word-arg (fasl-input-stream)))))
3101 (record-cold-assembler-routine
3102 routine
3103 (+ (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) offset))
3104 des))
3106 (define-cold-fop (fop-assembler-fixup)
3107 (let* ((routine (pop-stack))
3108 (kind (pop-stack))
3109 (code-object (pop-stack))
3110 (offset (read-word-arg (fasl-input-stream))))
3111 (record-cold-assembler-fixup routine code-object offset kind)
3112 code-object))
3114 (define-cold-fop (fop-code-object-fixup)
3115 (let* ((kind (pop-stack))
3116 (code-object (pop-stack))
3117 (offset (read-word-arg (fasl-input-stream)))
3118 (value (descriptor-bits code-object)))
3119 (do-cold-fixup code-object offset value kind)
3120 code-object))
3122 ;;;; sanity checking space layouts
3124 (defun check-spaces ()
3125 ;;; Co-opt type machinery to check for intersections...
3126 (let (types)
3127 (flet ((check (start end space)
3128 (unless (< start end)
3129 (error "Bogus space: ~A" space))
3130 (let ((type (specifier-type `(integer ,start ,end))))
3131 (dolist (other types)
3132 (unless (eq *empty-type* (type-intersection (cdr other) type))
3133 (error "Space overlap: ~A with ~A" space (car other))))
3134 (push (cons space type) types))))
3135 (check sb!vm:read-only-space-start sb!vm:read-only-space-end :read-only)
3136 (check sb!vm:static-space-start sb!vm:static-space-end :static)
3137 #!+gencgc
3138 (check sb!vm:dynamic-space-start sb!vm:dynamic-space-end :dynamic)
3139 #!-gencgc
3140 (progn
3141 (check sb!vm:dynamic-0-space-start sb!vm:dynamic-0-space-end :dynamic-0)
3142 (check sb!vm:dynamic-1-space-start sb!vm:dynamic-1-space-end :dynamic-1))
3143 #!+linkage-table
3144 (check sb!vm:linkage-table-space-start sb!vm:linkage-table-space-end :linkage-table))))
3146 ;;;; emitting C header file
3148 (defun tailwise-equal (string tail)
3149 (and (>= (length string) (length tail))
3150 (string= string tail :start1 (- (length string) (length tail)))))
3152 (defun write-boilerplate ()
3153 (format t "/*~%")
3154 (dolist (line
3155 '("This is a machine-generated file. Please do not edit it by hand."
3156 "(As of sbcl-0.8.14, it came from WRITE-CONFIG-H in genesis.lisp.)"
3158 "This file contains low-level information about the"
3159 "internals of a particular version and configuration"
3160 "of SBCL. It is used by the C compiler to create a runtime"
3161 "support environment, an executable program in the host"
3162 "operating system's native format, which can then be used to"
3163 "load and run 'core' files, which are basically programs"
3164 "in SBCL's own format."))
3165 (format t " *~@[ ~A~]~%" line))
3166 (format t " */~%"))
3168 (defun c-name (string &optional strip)
3169 (delete #\+
3170 (substitute-if #\_ (lambda (c) (member c '(#\- #\/ #\%)))
3171 (remove-if (lambda (c) (position c strip))
3172 string))))
3174 (defun c-symbol-name (symbol &optional strip)
3175 (c-name (symbol-name symbol) strip))
3177 (defun write-makefile-features ()
3178 ;; propagating *SHEBANG-FEATURES* into the Makefiles
3179 (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name
3180 sb-cold:*shebang-features*)
3181 #'string<))
3182 (format t "LISP_FEATURE_~A=1~%" shebang-feature-name)))
3184 (defun write-config-h ()
3185 ;; propagating *SHEBANG-FEATURES* into C-level #define's
3186 (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name
3187 sb-cold:*shebang-features*)
3188 #'string<))
3189 (format t "#define LISP_FEATURE_~A~%" shebang-feature-name))
3190 (terpri)
3191 ;; and miscellaneous constants
3192 (format t "#define SBCL_VERSION_STRING ~S~%"
3193 (sb!xc:lisp-implementation-version))
3194 (format t "#define CORE_MAGIC 0x~X~%" core-magic)
3195 (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
3196 (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
3197 (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
3198 (format t "#define LISPOBJ(thing) thing~2%")
3199 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")
3200 (terpri))
3202 (defun write-constants-h ()
3203 ;; writing entire families of named constants
3204 (let ((constants nil))
3205 (dolist (package-name '( ;; Even in CMU CL, constants from VM
3206 ;; were automatically propagated
3207 ;; into the runtime.
3208 "SB!VM"
3209 ;; In SBCL, we also propagate various
3210 ;; magic numbers related to file format,
3211 ;; which live here instead of SB!VM.
3212 "SB!FASL"))
3213 (do-external-symbols (symbol (find-package package-name))
3214 (when (constantp symbol)
3215 (let ((name (symbol-name symbol)))
3216 (labels ( ;; shared machinery
3217 (record (string priority suffix)
3218 (push (list string
3219 priority
3220 (symbol-value symbol)
3221 suffix
3222 (documentation symbol 'variable))
3223 constants))
3224 ;; machinery for old-style CMU CL Lisp-to-C
3225 ;; arbitrary renaming, being phased out in favor of
3226 ;; the newer systematic RECORD-WITH-TRANSLATED-NAME
3227 ;; renaming
3228 (record-with-munged-name (prefix string priority)
3229 (record (concatenate
3230 'simple-string
3231 prefix
3232 (delete #\- (string-capitalize string)))
3233 priority
3234 ""))
3235 (maybe-record-with-munged-name (tail prefix priority)
3236 (when (tailwise-equal name tail)
3237 (record-with-munged-name prefix
3238 (subseq name 0
3239 (- (length name)
3240 (length tail)))
3241 priority)))
3242 ;; machinery for new-style SBCL Lisp-to-C naming
3243 (record-with-translated-name (priority large)
3244 (record (c-name name) priority
3245 (if large
3246 #!+(and win32 x86-64) "LLU"
3247 #!-(and win32 x86-64) "LU"
3248 "")))
3249 (maybe-record-with-translated-name (suffixes priority &key large)
3250 (when (some (lambda (suffix)
3251 (tailwise-equal name suffix))
3252 suffixes)
3253 (record-with-translated-name priority large))))
3254 (maybe-record-with-translated-name '("-LOWTAG") 0)
3255 (maybe-record-with-translated-name '("-WIDETAG" "-SHIFT") 1)
3256 (maybe-record-with-munged-name "-FLAG" "flag_" 2)
3257 (maybe-record-with-munged-name "-TRAP" "trap_" 3)
3258 (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
3259 (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
3260 (maybe-record-with-translated-name '("-SIZE" "-INTERRUPTS") 6)
3261 (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES"
3262 "-CARD-BYTES" "-GRANULARITY")
3263 7 :large t)
3264 (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8)
3265 (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9)
3266 (maybe-record-with-translated-name '("-CORE-SPACE-ID-FLAG") 9)
3267 (maybe-record-with-translated-name '("-GENERATION+") 10))))))
3268 ;; KLUDGE: these constants are sort of important, but there's no
3269 ;; pleasing way to inform the code above about them. So we fake
3270 ;; it for now. nikodemus on #lisp (2004-08-09) suggested simply
3271 ;; exporting every numeric constant from SB!VM; that would work,
3272 ;; but the C runtime would have to be altered to use Lisp-like names
3273 ;; rather than the munged names currently exported. --njf, 2004-08-09
3274 (dolist (c '(sb!vm:n-word-bits sb!vm:n-word-bytes
3275 sb!vm:n-lowtag-bits sb!vm:lowtag-mask
3276 sb!vm:n-widetag-bits sb!vm:widetag-mask
3277 sb!vm:n-fixnum-tag-bits sb!vm:fixnum-tag-mask))
3278 (push (list (c-symbol-name c)
3279 -1 ; invent a new priority
3280 (symbol-value c)
3282 nil)
3283 constants))
3284 ;; One more symbol that doesn't fit into the code above.
3285 (let ((c 'sb!impl::+magic-hash-vector-value+))
3286 (push (list (c-symbol-name c)
3288 (symbol-value c)
3289 #!+(and win32 x86-64) "LLU"
3290 #!-(and win32 x86-64) "LU"
3291 nil)
3292 constants))
3293 (setf constants
3294 (sort constants
3295 (lambda (const1 const2)
3296 (if (= (second const1) (second const2))
3297 (if (= (third const1) (third const2))
3298 (string< (first const1) (first const2))
3299 (< (third const1) (third const2)))
3300 (< (second const1) (second const2))))))
3301 (let ((prev-priority (second (car constants))))
3302 (dolist (const constants)
3303 (destructuring-bind (name priority value suffix doc) const
3304 (unless (= prev-priority priority)
3305 (terpri)
3306 (setf prev-priority priority))
3307 (when (minusp value)
3308 (error "stub: negative values unsupported"))
3309 (format t "#define ~A ~A~A /* 0x~X ~@[ -- ~A ~]*/~%" name value suffix value doc))))
3310 (terpri))
3312 ;; writing information about internal errors
3313 ;; Assembly code needs only the constants for UNDEFINED_[ALIEN_]FUN_ERROR
3314 ;; but to avoid imparting that knowledge here, we'll expose all error
3315 ;; number constants except for OBJECT-NOT-<x>-ERROR ones.
3316 (loop for interr across sb!c:+backend-internal-errors+
3317 for i from 0
3318 when (stringp (car interr))
3319 do (format t "#define ~A ~D~%" (c-symbol-name (cdr interr)) i))
3320 ;; C code needs strings for describe_internal_error()
3321 (format t "#define INTERNAL_ERROR_NAMES ~{\\~%~S~^, ~}~2%"
3322 (map 'list 'sb!kernel::!c-stringify-internal-error
3323 sb!c:+backend-internal-errors+))
3325 ;; I'm not really sure why this is in SB!C, since it seems
3326 ;; conceptually like something that belongs to SB!VM. In any case,
3327 ;; it's needed C-side.
3328 (format t "#define BACKEND_PAGE_BYTES ~DLU~%" sb!c:*backend-page-bytes*)
3330 (terpri)
3332 ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between
3333 ;; platforms. If we export this from the SB!VM package, it gets
3334 ;; written out as #define trap_PseudoAtomic, which is confusing as
3335 ;; the runtime treats trap_ as the prefix for illegal instruction
3336 ;; type things. We therefore don't export it, but instead do
3337 #!+sparc
3338 (when (boundp 'sb!vm::pseudo-atomic-trap)
3339 (format t
3340 "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%"
3341 sb!vm::pseudo-atomic-trap)
3342 (terpri))
3343 ;; possibly this is another candidate for a rename (to
3344 ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
3345 ;; [possibly applicable to other platforms])
3347 #!+sb-safepoint
3348 (format t "#define GC_SAFEPOINT_PAGE_ADDR ((void*)0x~XUL) /* ~:*~A */~%"
3349 sb!vm:gc-safepoint-page-addr)
3351 (dolist (symbol '(sb!vm::float-traps-byte
3352 sb!vm::float-exceptions-byte
3353 sb!vm::float-sticky-bits
3354 sb!vm::float-rounding-mode))
3355 (format t "#define ~A_POSITION ~A /* ~:*0x~X */~%"
3356 (c-symbol-name symbol)
3357 (sb!xc:byte-position (symbol-value symbol)))
3358 (format t "#define ~A_MASK 0x~X /* ~:*~A */~%"
3359 (c-symbol-name symbol)
3360 (sb!xc:mask-field (symbol-value symbol) -1))))
3362 #!+sb-ldb
3363 (defun write-tagnames-h (&optional (out *standard-output*))
3364 (labels
3365 ((pretty-name (symbol strip)
3366 (let ((name (string-downcase symbol)))
3367 (substitute #\Space #\-
3368 (subseq name 0 (- (length name) (length strip))))))
3369 (list-sorted-tags (tail)
3370 (loop for symbol being the external-symbols of "SB!VM"
3371 when (and (constantp symbol)
3372 (tailwise-equal (string symbol) tail))
3373 collect symbol into tags
3374 finally (return (sort tags #'< :key #'symbol-value))))
3375 (write-tags (kind limit ash-count)
3376 (format out "~%static const char *~(~A~)_names[] = {~%"
3377 (subseq kind 1))
3378 (let ((tags (list-sorted-tags kind)))
3379 (dotimes (i limit)
3380 (if (eql i (ash (or (symbol-value (first tags)) -1) ash-count))
3381 (format out " \"~A\"" (pretty-name (pop tags) kind))
3382 (format out " \"unknown [~D]\"" i))
3383 (unless (eql i (1- limit))
3384 (write-string "," out))
3385 (terpri out)))
3386 (write-line "};" out)))
3387 (write-tags "-LOWTAG" sb!vm:lowtag-limit 0)
3388 ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG
3389 ;; ending with the same 2 bits. (#b10)
3390 (write-tags "-WIDETAG" (ash (1+ sb!vm:widetag-mask) -2) -2))
3391 ;; Inform print_otherptr() of all array types that it's too dumb to print
3392 (let ((array-type-bits (make-array 32 :initial-element 0)))
3393 (flet ((toggle (b)
3394 (multiple-value-bind (ofs bit) (floor b 8)
3395 (setf (aref array-type-bits ofs) (ash 1 bit)))))
3396 (dovector (saetp sb!vm:*specialized-array-element-type-properties*)
3397 (unless (or (typep (sb!vm:saetp-ctype saetp) 'character-set-type)
3398 (eq (sb!vm:saetp-specifier saetp) t))
3399 (toggle (sb!vm:saetp-typecode saetp))
3400 (awhen (sb!vm:saetp-complex-typecode saetp) (toggle it)))))
3401 (format out
3402 "~%static unsigned char unprintable_array_types[32] =~% {~{~d~^,~}};~%"
3403 (coerce array-type-bits 'list)))
3404 (values))
3406 (defun write-primitive-object (obj)
3407 ;; writing primitive object layouts
3408 (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
3409 (format t
3410 "struct ~A {~%"
3411 (c-name (string-downcase (string (sb!vm:primitive-object-name obj)))))
3412 (when (sb!vm:primitive-object-widetag obj)
3413 (format t " lispobj header;~%"))
3414 (dolist (slot (sb!vm:primitive-object-slots obj))
3415 (format t " ~A ~A~@[[1]~];~%"
3416 (getf (sb!vm:slot-options slot) :c-type "lispobj")
3417 (c-name (string-downcase (string (sb!vm:slot-name slot))))
3418 (sb!vm:slot-rest-p slot)))
3419 (format t "};~2%")
3420 (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
3421 (format t "/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%")
3422 (format t " * so they work directly on tagged addresses. */~2%")
3423 (let ((name (sb!vm:primitive-object-name obj))
3424 (lowtag (or (symbol-value (sb!vm:primitive-object-lowtag obj))
3425 0)))
3426 (dolist (slot (sb!vm:primitive-object-slots obj))
3427 (format t "#define ~A_~A_OFFSET ~D~%"
3428 (c-symbol-name name)
3429 (c-symbol-name (sb!vm:slot-name slot))
3430 (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
3431 (terpri))
3432 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
3434 (defun write-structure-object (dd)
3435 (flet ((cstring (designator)
3436 (c-name (string-downcase (string designator)))))
3437 (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
3438 (format t "struct ~A {~%" (cstring (dd-name dd)))
3439 (format t " lispobj header; // = word_0_~%")
3440 ;; "self layout" slots are named '_layout' instead of 'layout' so that
3441 ;; classoid's expressly declared layout isn't renamed as a special-case.
3442 (format t " lispobj _layout;~%")
3443 #!-interleaved-raw-slots
3444 (progn
3445 ;; Note: if the structure has no raw slots, but has an even number of
3446 ;; ordinary slots (incl. layout, sans header), then the last slot gets
3447 ;; named 'raw_slot_paddingN' (not 'paddingN')
3448 ;; The choice of name is mildly disturbing, but harmless.
3449 (dolist (slot (dd-slots dd))
3450 (when (eq t (dsd-raw-type slot))
3451 (format t " lispobj ~A;~%" (cstring (dsd-name slot)))))
3452 (unless (oddp (+ (dd-length dd) (dd-raw-length dd)))
3453 (format t " lispobj raw_slot_padding;~%"))
3454 (dotimes (n (dd-raw-length dd))
3455 (format t " lispobj raw~D;~%" (- (dd-raw-length dd) n 1))))
3456 #!+interleaved-raw-slots
3457 (let ((names ; round dd-length to odd so that total + header is even
3458 (coerce (loop for i from 1 below (logior (dd-length dd) 1)
3459 collect (list (format nil "word_~D_" (1+ i))))
3460 'vector)))
3461 (dolist (slot (dd-slots dd))
3462 (let ((cell (aref names (1- (dsd-index slot))))
3463 (name (cstring (dsd-name slot))))
3464 (if (eq (dsd-raw-type slot) t)
3465 (rplaca cell name)
3466 (rplacd cell name))))
3467 (loop for slot across names
3468 do (format t " lispobj ~A;~@[ //~A~]~%" (car slot) (cdr slot))))
3469 (format t "};~2%")
3470 (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")))
3472 (defun write-static-symbols ()
3473 (dolist (symbol (cons nil sb!vm:*static-symbols*))
3474 ;; FIXME: It would be nice to use longer names than NIL and
3475 ;; (particularly) T in #define statements.
3476 (format t "#define ~A LISPOBJ(0x~X)~%"
3477 ;; FIXME: It would be nice not to need to strip anything
3478 ;; that doesn't get stripped always by C-SYMBOL-NAME.
3479 (c-symbol-name symbol "%*.!")
3480 (if *static* ; if we ran GENESIS
3481 ;; We actually ran GENESIS, use the real value.
3482 (descriptor-bits (cold-intern symbol))
3483 ;; We didn't run GENESIS, so guess at the address.
3484 (+ sb!vm:static-space-start
3485 sb!vm:n-word-bytes
3486 sb!vm:other-pointer-lowtag
3487 (if symbol (sb!vm:static-symbol-offset symbol) 0))))))
3490 ;;;; writing map file
3492 ;;; Write a map file describing the cold load. Some of this
3493 ;;; information is subject to change due to relocating GC, but even so
3494 ;;; it can be very handy when attempting to troubleshoot the early
3495 ;;; stages of cold load.
3496 (defun write-map ()
3497 (let ((*print-pretty* nil)
3498 (*print-case* :upcase))
3499 (format t "assembler routines defined in core image:~2%")
3500 (dolist (routine (sort (copy-list *cold-assembler-routines*) #'<
3501 :key #'cdr))
3502 (format t "~8,'0X: ~S~%" (cdr routine) (car routine)))
3503 (let ((funs nil)
3504 (undefs nil))
3505 (maphash (lambda (name fdefn)
3506 (let ((fun (cold-fdefn-fun fdefn)))
3507 (if (cold-null fun)
3508 (push name undefs)
3509 (let ((addr (read-wordindexed
3510 fdefn sb!vm:fdefn-raw-addr-slot)))
3511 (push (cons name (descriptor-bits addr))
3512 funs)))))
3513 *cold-fdefn-objects*)
3514 (format t "~%~|~%initially defined functions:~2%")
3515 (setf funs (sort funs #'< :key #'cdr))
3516 (dolist (info funs)
3517 (format t "~8,'0X: ~S #X~8,'0X~%" (cdr info) (car info)
3518 (- (cdr info) #x17)))
3519 (format t
3520 "~%~|
3521 (a note about initially undefined function references: These functions
3522 are referred to by code which is installed by GENESIS, but they are not
3523 installed by GENESIS. This is not necessarily a problem; functions can
3524 be defined later, by cold init toplevel forms, or in files compiled and
3525 loaded at warm init, or elsewhere. As long as they are defined before
3526 they are called, everything should be OK. Things are also OK if the
3527 cross-compiler knew their inline definition and used that everywhere
3528 that they were called before the out-of-line definition is installed,
3529 as is fairly common for structure accessors.)
3530 initially undefined function references:~2%")
3532 (setf undefs (sort undefs #'string< :key #'fun-name-block-name))
3533 (dolist (name undefs)
3534 (format t "~8,'0X: ~S~%"
3535 (descriptor-bits (gethash name *cold-fdefn-objects*))
3536 name)))
3538 (format t "~%~|~%layout names:~2%")
3539 (dolist (x (sort-cold-layouts))
3540 (let* ((des (cdr x))
3541 (inherits (read-slot des *host-layout-of-layout* :inherits)))
3542 (format t "~8,'0X: ~S[~D]~%~10T~:S~%" (descriptor-bits des) (car x)
3543 (cold-layout-length des) (listify-cold-inherits inherits))))
3545 (format t "~%~|~%parsed type specifiers:~2%")
3546 (mapc (lambda (cell)
3547 (format t "~X: ~S~%" (descriptor-bits (cdr cell)) (car cell)))
3548 (sort (%hash-table-alist *ctype-cache*) #'<
3549 :key (lambda (x) (descriptor-bits (cdr x))))))
3550 (values))
3552 ;;;; writing core file
3554 (defvar *core-file*)
3555 (defvar *data-page*)
3557 ;;; magic numbers to identify entries in a core file
3559 ;;; (In case you were wondering: No, AFAIK there's no special magic about
3560 ;;; these which requires them to be in the 38xx range. They're just
3561 ;;; arbitrary words, tested not for being in a particular range but just
3562 ;;; for equality. However, if you ever need to look at a .core file and
3563 ;;; figure out what's going on, it's slightly convenient that they're
3564 ;;; all in an easily recognizable range, and displacing the range away from
3565 ;;; zero seems likely to reduce the chance that random garbage will be
3566 ;;; misinterpreted as a .core file.)
3567 (defconstant build-id-core-entry-type-code 3860)
3568 (defconstant new-directory-core-entry-type-code 3861)
3569 (defconstant initial-fun-core-entry-type-code 3863)
3570 (defconstant page-table-core-entry-type-code 3880)
3571 (defconstant end-core-entry-type-code 3840)
3573 (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))
3574 (defun write-word (num)
3575 (ecase sb!c:*backend-byte-order*
3576 (:little-endian
3577 (dotimes (i sb!vm:n-word-bytes)
3578 (write-byte (ldb (byte 8 (* i 8)) num) *core-file*)))
3579 (:big-endian
3580 (dotimes (i sb!vm:n-word-bytes)
3581 (write-byte (ldb (byte 8 (* (- (1- sb!vm:n-word-bytes) i) 8)) num)
3582 *core-file*))))
3583 num)
3585 (defun advance-to-page ()
3586 (force-output *core-file*)
3587 (file-position *core-file*
3588 (round-up (file-position *core-file*)
3589 sb!c:*backend-page-bytes*)))
3591 (defun output-gspace (gspace)
3592 (force-output *core-file*)
3593 (let* ((posn (file-position *core-file*))
3594 (bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes))
3595 (pages (ceiling bytes sb!c:*backend-page-bytes*))
3596 (total-bytes (* pages sb!c:*backend-page-bytes*)))
3598 (file-position *core-file*
3599 (* sb!c:*backend-page-bytes* (1+ *data-page*)))
3600 (format t
3601 "writing ~S byte~:P [~S page~:P] from ~S~%"
3602 total-bytes
3603 pages
3604 gspace)
3605 (force-output)
3607 ;; Note: It is assumed that the GSPACE allocation routines always
3608 ;; allocate whole pages (of size *target-page-size*) and that any
3609 ;; empty gspace between the free pointer and the end of page will
3610 ;; be zero-filled. This will always be true under Mach on machines
3611 ;; where the page size is equal. (RT is 4K, PMAX is 4K, Sun 3 is
3612 ;; 8K).
3613 (write-bigvec-as-sequence (gspace-bytes gspace)
3614 *core-file*
3615 :end total-bytes
3616 :pad-with-zeros t)
3617 (force-output *core-file*)
3618 (file-position *core-file* posn)
3620 ;; Write part of a (new) directory entry which looks like this:
3621 ;; GSPACE IDENTIFIER
3622 ;; WORD COUNT
3623 ;; DATA PAGE
3624 ;; ADDRESS
3625 ;; PAGE COUNT
3626 (write-word (gspace-identifier gspace))
3627 (write-word (gspace-free-word-index gspace))
3628 (write-word *data-page*)
3629 (multiple-value-bind (floor rem)
3630 (floor (gspace-byte-address gspace) sb!c:*backend-page-bytes*)
3631 (aver (zerop rem))
3632 (write-word floor))
3633 (write-word pages)
3635 (incf *data-page* pages)))
3637 ;;; Create a core file created from the cold loaded image. (This is
3638 ;;; the "initial core file" because core files could be created later
3639 ;;; by executing SAVE-LISP in a running system, perhaps after we've
3640 ;;; added some functionality to the system.)
3641 (declaim (ftype (function (string)) write-initial-core-file))
3642 (defun write-initial-core-file (filename)
3644 (let ((filenamestring (namestring filename))
3645 (*data-page* 0))
3647 (format t
3648 "[building initial core file in ~S: ~%"
3649 filenamestring)
3650 (force-output)
3652 (with-open-file (*core-file* filenamestring
3653 :direction :output
3654 :element-type '(unsigned-byte 8)
3655 :if-exists :rename-and-delete)
3657 ;; Write the magic number.
3658 (write-word core-magic)
3660 ;; Write the build ID.
3661 (write-word build-id-core-entry-type-code)
3662 (let ((build-id (with-open-file (s "output/build-id.tmp")
3663 (read s))))
3664 (declare (type simple-string build-id))
3665 (/show build-id (length build-id))
3666 ;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE
3667 ;; word, this length word, and one word for each char of BUILD-ID.
3668 (write-word (+ 2 (length build-id)))
3669 (dovector (char build-id)
3670 ;; (We write each character as a word in order to avoid
3671 ;; having to think about word alignment issues in the
3672 ;; sbcl-0.7.8 version of coreparse.c.)
3673 (write-word (sb!xc:char-code char))))
3675 ;; Write the New Directory entry header.
3676 (write-word new-directory-core-entry-type-code)
3677 (write-word 17) ; length = (5 words/space) * 3 spaces + 2 for header.
3679 (output-gspace *read-only*)
3680 (output-gspace *static*)
3681 (output-gspace *dynamic*)
3683 ;; Write the initial function.
3684 (write-word initial-fun-core-entry-type-code)
3685 (write-word 3)
3686 (let* ((cold-name (cold-intern '!cold-init))
3687 (initial-fun
3688 (cold-fdefn-fun (cold-fdefinition-object cold-name))))
3689 (format t
3690 "~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%"
3691 (descriptor-bits initial-fun))
3692 (write-word (descriptor-bits initial-fun)))
3694 ;; Write the End entry.
3695 (write-word end-core-entry-type-code)
3696 (write-word 2)))
3698 (format t "done]~%")
3699 (force-output)
3700 (/show "leaving WRITE-INITIAL-CORE-FILE")
3701 (values))
3703 ;;;; the actual GENESIS function
3705 ;;; Read the FASL files in OBJECT-FILE-NAMES and produce a Lisp core,
3706 ;;; and/or information about a Lisp core, therefrom.
3708 ;;; input file arguments:
3709 ;;; SYMBOL-TABLE-FILE-NAME names a UNIX-style .nm file *with* *any*
3710 ;;; *tab* *characters* *converted* *to* *spaces*. (We push
3711 ;;; responsibility for removing tabs out to the caller it's
3712 ;;; trivial to remove them using UNIX command line tools like
3713 ;;; sed, whereas it's a headache to do it portably in Lisp because
3714 ;;; #\TAB is not a STANDARD-CHAR.) If this file is not supplied,
3715 ;;; a core file cannot be built (but a C header file can be).
3717 ;;; output files arguments (any of which may be NIL to suppress output):
3718 ;;; CORE-FILE-NAME gets a Lisp core.
3719 ;;; C-HEADER-FILE-NAME gets a C header file, traditionally called
3720 ;;; internals.h, which is used by the C compiler when constructing
3721 ;;; the executable which will load the core.
3722 ;;; MAP-FILE-NAME gets (?) a map file. (dunno about this -- WHN 19990815)
3724 ;;; FIXME: GENESIS doesn't belong in SB!VM. Perhaps in %KERNEL for now,
3725 ;;; perhaps eventually in SB-LD or SB-BOOT.
3726 (defun sb!vm:genesis (&key
3727 object-file-names
3728 symbol-table-file-name
3729 core-file-name
3730 map-file-name
3731 c-header-dir-name
3732 #+nil (list-objects t))
3733 #!+sb-dynamic-core
3734 (declare (ignorable symbol-table-file-name))
3736 (format t
3737 "~&beginning GENESIS, ~A~%"
3738 (if core-file-name
3739 ;; Note: This output summarizing what we're doing is
3740 ;; somewhat telegraphic in style, not meant to imply that
3741 ;; we're not e.g. also creating a header file when we
3742 ;; create a core.
3743 (format nil "creating core ~S" core-file-name)
3744 (format nil "creating headers in ~S" c-header-dir-name)))
3746 (let ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
3748 #!-sb-dynamic-core
3749 (when core-file-name
3750 (if symbol-table-file-name
3751 (load-cold-foreign-symbol-table symbol-table-file-name)
3752 (error "can't output a core file without symbol table file input")))
3754 #!+sb-dynamic-core
3755 (progn
3756 (setf (gethash (extern-alien-name "undefined_tramp")
3757 *cold-foreign-symbol-table*)
3758 (dyncore-note-symbol "undefined_tramp" nil))
3759 (dyncore-note-symbol "undefined_alien_function" nil))
3761 ;; Now that we've successfully read our only input file (by
3762 ;; loading the symbol table, if any), it's a good time to ensure
3763 ;; that there'll be someplace for our output files to go when
3764 ;; we're done.
3765 (flet ((frob (filename)
3766 (when filename
3767 (ensure-directories-exist filename :verbose t))))
3768 (frob core-file-name)
3769 (frob map-file-name))
3771 ;; (This shouldn't matter in normal use, since GENESIS normally
3772 ;; only runs once in any given Lisp image, but it could reduce
3773 ;; confusion if we ever experiment with running, tweaking, and
3774 ;; rerunning genesis interactively.)
3775 (do-all-symbols (sym)
3776 (remprop sym 'cold-intern-info))
3778 (check-spaces)
3780 (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0))
3781 (*load-time-value-counter* 0)
3782 (*cold-fdefn-objects* (make-hash-table :test 'equal))
3783 (*cold-symbols* (make-hash-table :test 'eql)) ; integer keys
3784 (*cold-package-symbols* (make-hash-table :test 'equal)) ; string keys
3785 (pkg-metadata (sb-cold::package-list-for-genesis))
3786 (*read-only* (make-gspace :read-only
3787 read-only-core-space-id
3788 sb!vm:read-only-space-start))
3789 (*static* (make-gspace :static
3790 static-core-space-id
3791 sb!vm:static-space-start))
3792 (*dynamic* (make-gspace :dynamic
3793 dynamic-core-space-id
3794 #!+gencgc sb!vm:dynamic-space-start
3795 #!-gencgc sb!vm:dynamic-0-space-start))
3796 ;; There's a cyclic dependency here: NIL refers to a package;
3797 ;; a package needs its layout which needs others layouts
3798 ;; which refer to NIL, which refers to a package ...
3799 ;; Break the cycle by preallocating packages without a layout.
3800 ;; This avoids having to track any symbols created prior to
3801 ;; creation of packages, since packages are primordial.
3802 (target-cl-pkg-info
3803 (dolist (name (list* "COMMON-LISP" "COMMON-LISP-USER" "KEYWORD"
3804 (mapcar #'sb-cold:package-data-name
3805 pkg-metadata))
3806 (gethash "COMMON-LISP" *cold-package-symbols*))
3807 (setf (gethash name *cold-package-symbols*)
3808 (cons (allocate-struct
3809 *dynamic* (make-fixnum-descriptor 0)
3810 (layout-length (find-layout 'package)))
3811 (cons nil nil))))) ; (externals . internals)
3812 (*nil-descriptor* (make-nil-descriptor target-cl-pkg-info))
3813 (*known-structure-classoids* nil)
3814 (*classoid-cells* (make-hash-table :test 'eq))
3815 (*ctype-cache* (make-hash-table :test 'equal))
3816 (*!cold-defconstants* nil)
3817 (*!cold-defuns* nil)
3818 (*!cold-toplevels* nil)
3819 (*current-debug-sources* *nil-descriptor*)
3820 (*unbound-marker* (make-other-immediate-descriptor
3822 sb!vm:unbound-marker-widetag))
3823 *cold-assembler-fixups*
3824 *cold-assembler-routines*
3825 (*deferred-known-fun-refs* nil)
3826 #!+x86 (*load-time-code-fixups* (make-hash-table)))
3828 ;; Prepare for cold load.
3829 (initialize-non-nil-symbols)
3830 (initialize-layouts)
3831 (initialize-packages
3832 ;; docstrings are set in src/cold/warm. It would work to do it here,
3833 ;; but seems preferable not to saddle Genesis with such responsibility.
3834 (list* (sb-cold:make-package-data :name "COMMON-LISP" :doc nil)
3835 (sb-cold:make-package-data :name "KEYWORD" :doc nil)
3836 (sb-cold:make-package-data :name "COMMON-LISP-USER" :doc nil
3837 :use '("COMMON-LISP"
3838 ;; ANSI encourages us to put extension packages
3839 ;; in the USE list of COMMON-LISP-USER.
3840 "SB!ALIEN" "SB!DEBUG" "SB!EXT" "SB!GRAY" "SB!PROFILE"))
3841 pkg-metadata))
3842 (initialize-static-fns)
3844 ;; Initialize the *COLD-SYMBOLS* system with the information
3845 ;; from common-lisp-exports.lisp-expr.
3846 ;; Packages whose names match SB!THING were set up on the host according
3847 ;; to "package-data-list.lisp-expr" which expresses the desired target
3848 ;; package configuration, so we can just mirror the host into the target.
3849 ;; But by waiting to observe calls to COLD-INTERN that occur during the
3850 ;; loading of the cross-compiler's outputs, it is possible to rid the
3851 ;; target of accidental leftover symbols, not that it wouldn't also be
3852 ;; a good idea to clean up package-data-list once in a while.
3853 (dolist (exported-name
3854 (sb-cold:read-from-file "common-lisp-exports.lisp-expr"))
3855 (cold-intern (intern exported-name *cl-package*) :access :external))
3857 ;; Create SB!KERNEL::*TYPE-CLASSES* as an array of NIL
3858 (cold-set (cold-intern 'sb!kernel::*type-classes*)
3859 (vector-in-core (make-list (length sb!kernel::*type-classes*))))
3861 ;; Cold load.
3862 (dolist (file-name object-file-names)
3863 (write-line (namestring file-name))
3864 (cold-load file-name))
3866 (when *known-structure-classoids*
3867 (let ((dd-layout (find-layout 'defstruct-description)))
3868 (dolist (defstruct-args *known-structure-classoids*)
3869 (let* ((dd (first defstruct-args))
3870 (name (warm-symbol (read-slot dd dd-layout :name)))
3871 (layout (gethash name *cold-layouts*)))
3872 (aver layout)
3873 (write-slots layout *host-layout-of-layout* :info dd))))
3874 (format t "~&; SB!Loader: (~D+~D+~D+~D) structs/consts/funs/other~%"
3875 (length *known-structure-classoids*)
3876 (length *!cold-defconstants*)
3877 (length *!cold-defuns*)
3878 (length *!cold-toplevels*)))
3880 (dolist (symbol '(*!cold-defconstants* *!cold-defuns* *!cold-toplevels*))
3881 (cold-set symbol (list-to-core (nreverse (symbol-value symbol))))
3882 (makunbound symbol)) ; so no further PUSHes can be done
3884 ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
3885 (resolve-deferred-known-funs)
3886 (resolve-assembler-fixups)
3887 #!+x86 (output-load-time-code-fixups)
3888 (foreign-symbols-to-core)
3889 (finish-symbols)
3890 (/show "back from FINISH-SYMBOLS")
3891 (finalize-load-time-value-noise)
3893 ;; Tell the target Lisp how much stuff we've allocated.
3894 (cold-set 'sb!vm:*read-only-space-free-pointer*
3895 (allocate-cold-descriptor *read-only*
3897 sb!vm:even-fixnum-lowtag))
3898 (cold-set 'sb!vm:*static-space-free-pointer*
3899 (allocate-cold-descriptor *static*
3901 sb!vm:even-fixnum-lowtag))
3902 (/show "done setting free pointers")
3904 ;; Write results to files.
3906 ;; FIXME: I dislike this approach of redefining
3907 ;; *STANDARD-OUTPUT* instead of putting the new stream in a
3908 ;; lexical variable, and it's annoying to have WRITE-MAP (to
3909 ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE
3910 ;; (to a stream explicitly passed as an argument).
3911 (macrolet ((out-to (name &body body)
3912 `(let ((fn (format nil "~A/~A.h" c-header-dir-name ,name)))
3913 (ensure-directories-exist fn)
3914 (with-open-file (*standard-output* fn
3915 :if-exists :supersede :direction :output)
3916 (write-boilerplate)
3917 (let ((n (c-name (string-upcase ,name))))
3918 (format
3920 "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~A 1~%"
3921 n n))
3922 ,@body
3923 (format t
3924 "#endif /* SBCL_GENESIS_~A */~%"
3925 (string-upcase ,name))))))
3926 (when map-file-name
3927 (with-open-file (*standard-output* map-file-name
3928 :direction :output
3929 :if-exists :supersede)
3930 (write-map)))
3931 (out-to "config" (write-config-h))
3932 (out-to "constants" (write-constants-h))
3933 #!+sb-ldb
3934 (out-to "tagnames" (write-tagnames-h))
3935 (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
3936 :key (lambda (obj)
3937 (symbol-name
3938 (sb!vm:primitive-object-name obj))))))
3939 (dolist (obj structs)
3940 (out-to
3941 (string-downcase (string (sb!vm:primitive-object-name obj)))
3942 (write-primitive-object obj)))
3943 (out-to "primitive-objects"
3944 (dolist (obj structs)
3945 (format t "~&#include \"~A.h\"~%"
3946 (string-downcase
3947 (string (sb!vm:primitive-object-name obj)))))))
3948 (dolist (class '(hash-table
3949 classoid
3950 layout
3951 sb!c::compiled-debug-info
3952 sb!c::compiled-debug-fun
3953 package))
3954 (out-to
3955 (string-downcase (string class))
3956 (write-structure-object
3957 (layout-info (find-layout class)))))
3958 (out-to "static-symbols" (write-static-symbols))
3960 (let ((fn (format nil "~A/Makefile.features" c-header-dir-name)))
3961 (ensure-directories-exist fn)
3962 (with-open-file (*standard-output* fn :if-exists :supersede
3963 :direction :output)
3964 (write-makefile-features)))
3966 (when core-file-name
3967 (write-initial-core-file core-file-name))))))
3969 ;;; Invert the action of HOST-CONSTANT-TO-CORE. If STRICTP is given as NIL,
3970 ;;; then we can produce a host object even if it is not a faithful rendition.
3971 (defun host-object-from-core (descriptor &optional (strictp t))
3972 (named-let recurse ((x descriptor))
3973 (when (cold-null x)
3974 (return-from recurse nil))
3975 (when (eq (descriptor-gspace x) :load-time-value)
3976 (error "Can't warm a deferred LTV placeholder"))
3977 (when (is-fixnum-lowtag (descriptor-lowtag x))
3978 (return-from recurse (descriptor-fixnum x)))
3979 (ecase (descriptor-lowtag x)
3980 (#.sb!vm:list-pointer-lowtag
3981 (cons (recurse (cold-car x)) (recurse (cold-cdr x))))
3982 (#.sb!vm:fun-pointer-lowtag
3983 (if strictp
3984 (error "Can't map cold-fun -> warm-fun")
3985 (let ((name (read-wordindexed x sb!vm:simple-fun-name-slot)))
3986 `(function ,(recurse name)))))
3987 (#.sb!vm:other-pointer-lowtag
3988 (let ((widetag (logand (descriptor-bits (read-memory x))
3989 sb!vm:widetag-mask)))
3990 (ecase widetag
3991 (#.sb!vm:symbol-header-widetag
3992 (if strictp
3993 (warm-symbol x)
3994 (or (gethash (descriptor-bits x) *cold-symbols*) ; first try
3995 (make-symbol
3996 (recurse (read-wordindexed x sb!vm:symbol-name-slot))))))
3997 (#.sb!vm:simple-base-string-widetag (base-string-from-core x))
3998 (#.sb!vm:simple-vector-widetag (vector-from-core x #'recurse))
3999 (#.sb!vm:bignum-widetag (bignum-from-core x))))))))