1 ;;;; "cold" core image builder: This is how we create a target Lisp
2 ;;;; system from scratch, by converting from fasl files to an image
3 ;;;; file in the cross-compilation host, without the help of the
4 ;;;; target Lisp system.
6 ;;;; As explained by Rob MacLachlan on the CMU CL mailing list Wed, 06
7 ;;;; Jan 1999 11:05:02 -0500, this cold load generator more or less
8 ;;;; fakes up static function linking. I.e. it makes sure that all the
9 ;;;; DEFUN-defined functions in the fasl files it reads are bound to the
10 ;;;; corresponding symbols before execution starts. It doesn't do
11 ;;;; anything to initialize variable values; instead it just arranges
12 ;;;; for !COLD-INIT to be called at cold load time. !COLD-INIT is
13 ;;;; responsible for explicitly initializing anything which has to be
14 ;;;; initialized early before it transfers control to the ordinary
17 ;;;; (In CMU CL, and in SBCL as of 0.6.9 anyway, functions not defined
18 ;;;; by DEFUN aren't set up specially by GENESIS.)
20 ;;;; This software is part of the SBCL system. See the README file for
21 ;;;; more information.
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
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
+
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
57 `(simple-array (unsigned-byte 8) (,+smallvec-length
+)))
59 (defun make-smallvec ()
60 (make-array +smallvec-length
+ :element-type
'(unsigned-byte 8)
63 ;;; a big vector, implemented as a vector of SMALLVECs
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
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
+)
85 (svref (bigvec-outer-vector bigvec
) outer-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
))
95 ;;; analogous to LENGTH, but for a BIGVEC
97 ;;; the length of BIGVEC, measured in the number of BVREFable bytes it
99 (defun bvlength (bigvec)
100 (* (length (bigvec-outer-vector bigvec
))
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
)
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 (replace new-outer-vector old-outer-vector
)
126 (loop for i from length-old-outer-vector below
(length new-outer-vector
) do
127 (setf (svref new-outer-vector i
)
129 (setf (bigvec-outer-vector bigvec
)
133 ;;;; looking up bytes and multi-byte values in a BIGVEC (considering
134 ;;;; it as an image of machine memory on the cross-compilation target)
136 ;;; BVREF-32 and friends. These are like SAP-REF-n, except that
137 ;;; instead of a SAP we use a BIGVEC.
138 (macrolet ((make-bvref-n (n)
139 (let ((name (intern (format nil
"BVREF-~A" n
)))
141 (loop with n-octets
= (/ n
8)
142 for i from
0 below n-octets
143 collect
`(+ byte-index
#!+big-endian
,(- n-octets i
1)
146 (defun ,name
(bigvec byte-index
)
147 (logior ,@(loop for index in le-octet-indices
149 collect
`(ash (bvref bigvec
,index
) ,(* i
8)))))
150 (defun (setf ,name
) (new-value bigvec byte-index
)
151 ;; We don't carefully distinguish between signed and unsigned,
152 ;; since there's only one setter function per byte size.
153 (declare (type (or (signed-byte ,n
) (unsigned-byte ,n
))
155 (setf ,@(loop for index in le-octet-indices
157 append
`((bvref bigvec
,index
)
158 (ldb (byte 8 ,(* i
8)) new-value
)))))))))
164 ;; lispobj-sized word, whatever that may be
165 ;; hopefully nobody ever wants a 128-bit SBCL...
166 (macrolet ((acc (bv index
) `(#!+64-bit bvref-64
#!-
64-bit bvref-32
,bv
,index
)))
167 (defun (setf bvref-word
) (new-val bytes index
) (setf (acc bytes index
) new-val
))
168 (defun bvref-word (bytes index
) (acc bytes index
)))
170 ;;;; representation of spaces in the core
172 ;;; If there is more than one dynamic space in memory (i.e., if a
173 ;;; copying GC is in use), then only the active dynamic space gets
176 (defconstant dynamic-core-space-id
1)
179 (defconstant static-core-space-id
2)
182 (defconstant read-only-core-space-id
3)
186 (defvar *immobile-fixedobj
*)
187 (defvar *immobile-varyobj
*)
188 (defconstant immobile-fixedobj-core-space-id
4)
189 (defconstant immobile-varyobj-core-space-id
5)
190 (defvar *immobile-space-map
* nil
))
192 (defconstant max-core-space-id
5)
193 (defconstant deflated-core-space-id-flag
8)
195 ;;; a GENESIS-time representation of a memory space (e.g. read-only
196 ;;; space, dynamic space, or static space)
197 (defstruct (gspace (:constructor %make-gspace
)
199 ;; name and identifier for this GSPACE
200 (name (missing-arg) :type symbol
:read-only t
)
201 (identifier (missing-arg) :type fixnum
:read-only t
)
202 ;; the word address where the data will be loaded
203 (word-address (missing-arg) :type unsigned-byte
:read-only t
)
204 ;; the gspace contents as a BIGVEC
205 (data (make-bigvec) :type bigvec
:read-only t
)
206 ;; the index of the next unwritten word (i.e. chunk of
207 ;; SB!VM:N-WORD-BYTES bytes) in DATA, or equivalently the number of
208 ;; words actually written in DATA. In order to convert to an actual
209 ;; index into DATA, thus must be multiplied by SB!VM:N-WORD-BYTES.
212 (defun gspace-byte-address (gspace)
213 (ash (gspace-word-address gspace
) sb
!vm
:word-shift
))
215 (cl:defmethod
print-object ((gspace gspace
) stream
)
216 (print-unreadable-object (gspace stream
:type t
)
217 (format stream
"@#x~X ~S" (gspace-byte-address gspace
) (gspace-name gspace
))))
219 (defun make-gspace (name identifier byte-address
)
220 ;; Genesis should be agnostic of space alignment except in so far as it must
221 ;; be a multiple of the backend page size. We used to care more, in that
222 ;; descriptor-bits were composed of a high half and low half for the
223 ;; questionable motive of caring about fixnum-ness of the halves,
224 ;; despite the wonderful abstraction INTEGER that transparently becomes
225 ;; a BIGNUM if the host's fixnum is limited in size.
226 ;; So it's not clear whether this test belongs here, because if we do need it,
227 ;; then it best belongs where we assign space addresses in the first place.
228 (let ((target-space-alignment (ash 1 16)))
229 (unless (zerop (rem byte-address target-space-alignment
))
230 (error "The byte address #X~X is not aligned on a #X~X-byte boundary."
231 byte-address target-space-alignment
)))
232 (%make-gspace
:name name
233 :identifier identifier
234 :word-address
(ash byte-address
(- sb
!vm
:word-shift
))))
236 ;;;; representation of descriptors
238 (declaim (inline is-fixnum-lowtag
))
239 (defun is-fixnum-lowtag (lowtag)
240 (zerop (logand lowtag sb
!vm
:fixnum-tag-mask
)))
242 (defun is-other-immediate-lowtag (lowtag)
243 ;; The other-immediate lowtags are similar to the fixnum lowtags, in
244 ;; that they have an "effective length" that is shorter than is used
245 ;; for the pointer lowtags. Unlike the fixnum lowtags, however, the
246 ;; other-immediate lowtags are always effectively two bits wide.
247 (= (logand lowtag
3) sb
!vm
:other-immediate-0-lowtag
))
249 (defstruct (descriptor
250 (:constructor make-descriptor
(bits &optional gspace word-offset
))
252 ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
253 (gspace nil
:type
(or gspace
(eql :load-time-value
) null
))
254 ;; the offset in words from the start of GSPACE, or NIL if not set yet
255 (word-offset nil
:type
(or sb
!vm
:word null
))
256 (bits 0 :read-only t
:type
(unsigned-byte #.sb
!vm
:n-machine-word-bits
)))
258 (declaim (inline descriptor
=))
259 (defun descriptor= (a b
) (eql (descriptor-bits a
) (descriptor-bits b
)))
261 (defun make-random-descriptor (bits)
262 (make-descriptor (logand bits sb
!ext
:most-positive-word
)))
264 (declaim (inline descriptor-lowtag
))
265 (defun descriptor-lowtag (des)
266 "the lowtag bits for DES"
267 (logand (descriptor-bits des
) sb
!vm
:lowtag-mask
))
269 (defmethod print-object ((des descriptor
) stream
)
270 (let ((gspace (descriptor-gspace des
))
271 (bits (descriptor-bits des
))
272 (lowtag (descriptor-lowtag des
)))
273 (print-unreadable-object (des stream
:type t
)
274 (cond ((eq gspace
:load-time-value
)
275 (format stream
"for LTV ~D" (descriptor-word-offset des
)))
276 ((is-fixnum-lowtag lowtag
)
277 (format stream
"for fixnum: ~W" (descriptor-fixnum des
)))
278 ((is-other-immediate-lowtag lowtag
)
280 "for other immediate: #X~X, type #b~8,'0B"
281 (ash bits
(- sb
!vm
:n-widetag-bits
))
282 (logand bits sb
!vm
:widetag-mask
)))
285 "for pointer: #X~X, lowtag #b~v,'0B, ~A"
286 (logandc2 bits sb
!vm
:lowtag-mask
)
287 sb
!vm
:n-lowtag-bits lowtag
288 (if gspace
(gspace-name gspace
) "unknown")))))))
290 ;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The
291 ;;; free word index is boosted as necessary, and if additional memory
292 ;;; is needed, we grow the GSPACE. The descriptor returned is a
293 ;;; pointer of type LOWTAG.
294 (defun allocate-cold-descriptor (gspace length lowtag
&optional page-attributes
)
296 (gspace-claim-n-bytes gspace length page-attributes
))
297 (ptr (+ (gspace-word-address gspace
) word-index
)))
298 (make-descriptor (logior (ash ptr sb
!vm
:word-shift
) lowtag
)
302 (defun gspace-claim-n-words (gspace n-words
)
303 (let* ((old-free-word-index (gspace-free-word-index gspace
))
304 (new-free-word-index (+ old-free-word-index n-words
)))
305 ;; Grow GSPACE as necessary until it's big enough to handle
306 ;; NEW-FREE-WORD-INDEX.
308 ((>= (bvlength (gspace-data gspace
))
309 (* new-free-word-index sb
!vm
:n-word-bytes
)))
310 (expand-bigvec (gspace-data gspace
)))
311 ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it.
312 (setf (gspace-free-word-index gspace
) new-free-word-index
)
313 old-free-word-index
))
315 ;; align256p is true if we need to force objects on this page to 256-byte
316 ;; boundaries. This doesn't need to be generalized - everything of type
317 ;; INSTANCE is either on its natural alignment, or 256-byte.
318 ;; [See doc/internals-notes/compact-instance for why you might want it at all]
319 ;; PAGE-KIND is a heuristic for placement of symbols
320 ;; based on being interned/uninterned/likely-special-variable.
321 (defun make-page-attributes (align256p page-kind
)
322 (declare (type (or null
(integer 0 3)) page-kind
))
323 (logior (ash (or page-kind
0) 1) (if align256p
1 0)))
324 (defun immobile-obj-spacing-words (page-attributes)
325 (if (logbitp 0 page-attributes
)
326 (/ 256 sb
!vm
:n-word-bytes
)))
328 (defun gspace-claim-n-bytes (gspace specified-n-bytes page-attributes
)
329 (declare (ignorable page-attributes
))
330 (let* ((n-bytes (round-up specified-n-bytes
(ash 1 sb
!vm
:n-lowtag-bits
)))
331 (n-words (ash n-bytes
(- sb
!vm
:word-shift
))))
332 (aver (evenp n-words
))
333 (cond #!+immobile-space
334 ((eq gspace
*immobile-fixedobj
*)
335 (aver page-attributes
)
336 ;; An immobile fixedobj page can only have one value of object-spacing
337 ;; and size for all objects on it. Different widetags are ok.
338 (let* ((key (cons specified-n-bytes page-attributes
))
339 (found (cdr (assoc key
*immobile-space-map
* :test
'equal
)))
340 (page-n-words (/ sb
!vm
:immobile-card-bytes sb
!vm
:n-word-bytes
)))
341 (unless found
; grab one whole GC page from immobile space
342 (let ((free-word-index
343 (gspace-claim-n-words gspace page-n-words
)))
344 (setf found
(cons 0 free-word-index
))
345 (push (cons key found
) *immobile-space-map
*)))
346 (destructuring-bind (page-word-index . page-base-index
) found
349 (or (immobile-obj-spacing-words page-attributes
)
351 (if (> next-word
(- page-n-words n-words
))
352 ;; no more objects fit on this page
353 (setf *immobile-space-map
*
354 (delete key
*immobile-space-map
* :key
'car
:test
'equal
))
355 (setf (car found
) next-word
)))
356 (+ page-word-index page-base-index
))))
358 (gspace-claim-n-words gspace n-words
)))))
360 (defun descriptor-fixnum (des)
361 (unless (is-fixnum-lowtag (descriptor-lowtag des
))
362 (error "descriptor-fixnum called on non-fixnum ~S" des
))
363 (let* ((descriptor-bits (descriptor-bits des
))
364 (bits (ash descriptor-bits
(- sb
!vm
:n-fixnum-tag-bits
))))
365 (if (logbitp (1- sb
!vm
:n-word-bits
) descriptor-bits
)
366 (logior bits
(ash -
1 (1+ sb
!vm
:n-positive-fixnum-bits
)))
369 (defun descriptor-word-sized-integer (des)
370 ;; Extract an (unsigned-byte 32), from either its fixnum or bignum
372 (let ((lowtag (descriptor-lowtag des
)))
373 (if (is-fixnum-lowtag lowtag
)
374 (make-random-descriptor (descriptor-fixnum des
))
375 (read-wordindexed des
1))))
378 (defun descriptor-mem (des)
379 (gspace-data (descriptor-intuit-gspace des
)))
380 (defun descriptor-byte-offset (des)
381 (ash (descriptor-word-offset des
) sb
!vm
:word-shift
))
383 ;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise,
384 ;;; figure out a GSPACE which corresponds to DES, set it into
385 ;;; (DESCRIPTOR-GSPACE DES), set a consistent value into
386 ;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
387 (declaim (ftype (function (descriptor) gspace
) descriptor-intuit-gspace
))
388 (defun descriptor-intuit-gspace (des)
389 (or (descriptor-gspace des
)
391 ;; gspace wasn't set, now we have to search for it.
392 (let* ((lowtag (descriptor-lowtag des
))
393 (abs-word-addr (ash (- (descriptor-bits des
) lowtag
)
394 (- sb
!vm
:word-shift
))))
396 ;; Non-pointer objects don't have a gspace.
397 (unless (or (eql lowtag sb
!vm
:fun-pointer-lowtag
)
398 (eql lowtag sb
!vm
:instance-pointer-lowtag
)
399 (eql lowtag sb
!vm
:list-pointer-lowtag
)
400 (eql lowtag sb
!vm
:other-pointer-lowtag
))
401 (error "don't even know how to look for a GSPACE for ~S" des
))
403 (dolist (gspace (list *dynamic
* *static
* *read-only
*
404 #!+immobile-space
*immobile-fixedobj
*
405 #!+immobile-space
*immobile-varyobj
*)
406 (error "couldn't find a GSPACE for ~S" des
))
407 ;; Bounds-check the descriptor against the allocated area
408 ;; within each gspace.
409 (when (and (<= (gspace-word-address gspace
)
411 (+ (gspace-word-address gspace
)
412 (gspace-free-word-index gspace
))))
413 ;; Update the descriptor with the correct gspace and the
414 ;; offset within the gspace and return the gspace.
415 (setf (descriptor-word-offset des
)
416 (- abs-word-addr
(gspace-word-address gspace
)))
417 (return (setf (descriptor-gspace des
) gspace
)))))))
419 (defun %fixnum-descriptor-if-possible
(num)
420 (and (typep num
'(signed-byte #.sb
!vm
:n-fixnum-bits
))
421 (make-random-descriptor (ash num sb
!vm
:n-fixnum-tag-bits
))))
423 (defun make-fixnum-descriptor (num)
424 (or (%fixnum-descriptor-if-possible num
)
425 (error "~W is too big for a fixnum." num
)))
427 (defun make-other-immediate-descriptor (data type
)
428 (make-descriptor (logior (ash data sb
!vm
:n-widetag-bits
) type
)))
430 (defun make-character-descriptor (data)
431 (make-other-immediate-descriptor data sb
!vm
:character-widetag
))
434 ;;;; miscellaneous variables and other noise
436 ;;; a numeric value to be returned for undefined foreign symbols, or NIL if
437 ;;; undefined foreign symbols are to be treated as an error.
438 ;;; (In the first pass of GENESIS, needed to create a header file before
439 ;;; the C runtime can be built, various foreign symbols will necessarily
440 ;;; be undefined, but we don't need actual values for them anyway, and
441 ;;; we can just use 0 or some other placeholder. In the second pass of
442 ;;; GENESIS, all foreign symbols should be defined, so any undefined
443 ;;; foreign symbol is a problem.)
445 ;;; KLUDGE: It would probably be cleaner to rewrite GENESIS so that it
446 ;;; never tries to look up foreign symbols in the first place unless
447 ;;; it's actually creating a core file (as in the second pass) instead
448 ;;; of using this hack to allow it to go through the motions without
449 ;;; causing an error. -- WHN 20000825
450 (defvar *foreign-symbol-placeholder-value
*)
452 ;;; a handle on the trap object
453 (defvar *unbound-marker
*
454 (make-other-immediate-descriptor 0 sb
!vm
:unbound-marker-widetag
))
456 ;;; a handle on the NIL object
457 (defvar *nil-descriptor
*)
459 ;;; the head of a list of TOPLEVEL-THINGs describing stuff to be done
460 ;;; when the target Lisp starts up
462 ;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or
463 ;;; loadtime value, represented by (CONS KEYWORD ..).
464 (declaim (special *!cold-toplevels
* *!cold-defconstants
*
465 *!cold-defuns
* *cold-methods
*))
467 ;;; the head of a list of DEBUG-SOURCEs which need to be patched when
468 ;;; the cold core starts up
469 (defvar *current-debug-sources
*)
471 ;;; foreign symbol references
472 (defparameter *cold-foreign-undefined-symbols
* nil
)
474 ;;;; miscellaneous stuff to read and write the core memory
476 ;; Like above, but the list is held in the target's image of the host symbol,
477 ;; not the host's value of the symbol.
478 (defun cold-target-push (cold-thing host-symbol
)
479 (cold-set host-symbol
(cold-cons cold-thing
(cold-symbol-value host-symbol
))))
481 (declaim (ftype (function (descriptor sb
!vm
:word
) descriptor
) read-wordindexed
))
482 (macrolet ((read-bits ()
483 `(bvref-word (descriptor-mem address
)
484 (ash (+ index
(descriptor-word-offset address
))
486 (defun read-bits-wordindexed (address index
)
488 (defun read-wordindexed (address index
)
489 "Return the value which is displaced by INDEX words from ADDRESS."
490 (make-random-descriptor (read-bits))))
492 (declaim (ftype (function (descriptor) descriptor
) read-memory
))
493 (defun read-memory (address)
494 "Return the value at ADDRESS."
495 (read-wordindexed address
0))
497 (declaim (ftype (function (descriptor
498 (integer #.
(- sb
!vm
:list-pointer-lowtag
)
499 #.sb
!ext
:most-positive-word
)
502 note-load-time-value-reference
))
503 (defun note-load-time-value-reference (address offset marker
)
504 (push (cold-list (cold-intern :load-time-value-fixup
)
506 (number-to-core offset
)
507 (number-to-core (descriptor-word-offset marker
)))
511 (declaim (ftype (function (descriptor sb
!vm
:word
(or symbol descriptor
))) write-wordindexed
))
512 (macrolet ((write-bits (bits)
513 `(setf (bvref-word (descriptor-mem address
)
514 (ash (+ index
(descriptor-word-offset address
))
517 (defun write-wordindexed (address index value
)
518 "Write VALUE displaced INDEX words from ADDRESS."
519 ;; If we're passed a symbol as a value then it needs to be interned.
520 (let ((value (cond ((symbolp value
) (cold-intern value
))
522 (if (eql (descriptor-gspace value
) :load-time-value
)
523 (note-load-time-value-reference address
524 (- (ash index sb
!vm
:word-shift
)
525 (logand (descriptor-bits address
)
528 (write-bits (descriptor-bits value
)))))
530 (defun write-wordindexed/raw
(address index bits
)
531 (declare (type descriptor address
) (type sb
!vm
:word index
)
532 (type (or sb
!vm
:word sb
!vm
:signed-word
) bits
))
533 (write-bits (logand bits sb
!ext
:most-positive-word
))))
535 (declaim (ftype (function (descriptor (or symbol descriptor
))) write-memory
))
536 (defun write-memory (address value
)
537 "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
538 (write-wordindexed address
0 value
))
540 ;;;; allocating images of primitive objects in the cold core
542 (defun write-header-word (des header-data widetag
)
543 ;; In immobile space, all objects start life as pseudo-static as if by 'save'.
544 (let ((gen #!+gencgc
(if (or #!+immobile-space
545 (let ((gspace (descriptor-gspace des
)))
546 (or (eq gspace
*immobile-fixedobj
*)
547 (eq gspace
*immobile-varyobj
*))))
548 sb
!vm
:+pseudo-static-generation
+
551 (write-wordindexed/raw des
0
552 (logior (ash (logior (ash gen
16) header-data
)
553 sb
!vm
:n-widetag-bits
) widetag
))))
555 (defun set-header-data (object data
)
556 (write-header-word object data
(ldb (byte sb
!vm
:n-widetag-bits
0)
557 (read-bits-wordindexed object
0)))
558 object
) ; return the object itself, like SB!KERNEL:SET-HEADER-DATA
560 (defun get-header-data (object)
561 (ash (read-bits-wordindexed object
0) (- sb
!vm
:n-widetag-bits
)))
563 ;;; There are three kinds of blocks of memory in the type system:
564 ;;; * Boxed objects (cons cells, structures, etc): These objects have no
565 ;;; header as all slots are descriptors.
566 ;;; * Unboxed objects (bignums): There is a single header word that contains
568 ;;; * Vector objects: There is a header word with the type, then a word for
569 ;;; the length, then the data.
570 (defun allocate-object (gspace length lowtag
&optional align256p
)
571 "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
573 (allocate-cold-descriptor gspace
(ash length sb
!vm
:word-shift
) lowtag
574 (make-page-attributes align256p
0)))
575 (defun allocate-header+object
(gspace length widetag
)
576 "Allocate LENGTH words plus a header word in GSPACE and
577 return an ``other-pointer'' descriptor to them. Initialize the header word
578 with the resultant length and WIDETAG."
579 (let ((des (allocate-cold-descriptor
580 gspace
(ash (1+ length
) sb
!vm
:word-shift
)
581 sb
!vm
:other-pointer-lowtag
582 (make-page-attributes nil
0))))
583 (write-header-word des length widetag
)
585 (defun allocate-vector-object (gspace element-bits length widetag
)
586 "Allocate LENGTH units of ELEMENT-BITS size plus a header plus a length slot in
587 GSPACE and return an ``other-pointer'' descriptor to them. Initialize the
588 header word with WIDETAG and the length slot with LENGTH."
589 ;; ALLOCATE-COLD-DESCRIPTOR will take any rational number of bytes
590 ;; and round up to a double-word. This doesn't need to use CEILING.
591 (let* ((bytes (/ (* element-bits length
) sb
!vm
:n-byte-bits
))
592 (des (allocate-cold-descriptor gspace
593 (+ bytes
(* 2 sb
!vm
:n-word-bytes
))
594 sb
!vm
:other-pointer-lowtag
)))
595 (write-header-word des
0 widetag
)
596 (write-wordindexed des
597 sb
!vm
:vector-length-slot
598 (make-fixnum-descriptor length
))
601 ;;; the hosts's representation of LAYOUT-of-LAYOUT
602 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
603 (defvar *host-layout-of-layout
* (find-layout 'layout
)))
605 (defun cold-layout-length (layout)
606 (descriptor-fixnum (read-slot layout
*host-layout-of-layout
* :length
)))
607 (defun cold-layout-depthoid (layout)
608 (descriptor-fixnum (read-slot layout
*host-layout-of-layout
* :depthoid
)))
610 ;; Make a structure and set the header word and layout.
611 ;; LAYOUT-LENGTH is as returned by the like-named function.
612 (defun allocate-struct
613 (gspace layout
&optional
(layout-length (cold-layout-length layout
))
615 ;; Count +1 for the header word when allocating.
616 (let ((des (allocate-object gspace
(1+ layout-length
)
617 sb
!vm
:instance-pointer-lowtag is-layout
)))
618 ;; Length as stored in the header is the exact number of useful words
619 ;; that follow, as is customary. A padding word, if any is not "useful"
620 (write-header-word des
621 (logior layout-length
622 #!+compact-instance-header
623 (if layout
(ash (descriptor-bits layout
) 24) 0))
624 sb
!vm
:instance-widetag
)
625 #!-compact-instance-header
626 (write-wordindexed des sb
!vm
:instance-slots-offset layout
)
629 ;;;; copying simple objects into the cold core
631 (defun base-string-to-core (string &optional
(gspace *dynamic
*))
632 "Copy STRING (which must only contain STANDARD-CHARs) into the cold
633 core and return a descriptor to it."
634 ;; (Remember that the system convention for storage of strings leaves an
635 ;; extra null byte at the end to aid in call-out to C.)
636 (let* ((length (length string
))
637 (des (allocate-vector-object gspace
640 sb
!vm
:simple-base-string-widetag
))
641 (bytes (gspace-data gspace
))
642 (offset (+ (* sb
!vm
:vector-data-offset sb
!vm
:n-word-bytes
)
643 (descriptor-byte-offset des
))))
644 (write-wordindexed des
645 sb
!vm
:vector-length-slot
646 (make-fixnum-descriptor length
))
648 (setf (bvref bytes
(+ offset i
))
649 (sb!xc
:char-code
(aref string i
))))
650 (setf (bvref bytes
(+ offset length
))
651 0) ; null string-termination character for C
654 (defun base-string-from-core (descriptor)
655 (let* ((len (descriptor-fixnum
656 (read-wordindexed descriptor sb
!vm
:vector-length-slot
)))
657 (str (make-string len
))
658 (bytes (descriptor-mem descriptor
)))
661 (code-char (bvref bytes
662 (+ (descriptor-byte-offset descriptor
)
663 (* sb
!vm
:vector-data-offset sb
!vm
:n-word-bytes
)
666 (defun bignum-to-core (n)
667 "Copy a bignum to the cold core."
668 (let* ((words (ceiling (1+ (integer-length n
)) sb
!vm
:n-word-bits
))
670 (allocate-header+object
*dynamic
* words sb
!vm
:bignum-widetag
)))
671 (declare (fixnum words
))
672 (do ((index 1 (1+ index
))
673 (remainder n
(ash remainder
(- sb
!vm
:n-word-bits
))))
675 (unless (zerop (integer-length remainder
))
676 ;; FIXME: Shouldn't this be a fatal error?
677 (warn "~W words of ~W were written, but ~W bits were left over."
679 (write-wordindexed/raw handle index
680 (ldb (byte sb
!vm
:n-word-bits
0) remainder
)))
683 (defun bignum-from-core (descriptor)
684 (let ((n-words (ash (descriptor-bits (read-memory descriptor
))
685 (- sb
!vm
:n-widetag-bits
)))
687 (dotimes (i n-words val
)
688 (let ((bits (read-bits-wordindexed descriptor
689 (+ i sb
!vm
:bignum-digits-offset
))))
690 ;; sign-extend the highest word
691 (when (and (= i
(1- n-words
)) (logbitp (1- sb
!vm
:n-word-bits
) bits
))
692 (setq bits
(dpb bits
(byte sb
!vm
:n-word-bits
0) -
1)))
693 (setq val
(logior (ash bits
(* i sb
!vm
:n-word-bits
)) val
))))))
695 (defun number-pair-to-core (first second type
)
696 "Makes a number pair of TYPE (ratio or complex) and fills it in."
697 (let ((des (allocate-header+object
*dynamic
* 2 type
)))
698 (write-wordindexed des
1 first
)
699 (write-wordindexed des
2 second
)
702 (defun write-double-float-bits (address index x
)
703 (let ((high-bits (double-float-high-bits x
))
704 (low-bits (double-float-low-bits x
)))
705 (ecase sb
!vm
::n-word-bits
707 (ecase sb
!c
:*backend-byte-order
*
709 (write-wordindexed/raw address index low-bits
)
710 (write-wordindexed/raw address
(1+ index
) high-bits
))
712 (write-wordindexed/raw address index high-bits
)
713 (write-wordindexed/raw address
(1+ index
) low-bits
))))
715 (let ((bits (ecase sb
!c
:*backend-byte-order
*
716 (:little-endian
(logior low-bits
(ash high-bits
32)))
718 #+nil
(:big-endian
(logior (logand high-bits
#xffffffff
)
719 (ash low-bits
32))))))
720 (write-wordindexed/raw address index bits
))))
724 (defun float-to-core (x)
727 ;; 64-bit platforms have immediate single-floats.
729 (make-random-descriptor (logior (ash (single-float-bits x
) 32)
730 sb
!vm
::single-float-widetag
))
732 (let ((des (allocate-header+object
*dynamic
*
733 (1- sb
!vm
:single-float-size
)
734 sb
!vm
:single-float-widetag
)))
735 (write-wordindexed/raw des sb
!vm
:single-float-value-slot
736 (single-float-bits x
))
739 (let ((des (allocate-header+object
*dynamic
*
740 (1- sb
!vm
:double-float-size
)
741 sb
!vm
:double-float-widetag
)))
742 (write-double-float-bits des sb
!vm
:double-float-value-slot x
)))))
744 (defun complex-single-float-to-core (num)
745 (declare (type (complex single-float
) num
))
746 (let ((des (allocate-header+object
*dynamic
*
747 (1- sb
!vm
:complex-single-float-size
)
748 sb
!vm
:complex-single-float-widetag
)))
751 (write-wordindexed/raw des sb
!vm
:complex-single-float-real-slot
752 (single-float-bits (realpart num
)))
753 (write-wordindexed/raw des sb
!vm
:complex-single-float-imag-slot
754 (single-float-bits (imagpart num
))))
756 (write-wordindexed/raw
757 des sb
!vm
:complex-single-float-data-slot
758 (logior (ldb (byte 32 0) (single-float-bits (realpart num
)))
759 (ash (single-float-bits (imagpart num
)) 32)))
762 (defun complex-double-float-to-core (num)
763 (declare (type (complex double-float
) num
))
764 (let ((des (allocate-header+object
*dynamic
*
765 (1- sb
!vm
:complex-double-float-size
)
766 sb
!vm
:complex-double-float-widetag
)))
767 (write-double-float-bits des sb
!vm
:complex-double-float-real-slot
769 (write-double-float-bits des sb
!vm
:complex-double-float-imag-slot
772 ;;; Copy the given number to the core.
773 (defun number-to-core (number)
775 (integer (or (%fixnum-descriptor-if-possible number
)
776 (bignum-to-core number
)))
777 (ratio (number-pair-to-core (number-to-core (numerator number
))
778 (number-to-core (denominator number
))
779 sb
!vm
:ratio-widetag
))
780 ((complex single-float
) (complex-single-float-to-core number
))
781 ((complex double-float
) (complex-double-float-to-core number
))
783 ((complex long-float
)
784 (error "~S isn't a cold-loadable number at all!" number
))
785 (complex (number-pair-to-core (number-to-core (realpart number
))
786 (number-to-core (imagpart number
))
787 sb
!vm
:complex-widetag
))
788 (float (float-to-core number
))
789 (t (error "~S isn't a cold-loadable number at all!" number
))))
791 ;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
792 (defun cold-cons (car cdr
&optional
(gspace *dynamic
*))
793 (let ((dest (allocate-object gspace
2 sb
!vm
:list-pointer-lowtag
)))
794 (write-wordindexed dest sb
!vm
:cons-car-slot car
)
795 (write-wordindexed dest sb
!vm
:cons-cdr-slot cdr
)
797 (defun list-to-core (list)
798 (let ((head *nil-descriptor
*)
800 ;; A recursive algorithm would have the first cons at the highest
801 ;; address. This way looks nicer when viewed in ldb.
803 (unless list
(return head
))
804 (let ((cons (cold-cons (pop list
) *nil-descriptor
*)))
805 (if tail
(cold-rplacd tail cons
) (setq head cons
))
807 (defun cold-list (&rest args
) (list-to-core args
))
808 (defun cold-list-length (list) ; but no circularity detection
809 ;; a recursive implementation uses too much stack for some Lisps
811 (loop (if (cold-null list
) (return n
))
813 (setq list
(cold-cdr list
)))))
815 ;;; Make a simple-vector on the target that holds the specified
816 ;;; OBJECTS, and return its descriptor.
817 ;;; This is really "vectorify-list-into-core" but that's too wordy,
818 ;;; so historically it was "vector-in-core" which is a fine name.
819 (defun vector-in-core (objects &optional
(gspace *dynamic
*))
820 (let* ((size (length objects
))
821 (result (allocate-vector-object gspace sb
!vm
:n-word-bits size
822 sb
!vm
:simple-vector-widetag
)))
823 (dotimes (index size result
)
824 (write-wordindexed result
(+ index sb
!vm
:vector-data-offset
)
827 (defun ub32-vector-in-core (objects)
828 (let* ((size (length objects
))
829 (result (allocate-vector-object *dynamic
* sb
!vm
:n-word-bits size
830 sb
!vm
:simple-array-unsigned-byte-32-widetag
)))
831 (dotimes (index size result
)
832 (write-wordindexed/raw result
(+ index sb
!vm
:vector-data-offset
)
834 (defun cold-svset (vector index value
)
835 (let ((i (if (integerp index
) index
(descriptor-fixnum index
))))
836 (write-wordindexed vector
(+ i sb
!vm
:vector-data-offset
) value
)))
838 (setf (get 'vector
:sb-cold-funcall-handler
/for-value
)
839 (lambda (&rest args
) (vector-in-core args
)))
841 (declaim (inline cold-vector-len cold-svref
))
842 (defun cold-vector-len (vector)
843 (descriptor-fixnum (read-wordindexed vector sb
!vm
:vector-length-slot
)))
844 (defun cold-svref (vector i
)
845 (read-wordindexed vector
(+ (if (integerp i
) i
(descriptor-fixnum i
))
846 sb
!vm
:vector-data-offset
)))
847 (defun cold-vector-elements-eq (a b
)
848 (and (eql (cold-vector-len a
) (cold-vector-len b
))
849 (dotimes (k (cold-vector-len a
) t
)
850 (unless (descriptor= (cold-svref a k
) (cold-svref b k
))
852 (defun vector-from-core (descriptor &optional
(transform #'identity
))
853 (let* ((len (cold-vector-len descriptor
))
854 (vector (make-array len
)))
855 (dotimes (i len vector
)
856 (setf (aref vector i
) (funcall transform
(cold-svref descriptor i
))))))
860 ;; Simulate *FREE-TLS-INDEX*. This is a count, not a displacement.
861 ;; In C, sizeof counts 1 word for the variable-length interrupt_contexts[]
862 ;; but primitive-object-size counts 0, so add 1, though in fact the C code
863 ;; implies that it might have overcounted by 1. We could make this agnostic
864 ;; of MAX-INTERRUPTS by moving the thread base register up by TLS-SIZE words,
865 ;; using negative offsets for all dynamically assigned indices.
866 (defvar *genesis-tls-counter
*
867 (+ 1 sb
!vm
::max-interrupts
868 (sb!vm
:primitive-object-size
869 (find 'sb
!vm
::thread sb
!vm
:*primitive-objects
*
870 :key
#'sb
!vm
:primitive-object-name
))))
874 ;; Assign SYMBOL the tls-index INDEX. SYMBOL must be a descriptor.
875 ;; This is a backend support routine, but the style within this file
876 ;; is to conditionalize by the target features.
877 (defun cold-assign-tls-index (symbol index
)
879 (write-wordindexed/raw
880 symbol
0 (logior (ash index
32) (read-bits-wordindexed symbol
0)))
882 (write-wordindexed/raw symbol sb
!vm
:symbol-tls-index-slot index
))
884 ;; Return SYMBOL's tls-index,
885 ;; choosing a new index if it doesn't have one yet.
886 (defun ensure-symbol-tls-index (symbol)
887 (let* ((cold-sym (cold-intern symbol
))
890 (ldb (byte 32 32) (read-bits-wordindexed cold-sym
0))
892 (read-bits-wordindexed cold-sym sb
!vm
:symbol-tls-index-slot
)))
893 (unless (plusp tls-index
)
894 (let ((next (prog1 *genesis-tls-counter
* (incf *genesis-tls-counter
*))))
895 (setq tls-index
(ash next sb
!vm
:word-shift
))
896 (cold-assign-tls-index cold-sym tls-index
)))
899 ;; A table of special variable names which get known TLS indices.
900 ;; Some of them are mapped onto 'struct thread' and have pre-determined offsets.
901 ;; Others are static symbols used with bind_variable() in the C runtime,
902 ;; and might not, in the absence of this table, get an index assigned by genesis
903 ;; depending on whether the cross-compiler used the BIND vop on them.
904 ;; Indices for those static symbols can be chosen arbitrarily, which is to say
905 ;; the value doesn't matter but must update the tls-counter correctly.
906 ;; All symbols other than the ones in this table get the indices assigned
907 ;; by the fasloader on demand.
909 (defvar *known-tls-symbols
*
910 ;; FIXME: no mechanism exists to determine which static symbols C code will
911 ;; dynamically bind. TLS is a finite resource, and wasting indices for all
912 ;; static symbols isn't the best idea. This list was hand-made with 'grep'.
913 '(sb!vm
:*alloc-signal
*
914 sb
!sys
:*allow-with-interrupts
*
915 sb
!vm
:*current-catch-block
*
916 sb
!vm
::*current-unwind-protect-block
*
917 sb
!kernel
:*free-interrupt-context-index
*
918 sb
!kernel
:*gc-inhibit
*
919 sb
!kernel
:*gc-pending
*
921 sb
!impl
::*in-safepoint
*
922 sb
!sys
:*interrupt-pending
*
923 sb
!sys
:*interrupts-enabled
*
924 sb
!vm
::*pinned-objects
*
925 sb
!kernel
:*restart-clusters
*
926 sb
!kernel
:*stop-for-gc-pending
*
928 sb
!sys
:*thruption-pending
*))
930 (defvar *cold-symbol-gspace
* (or #!+immobile-space
'*immobile-fixedobj
* '*dynamic
*))
932 ;;; Allocate (and initialize) a symbol.
933 (defun allocate-symbol (name &key
(gspace (symbol-value *cold-symbol-gspace
*)))
934 (declare (simple-string name
))
935 (let ((symbol (allocate-header+object gspace
(1- sb
!vm
:symbol-size
)
936 sb
!vm
:symbol-widetag
)))
937 (write-wordindexed symbol sb
!vm
:symbol-value-slot
*unbound-marker
*)
938 (write-wordindexed symbol sb
!vm
:symbol-hash-slot
(make-fixnum-descriptor 0))
939 (write-wordindexed symbol sb
!vm
:symbol-info-slot
*nil-descriptor
*)
940 (write-wordindexed symbol sb
!vm
:symbol-name-slot
941 (set-readonly (base-string-to-core name
*dynamic
*)))
942 (write-wordindexed symbol sb
!vm
:symbol-package-slot
*nil-descriptor
*)
946 (defun assign-tls-index-if-needed (symbol cold-symbol
)
947 (let ((index (info :variable
:wired-tls symbol
)))
948 (cond ((integerp index
) ; thread slot
949 (cold-assign-tls-index cold-symbol index
))
950 ((memq symbol
*known-tls-symbols
*)
951 ;; symbols without which the C runtime could not start
952 (shiftf index
*genesis-tls-counter
* (1+ *genesis-tls-counter
*))
953 (cold-assign-tls-index cold-symbol
(ash index sb
!vm
:word-shift
))))))
955 ;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a
956 ;;; descriptor of a cold symbol or (in an abbreviation for the
957 ;;; most common usage pattern) an ordinary symbol, which will be
958 ;;; automatically cold-interned.
959 (defun cold-set (symbol-or-symbol-des value
)
960 (let ((symbol-des (etypecase symbol-or-symbol-des
961 (descriptor symbol-or-symbol-des
)
962 (symbol (cold-intern symbol-or-symbol-des
)))))
963 (write-wordindexed symbol-des sb
!vm
:symbol-value-slot value
)))
964 (defun cold-symbol-value (symbol)
965 (let ((val (read-wordindexed (cold-intern symbol
) sb
!vm
:symbol-value-slot
)))
966 (if (= (descriptor-bits val
) sb
!vm
:unbound-marker-widetag
)
967 (unbound-cold-symbol-handler symbol
)
969 (defun cold-fdefn-fun (cold-fdefn)
970 (read-wordindexed cold-fdefn sb
!vm
:fdefn-fun-slot
))
972 (defun unbound-cold-symbol-handler (symbol)
973 (let ((host-val (and (boundp symbol
) (symbol-value symbol
))))
974 (if (typep host-val
'sb
!kernel
:named-type
)
975 (let ((target-val (ctype-to-core (sb!kernel
:named-type-name host-val
)
977 ;; Though it looks complicated to assign cold symbols on demand,
978 ;; it avoids writing code to build the layout of NAMED-TYPE in the
979 ;; way we build other primordial stuff such as layout-of-layout.
980 (cold-set symbol target-val
)
982 (error "Taking Cold-symbol-value of unbound symbol ~S" symbol
))))
984 ;;;; layouts and type system pre-initialization
986 ;;; Since we want to be able to dump structure constants and
987 ;;; predicates with reference layouts, we need to create layouts at
988 ;;; cold-load time. We use the name to intern layouts by, and dump a
989 ;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system
990 ;;; initialization can find them. The only thing that's tricky [sic --
991 ;;; WHN 19990816] is initializing layout's layout, which must point to
994 ;;; a map from name as a host symbol to the descriptor of its target layout
995 (defvar *cold-layouts
*)
997 ;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting
999 (defvar *cold-layout-names
*)
1001 ;;; the descriptor for layout's layout (needed when making layouts)
1002 (defvar *layout-layout
*)
1004 (defvar *known-structure-classoids
*)
1006 (defconstant target-layout-length
1007 ;; LAYOUT-LENGTH counts the number of words in an instance,
1008 ;; including the layout itself as 1 word
1009 (layout-length *host-layout-of-layout
*))
1011 ;;; Trivial methods [sic] require that we sort possible methods by the depthoid.
1012 ;;; Most of the objects printed in cold-init are ordered hierarchically in our
1013 ;;; type lattice; the major exceptions are ARRAY and VECTOR at depthoid -1.
1014 ;;; Of course we need to print VECTORs because a STRING is a vector,
1015 ;;; and vector has to precede ARRAY. Kludge it for now.
1016 (defun class-depthoid (class-name) ; DEPTHOID-ish thing, any which way you can
1020 ;; The depthoid of CONDITION has to be faked. The proper value is 1.
1021 ;; But STRUCTURE-OBJECT is also at depthoid 1, and its predicate
1022 ;; is %INSTANCEP (which is too weak), so to select the correct method
1023 ;; we have to make CONDITION more specific.
1024 ;; In reality it is type disjoint from structure-object.
1027 (let ((target-layout (gethash class-name
*cold-layouts
*)))
1029 (cold-layout-depthoid target-layout
)
1030 (let ((host-layout (find-layout class-name
)))
1031 (if (layout-invalid host-layout
)
1032 (error "~S has neither a host not target layout" class-name
)
1033 (layout-depthoid host-layout
))))))))
1035 ;;; Return a list of names created from the cold layout INHERITS data
1037 (defun listify-cold-inherits (x)
1038 (map 'list
(lambda (cold-layout)
1039 (or (gethash (descriptor-bits cold-layout
) *cold-layout-names
*)
1040 (error "~S is not the descriptor of a cold-layout" cold-layout
)))
1041 (vector-from-core x
)))
1043 ;;; COLD-DD-SLOTS is a cold descriptor for the list of slots
1044 ;;; in a cold defstruct-description. INDEX is a DSD-INDEX.
1045 ;;; Return the host's accessor name for the host image of that slot.
1046 (defun dsd-accessor-from-cold-slots (cold-dd-slots desired-index
)
1047 (let* ((dsd-slots (dd-slots
1048 (find-defstruct-description 'defstruct-slot-description
)))
1050 (dsd-index (find 'sb
!kernel
::bits dsd-slots
:key
#'dsd-name
)))
1051 (accessor-fun-name-slot
1052 (dsd-index (find 'sb
!kernel
::accessor-name dsd-slots
:key
#'dsd-name
))))
1053 (do ((list cold-dd-slots
(cold-cdr list
)))
1055 (when (= (ash (descriptor-fixnum
1056 (read-wordindexed (cold-car list
)
1057 (+ sb
!vm
:instance-slots-offset bits-slot
)))
1058 (- sb
!kernel
::+dsd-index-shift
+))
1062 (read-wordindexed (cold-car list
)
1063 (+ sb
!vm
:instance-slots-offset
1064 accessor-fun-name-slot
))))))))
1066 (defun cold-dsd-index (cold-dsd dsd-layout
)
1067 (ash (descriptor-fixnum (read-slot cold-dsd dsd-layout
:bits
))
1068 (- sb
!kernel
::+dsd-index-shift
+)))
1070 (defun cold-dsd-raw-type (cold-dsd dsd-layout
)
1071 (1- (ldb (byte 3 0) (descriptor-fixnum (read-slot cold-dsd dsd-layout
:bits
)))))
1073 (flet ((get-slots (host-layout-or-type)
1074 (etypecase host-layout-or-type
1075 (layout (dd-slots (layout-info host-layout-or-type
)))
1076 (symbol (dd-slots-from-core host-layout-or-type
))))
1077 (get-slot-index (slots initarg
)
1078 (+ sb
!vm
:instance-slots-offset
1079 (if (descriptor-p slots
)
1080 (do ((dsd-layout (find-layout 'defstruct-slot-description
))
1081 (slots slots
(cold-cdr slots
)))
1082 ((cold-null slots
) (error "No slot for ~S" initarg
))
1083 (let* ((dsd (cold-car slots
))
1084 (slot-name (read-slot dsd dsd-layout
:name
)))
1085 (when (eq (keywordicate (warm-symbol slot-name
)) initarg
)
1086 ;; Untagged slots are not accessible during cold-load
1087 (aver (eql (cold-dsd-raw-type dsd dsd-layout
) -
1))
1088 (return (cold-dsd-index dsd dsd-layout
)))))
1089 (let ((dsd (find initarg slots
1091 (eq x
(keywordicate (dsd-name y
)))))))
1092 (aver (eq (dsd-raw-type dsd
) t
)) ; Same as above: no can do.
1093 (dsd-index dsd
))))))
1094 (defun write-slots (cold-object host-layout-or-type
&rest assignments
)
1095 (aver (evenp (length assignments
)))
1096 (let ((slots (get-slots host-layout-or-type
)))
1097 (loop for
(initarg value
) on assignments by
#'cddr
1098 do
(write-wordindexed
1099 cold-object
(get-slot-index slots initarg
) value
)))
1102 ;; For symmetry, the reader takes an initarg, not a slot name.
1103 (defun read-slot (cold-object host-layout-or-type slot-initarg
)
1104 (let ((slots (get-slots host-layout-or-type
)))
1105 (read-wordindexed cold-object
(get-slot-index slots slot-initarg
)))))
1107 ;; Given a TYPE-NAME of a structure-class, find its defstruct-description
1108 ;; as a target descriptor, and return the slot list as a target descriptor.
1109 (defun dd-slots-from-core (type-name)
1110 (let* ((host-dd-layout (find-layout 'defstruct-description
))
1112 ;; This is inefficient, but not enough so to worry about.
1113 (or (car (assoc (cold-intern type-name
) *known-structure-classoids
*
1114 :key
(lambda (x) (read-slot x host-dd-layout
:name
))
1115 :test
#'descriptor
=))
1116 (error "No known layout for ~S" type-name
))))
1117 (read-slot target-dd host-dd-layout
:slots
)))
1119 (defvar *simple-vector-0-descriptor
*)
1120 (defvar *vacuous-slot-table
*)
1121 (defvar *cold-layout-gspace
* (or #!+immobile-space
'*immobile-fixedobj
* '*dynamic
*))
1122 (declaim (ftype (function (symbol descriptor descriptor descriptor descriptor
)
1125 (defun make-cold-layout (name length inherits depthoid bitmap
)
1126 (let ((result (allocate-struct (symbol-value *cold-layout-gspace
*) *layout-layout
*
1127 target-layout-length t
)))
1128 ;; Don't set the CLOS hash value: done in cold-init instead.
1130 ;; Set other slot values.
1132 ;; leave CLASSOID uninitialized for now
1133 (multiple-value-call
1134 #'write-slots result
*host-layout-of-layout
*
1135 :invalid
*nil-descriptor
*
1139 :info
*nil-descriptor
*
1140 :pure
*nil-descriptor
*
1142 ;; Nothing in cold-init needs to call EQUALP on a structure with raw slots,
1143 ;; but for type-correctness this slot needs to be a simple-vector.
1144 :equalp-tests
*simple-vector-0-descriptor
*
1145 :source-location
*nil-descriptor
*
1146 :%for-std-class-b
(make-fixnum-descriptor 0)
1147 :slot-list
*nil-descriptor
*
1148 (if (member name
'(null list symbol
))
1149 ;; Assign an empty slot-table. Why this is done only for three
1150 ;; classoids is ... too complicated to explain here in a few words,
1151 ;; but revision 18c239205d9349abc017b07e7894a710835c5205 broke it.
1152 ;; Keep this in sync with MAKE-SLOT-TABLE in pcl/slots-boot.
1153 (values :slot-table
(if (boundp '*vacuous-slot-table
*)
1154 *vacuous-slot-table
*
1155 (setq *vacuous-slot-table
*
1156 (host-constant-to-core '#(1 nil
)))))
1159 (setf (gethash (descriptor-bits result
) *cold-layout-names
*) name
1160 (gethash name
*cold-layouts
*) result
)))
1162 (defun predicate-for-specializer (type-name)
1163 (let ((classoid (find-classoid type-name nil
)))
1166 (cond ((dd-predicate-name (layout-info (classoid-layout classoid
))))
1167 ;; All early INSTANCEs should be STRUCTURE-OBJECTs.
1168 ;; Except: see hack for CONDITIONs in CLASS-DEPTHOID.
1169 ((eq type-name
'structure-object
) 'sb
!kernel
:%instancep
)))
1171 (let ((translation (specifier-type type-name
)))
1172 (aver (not (contains-unknown-type-p translation
)))
1173 (let ((predicate (find translation sb
!c
::*backend-type-predicates
*
1174 :test
#'type
= :key
#'car
)))
1175 (cond (predicate (cdr predicate
))
1176 ((eq type-name
'stream
) 'streamp
)
1177 ((eq type-name
't
) 'sb
!int
:constantly-t
)
1178 (t (error "No predicate for builtin: ~S" type-name
))))))
1180 #+nil
(format t
"~&; PREDICATE-FOR-SPECIALIZER: no classoid for ~S~%"
1183 (condition 'sb
!kernel
::!condition-p
))))))
1185 ;;; Convert SPECIFIER (equivalently OBJ) to its representation as a ctype
1186 ;;; in the cold core.
1187 (defvar *ctype-cache
*)
1189 (defvar *ctype-nullified-slots
* nil
)
1190 (defvar *built-in-classoid-nullified-slots
* nil
)
1192 ;; This function is memoized because it's essentially a constant,
1193 ;; but *nil-descriptor* isn't initialized by the time it's defined.
1194 (defun get-exceptional-slots (obj-type)
1195 (flet ((index (classoid-name slot-name
)
1196 (dsd-index (find slot-name
1197 (dd-slots (find-defstruct-description classoid-name
))
1201 (or *built-in-classoid-nullified-slots
*
1202 (setq *built-in-classoid-nullified-slots
*
1203 (append (get-exceptional-slots 'ctype
)
1204 (list (cons (index 'built-in-classoid
'sb
!kernel
::subclasses
)
1206 (cons (index 'built-in-classoid
'layout
)
1207 *nil-descriptor
*))))))
1209 (or *ctype-nullified-slots
*
1210 (setq *ctype-nullified-slots
*
1211 (list (cons (index 'ctype
'sb
!kernel
::class-info
)
1212 *nil-descriptor
*))))))))
1214 (defun ctype-to-core (specifier obj
)
1215 (declare (type ctype obj
))
1216 (if (classoid-p obj
)
1217 (let* ((cell (cold-find-classoid-cell (classoid-name obj
) :create t
))
1219 (read-slot cell
(find-layout 'sb
!kernel
::classoid-cell
) :classoid
)))
1220 (unless (cold-null cold-classoid
)
1221 (return-from ctype-to-core cold-classoid
)))
1222 ;; CTYPEs can't be TYPE=-hashed, but specifiers can be EQUAL-hashed.
1223 ;; Don't check the cache for classoids though; that would be wrong.
1224 ;; e.g. named-type T and classoid T both unparse to T.
1225 (awhen (gethash specifier
*ctype-cache
*)
1226 (return-from ctype-to-core it
)))
1228 (ctype-to-core-helper
1232 (xset (ctype-to-core-helper obj nil nil
))
1233 (ctype (ctype-to-core (type-specifier obj
) obj
))))
1234 (get-exceptional-slots (type-of obj
)))))
1235 (let ((type-class-vector
1236 (cold-symbol-value 'sb
!kernel
::*type-classes
*))
1237 (index (position (sb!kernel
::type-class-info obj
)
1238 sb
!kernel
::*type-classes
*)))
1239 ;; Push this instance into the list of fixups for its type class
1240 (cold-svset type-class-vector index
1241 (cold-cons result
(cold-svref type-class-vector index
))))
1242 (if (classoid-p obj
)
1243 ;; Place this classoid into its clasoid-cell.
1244 (let ((cell (cold-find-classoid-cell (classoid-name obj
) :create t
)))
1245 (write-slots cell
(find-layout 'sb
!kernel
::classoid-cell
)
1247 ;; Otherwise put it in the general cache
1248 (setf (gethash specifier
*ctype-cache
*) result
))
1251 (defun ctype-to-core-helper (obj obj-to-core-helper exceptional-slots
)
1252 (let* ((host-type (type-of obj
))
1253 (target-layout (or (gethash host-type
*cold-layouts
*)
1254 (error "No target layout for ~S" obj
)))
1255 (result (allocate-struct *dynamic
* target-layout
))
1256 (cold-dd-slots (dd-slots-from-core host-type
)))
1257 (aver (eql (layout-bitmap (find-layout host-type
))
1258 sb
!kernel
::+layout-all-tagged
+))
1260 (do ((len (cold-layout-length target-layout
))
1261 (index sb
!vm
:instance-data-start
(1+ index
)))
1262 ((= index len
) result
)
1265 (+ sb
!vm
:instance-slots-offset index
)
1266 (acond ((assq index exceptional-slots
) (cdr it
))
1267 (t (host-constant-to-core
1268 (funcall (dsd-accessor-from-cold-slots cold-dd-slots index
)
1270 obj-to-core-helper
)))))))
1272 ;; This is called to backpatch two small sets of objects:
1273 ;; - layouts created before layout-of-layout is made (3 counting LAYOUT itself)
1274 ;; - a small number of classoid-cells (~ 4).
1275 (defun set-instance-layout (thing layout
)
1276 #!+compact-instance-header
1277 ;; High half of the header points to the layout
1278 (write-wordindexed/raw thing
0 (logior (ash (descriptor-bits layout
) 32)
1279 (read-bits-wordindexed thing
0)))
1280 #!-compact-instance-header
1281 ;; Word following the header is the layout
1282 (write-wordindexed thing sb
!vm
:instance-slots-offset layout
))
1284 (defun cold-layout-of (cold-struct)
1285 #!+compact-instance-header
1286 (let ((bits (ash (read-bits-wordindexed cold-struct
0) -
32)))
1287 (if (zerop bits
) *nil-descriptor
* (make-random-descriptor bits
)))
1288 #!-compact-instance-header
1289 (read-wordindexed cold-struct sb
!vm
:instance-slots-offset
))
1291 (defun initialize-layouts ()
1292 (clrhash *cold-layouts
*)
1293 ;; This assertion is due to the fact that MAKE-COLD-LAYOUT does not
1294 ;; know how to set any raw slots.
1295 (aver (eql (layout-bitmap *host-layout-of-layout
*)
1296 sb
!kernel
::+layout-all-tagged
+))
1297 (setq *layout-layout
* (make-fixnum-descriptor 0))
1298 (flet ((chill-layout (name &rest inherits
)
1299 ;; Check that the number of specified INHERITS matches
1300 ;; the length of the layout's inherits in the cross-compiler.
1301 (let ((warm-layout (classoid-layout (find-classoid name
))))
1302 (assert (eql (length (layout-inherits warm-layout
))
1306 (number-to-core (layout-length warm-layout
))
1307 (vector-in-core inherits
)
1308 (number-to-core (layout-depthoid warm-layout
))
1309 (number-to-core (layout-bitmap warm-layout
))))))
1310 (let* ((t-layout (chill-layout 't
))
1311 (s-o-layout (chill-layout 'structure-object t-layout
)))
1312 (setf *layout-layout
* (chill-layout 'layout t-layout s-o-layout
))
1313 (dolist (layout (list t-layout s-o-layout
*layout-layout
*))
1314 (set-instance-layout layout
*layout-layout
*))
1315 (chill-layout 'function t-layout
)
1316 (let* ((sequence (chill-layout 'sequence t-layout
))
1317 (list (chill-layout 'list t-layout sequence
))
1318 (symbol (chill-layout 'symbol t-layout
)))
1319 (chill-layout 'null t-layout sequence list symbol
))
1320 (chill-layout 'package t-layout s-o-layout
))))
1322 ;;;; interning symbols in the cold image
1324 ;;; a map from package name as a host string to
1325 ;;; ((external-symbols . internal-symbols) . cold-package-descriptor)
1326 (defvar *cold-package-symbols
*)
1327 (declaim (type hash-table
*cold-package-symbols
*))
1329 (setf (get 'find-package
:sb-cold-funcall-handler
/for-value
)
1330 (lambda (descriptor &aux
(name (base-string-from-core descriptor
)))
1331 (or (cdr (gethash name
*cold-package-symbols
*))
1332 (error "Genesis could not find a target package named ~S" name
))))
1334 (defvar *classoid-cells
*)
1335 (defun cold-find-classoid-cell (name &key create
)
1336 (aver (eq create t
))
1337 (or (gethash name
*classoid-cells
*)
1338 (let ((layout (gethash 'sb
!kernel
::classoid-cell
*cold-layouts
*)) ; ok if nil
1339 (host-layout (find-layout 'sb
!kernel
::classoid-cell
)))
1340 (setf (gethash name
*classoid-cells
*)
1341 (write-slots (allocate-struct *dynamic
* layout
1342 (layout-length host-layout
))
1345 :pcl-class
*nil-descriptor
*
1346 :classoid
*nil-descriptor
*)))))
1348 (setf (get 'find-classoid-cell
:sb-cold-funcall-handler
/for-value
)
1349 #'cold-find-classoid-cell
)
1351 ;;; a map from descriptors to symbols, so that we can back up. The key
1352 ;;; is the address in the target core.
1353 (defvar *cold-symbols
*)
1354 (declaim (type hash-table
*cold-symbols
*))
1356 (defun set-readonly (string) (set-header-data string sb
!vm
:+vector-shareable
+))
1358 (defun initialize-packages ()
1359 (let ((package-data-list
1360 ;; docstrings are set in src/cold/warm. It would work to do it here,
1361 ;; but seems preferable not to saddle Genesis with such responsibility.
1362 (list* (sb-cold:make-package-data
:name
"COMMON-LISP" :doc nil
)
1363 (sb-cold:make-package-data
:name
"KEYWORD" :doc nil
)
1364 ;; ANSI encourages us to put extension packages
1365 ;; in the USE list of COMMON-LISP-USER.
1366 (sb-cold:make-package-data
1367 :name
"COMMON-LISP-USER" :doc nil
1368 :use
'("COMMON-LISP" "SB!ALIEN" "SB!DEBUG" "SB!EXT" "SB!GRAY" "SB!PROFILE"))
1369 (sb-cold::package-list-for-genesis
)))
1370 (package-layout (find-layout 'package
))
1371 (target-pkg-list nil
))
1372 (labels ((init-cold-package (name &optional docstring
)
1373 (let ((cold-package (allocate-struct (symbol-value *cold-layout-gspace
*)
1374 (gethash 'package
*cold-layouts
*))))
1375 (setf (gethash name
*cold-package-symbols
*)
1376 (cons (cons nil nil
) cold-package
))
1377 ;; Initialize string slots
1378 (write-slots cold-package package-layout
1379 :%name
(set-readonly
1380 (base-string-to-core
1381 (target-package-name name
)))
1382 :%nicknames
(chill-nicknames name
)
1383 :doc-string
(if docstring
1384 (base-string-to-core docstring
)
1386 :%use-list
*nil-descriptor
*)
1387 ;; the cddr of this will accumulate the 'used-by' package list
1388 (push (list name cold-package
) target-pkg-list
)))
1389 (target-package-name (string)
1390 (if (eql (mismatch string
"SB!") 3)
1391 (concatenate 'string
"SB-" (subseq string
3))
1393 (chill-nicknames (pkg-name)
1394 ;; Make the package nickname lists for the standard packages
1395 ;; be the minimum specified by ANSI, regardless of what value
1396 ;; the cross-compilation host happens to use.
1397 ;; For packages other than the standard packages, the nickname
1398 ;; list was specified by our package setup code, and we can just
1399 ;; propagate the current state into the target.
1401 (mapcar #'base-string-to-core
1402 (cond ((string= pkg-name
"COMMON-LISP") '("CL"))
1403 ((string= pkg-name
"COMMON-LISP-USER")
1405 ((string= pkg-name
"KEYWORD") '())
1407 ;; 'package-data-list' contains no nicknames.
1408 ;; (See comment in 'set-up-cold-packages')
1409 (aver (null (package-nicknames
1410 (find-package pkg-name
))))
1412 (find-cold-package (name)
1413 (cadr (find-package-cell name
)))
1414 (find-package-cell (name)
1415 (or (assoc (if (string= name
"CL") "COMMON-LISP" name
)
1416 target-pkg-list
:test
#'string
=)
1417 (error "No cold package named ~S" name
))))
1418 ;; pass 1: make all proto-packages
1419 (dolist (pd package-data-list
)
1420 (init-cold-package (sb-cold:package-data-name pd
)
1421 #!+sb-doc
(sb-cold::package-data-doc pd
)))
1422 ;; pass 2: set the 'use' lists and collect the 'used-by' lists
1423 (dolist (pd package-data-list
)
1424 (let ((this (find-cold-package (sb-cold:package-data-name pd
)))
1426 (dolist (that (sb-cold:package-data-use pd
))
1427 (let ((cell (find-package-cell that
)))
1428 (push (cadr cell
) use
)
1429 (push this
(cddr cell
))))
1430 (write-slots this package-layout
1431 :%use-list
(list-to-core (nreverse use
)))))
1432 ;; pass 3: set the 'used-by' lists
1433 (dolist (cell target-pkg-list
)
1434 (write-slots (cadr cell
) package-layout
1435 :%used-by-list
(list-to-core (cddr cell
)))))))
1437 ;;; sanity check for a symbol we're about to create on the target
1439 ;;; Make sure that the symbol has an appropriate package. In
1440 ;;; particular, catch the so-easy-to-make error of typing something
1441 ;;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really
1442 ;;; need is SB!KERNEL:%BYTE-BLT.
1443 (defun package-ok-for-target-symbol-p (package)
1444 (let ((package-name (package-name package
)))
1446 ;; Cold interning things in these standard packages is OK. (Cold
1447 ;; interning things in the other standard package, CL-USER, isn't
1448 ;; OK. We just use CL-USER to expose symbols whose homes are in
1449 ;; other packages. Thus, trying to cold intern a symbol whose
1450 ;; home package is CL-USER probably means that a coding error has
1451 ;; been made somewhere.)
1452 (find package-name
'("COMMON-LISP" "KEYWORD") :test
#'string
=)
1453 ;; Cold interning something in one of our target-code packages,
1454 ;; which are ever-so-rigorously-and-elegantly distinguished by
1455 ;; this prefix on their names, is OK too.
1456 (string= package-name
"SB!" :end1
3 :end2
3)
1457 ;; This one is OK too, since it ends up being COMMON-LISP on the
1459 (string= package-name
"SB-XC")
1460 ;; Anything else looks bad. (maybe COMMON-LISP-USER? maybe an extension
1461 ;; package in the xc host? something we can't think of
1462 ;; a valid reason to cold intern, anyway...)
1465 ;;; like SYMBOL-PACKAGE, but safe for symbols which end up on the target
1467 ;;; Most host symbols we dump onto the target are created by SBCL
1468 ;;; itself, so that as long as we avoid gratuitously
1469 ;;; cross-compilation-unfriendly hacks, it just happens that their
1470 ;;; SYMBOL-PACKAGE in the host system corresponds to their
1471 ;;; SYMBOL-PACKAGE in the target system. However, that's not the case
1472 ;;; in the COMMON-LISP package, where we don't get to create the
1473 ;;; symbols but instead have to use the ones that the xc host created.
1474 ;;; In particular, while ANSI specifies which symbols are exported
1475 ;;; from COMMON-LISP, it doesn't specify that their home packages are
1476 ;;; COMMON-LISP, so the xc host can keep them in random packages which
1477 ;;; don't exist on the target (e.g. CLISP keeping some CL-exported
1478 ;;; symbols in the CLOS package).
1479 (defun symbol-package-for-target-symbol (symbol)
1480 ;; We want to catch weird symbols like CLISP's
1481 ;; CL:FIND-METHOD=CLOS::FIND-METHOD, but we don't want to get
1482 ;; sidetracked by ordinary symbols like :CHARACTER which happen to
1483 ;; have the same SYMBOL-NAME as exports from COMMON-LISP.
1484 (multiple-value-bind (cl-symbol cl-status
)
1485 (find-symbol (symbol-name symbol
) *cl-package
*)
1486 (if (and (eq symbol cl-symbol
)
1487 (eq cl-status
:external
))
1488 ;; special case, to work around possible xc host weirdness
1489 ;; in COMMON-LISP package
1492 (let ((result (symbol-package symbol
)))
1493 (unless (package-ok-for-target-symbol-p result
)
1494 (bug "~A in bad package for target: ~A" symbol result
))
1497 (defvar *uninterned-symbol-table
* (make-hash-table :test
#'equal
))
1498 ;; This coalesces references to uninterned symbols, which is allowed because
1499 ;; "similar-as-constant" is defined by string comparison, and since we only have
1500 ;; base-strings during Genesis, there is no concern about upgraded array type.
1501 ;; There is a subtlety of whether coalescing may occur across files
1502 ;; - the target compiler doesn't and couldn't - but here it doesn't matter.
1503 (defun get-uninterned-symbol (name)
1504 (or (gethash name
*uninterned-symbol-table
*)
1505 (let ((cold-symbol (allocate-symbol name
)))
1506 (setf (gethash name
*uninterned-symbol-table
*) cold-symbol
))))
1508 ;;; Dump the target representation of HOST-VALUE,
1509 ;;; the type of which is in a restrictive set.
1510 (defun host-constant-to-core (host-value &optional helper
)
1511 (let ((visited (make-hash-table :test
#'eq
)))
1512 (named-let target-representation
((value host-value
))
1513 (unless (typep value
'(or symbol number descriptor
))
1514 (let ((found (gethash value visited
)))
1515 (cond ((eq found
:pending
)
1516 (bug "circular constant?")) ; Circularity not permitted
1518 (return-from target-representation found
))))
1519 (setf (gethash value visited
) :pending
))
1520 (setf (gethash value visited
)
1523 (symbol (if (symbol-package value
)
1525 (get-uninterned-symbol (string value
))))
1526 (number (number-to-core value
))
1527 (string (base-string-to-core value
))
1528 (cons (cold-cons (target-representation (car value
))
1529 (target-representation (cdr value
))))
1531 (vector-in-core (map 'list
#'target-representation value
)))
1533 (or (and helper
(funcall helper value
))
1534 (error "host-constant-to-core: can't convert ~S"
1537 ;; Look up the target's descriptor for #'FUN where FUN is a host symbol.
1538 (defun target-symbol-function (symbol)
1539 (let ((f (cold-fdefn-fun (cold-fdefinition-object symbol
))))
1540 ;; It works only if DEFUN F was seen first.
1541 (aver (not (cold-null f
)))
1544 ;;; Return a handle on an interned symbol. If necessary allocate the
1545 ;;; symbol and record its home package.
1546 (defun cold-intern (symbol
1548 (gspace (symbol-value *cold-symbol-gspace
*))
1549 &aux
(package (symbol-package-for-target-symbol symbol
)))
1551 ;; Anything on the cross-compilation host which refers to the target
1552 ;; machinery through the host SB-XC package should be translated to
1553 ;; something on the target which refers to the same machinery
1554 ;; through the target COMMON-LISP package.
1555 (let ((p (find-package "SB-XC")))
1556 (when (eq package p
)
1557 (setf package
*cl-package
*))
1558 (when (eq (symbol-package symbol
) p
)
1559 (setf symbol
(intern (symbol-name symbol
) *cl-package
*))))
1561 (or (get symbol
'cold-intern-info
)
1562 (let ((handle (allocate-symbol (symbol-name symbol
) :gspace gspace
)))
1563 (setf (get symbol
'cold-intern-info
) handle
)
1564 ;; maintain reverse map from target descriptor to host symbol
1565 (setf (gethash (descriptor-bits handle
) *cold-symbols
*) symbol
)
1566 (let ((pkg-info (or (gethash (package-name package
) *cold-package-symbols
*)
1567 (error "No target package descriptor for ~S" package
))))
1568 (write-wordindexed handle sb
!vm
:symbol-package-slot
(cdr pkg-info
))
1569 (record-accessibility
1570 (or access
(nth-value 1 (find-symbol (symbol-name symbol
) package
)))
1571 pkg-info handle package symbol
))
1572 #!+sb-thread
(assign-tls-index-if-needed symbol handle
)
1573 (when (eq package
*keyword-package
*)
1574 (cold-set handle handle
))
1577 (defun record-accessibility (accessibility target-pkg-info symbol-descriptor
1578 &optional host-package host-symbol
)
1579 (let ((access-lists (car target-pkg-info
)))
1581 (:external
(push symbol-descriptor
(car access-lists
)))
1582 (:internal
(push symbol-descriptor
(cdr access-lists
)))
1583 (t (error "~S inaccessible in package ~S" host-symbol host-package
)))))
1585 ;;; Construct and return a value for use as *NIL-DESCRIPTOR*.
1586 ;;; It might be nice to put NIL on a readonly page by itself to prevent unsafe
1587 ;;; code from destroying the world with (RPLACx nil 'kablooey)
1588 (defun make-nil-descriptor ()
1589 (let* ((des (allocate-header+object
*static
* sb
!vm
:symbol-size
0))
1590 (result (make-descriptor (+ (descriptor-bits des
)
1591 (* 2 sb
!vm
:n-word-bytes
)
1592 (- sb
!vm
:list-pointer-lowtag
1593 sb
!vm
:other-pointer-lowtag
)))))
1594 (write-wordindexed des
1596 (make-other-immediate-descriptor
1598 sb
!vm
:symbol-widetag
))
1599 (write-wordindexed des
1600 (+ 1 sb
!vm
:symbol-value-slot
)
1602 (write-wordindexed des
1603 (+ 2 sb
!vm
:symbol-value-slot
) ; = 1 + symbol-hash-slot
1605 (write-wordindexed des
1606 (+ 1 sb
!vm
:symbol-info-slot
)
1607 (cold-cons result result
)) ; NIL's info is (nil . nil)
1608 (write-wordindexed des
1609 (+ 1 sb
!vm
:symbol-name-slot
)
1610 ;; NIL's name is in dynamic space because any extra
1611 ;; bytes allocated in static space would need to
1612 ;; be accounted for by STATIC-SYMBOL-OFFSET.
1613 (set-readonly (base-string-to-core "NIL" *dynamic
*)))
1614 (setf (gethash (descriptor-bits result
) *cold-symbols
*) nil
1615 (get nil
'cold-intern-info
) result
)))
1617 ;;; Since the initial symbols must be allocated before we can intern
1618 ;;; anything else, we intern those here. We also set the value of T.
1619 (defun initialize-static-symbols ()
1620 "Initialize the cold load symbol-hacking data structures."
1621 ;; NIL did not have its package assigned. Do that now.
1622 (let ((target-cl-pkg-info (gethash "COMMON-LISP" *cold-package-symbols
*)))
1623 ;; -1 is magic having to do with nil-as-cons vs. nil-as-symbol
1624 (write-wordindexed *nil-descriptor
* (- sb
!vm
:symbol-package-slot
1)
1625 (cdr target-cl-pkg-info
))
1626 (record-accessibility :external target-cl-pkg-info
*nil-descriptor
*))
1627 ;; Intern the others.
1628 (dolist (symbol sb
!vm
:+static-symbols
+)
1629 (let* ((des (cold-intern symbol
:gspace
*static
*))
1630 (offset-wanted (sb!vm
:static-symbol-offset symbol
))
1631 (offset-found (- (descriptor-bits des
)
1632 (descriptor-bits *nil-descriptor
*))))
1633 (unless (= offset-wanted offset-found
)
1634 (error "Offset from ~S to ~S is ~W, not ~W"
1639 ;; Establish the value of T.
1640 (let ((t-symbol (cold-intern t
:gspace
*static
*)))
1641 (cold-set t-symbol t-symbol
))
1642 ;; Establish the value of *PSEUDO-ATOMIC-BITS* so that the
1643 ;; allocation sequences that expect it to be zero upon entrance
1644 ;; actually find it to be so.
1646 (let ((p-a-a-symbol (cold-intern '*pseudo-atomic-bits
*
1648 (cold-set p-a-a-symbol
(make-fixnum-descriptor 0))))
1650 ;;; Sort *COLD-LAYOUTS* to return them in a deterministic order.
1651 (defun sort-cold-layouts ()
1652 (sort (%hash-table-alist
*cold-layouts
*) #'<
1653 :key
(lambda (x) (descriptor-bits (cdr x
)))))
1655 ;;; Establish initial values for magic symbols.
1657 (defun finish-symbols ()
1659 ;; Everything between this preserved-for-posterity comment down to
1660 ;; the assignment of *CURRENT-CATCH-BLOCK* could be entirely deleted,
1661 ;; including the list of *C-CALLABLE-STATIC-SYMBOLS* itself,
1662 ;; if it is GC-safe for the C runtime to have its own implementation
1663 ;; of the INFO-VECTOR-FDEFN function in a multi-threaded build.
1665 ;; "I think the point of setting these functions into SYMBOL-VALUEs
1666 ;; here, instead of using SYMBOL-FUNCTION, is that in CMU CL
1667 ;; SYMBOL-FUNCTION reduces to FDEFINITION, which is a pretty
1668 ;; hairy operation (involving globaldb.lisp etc.) which we don't
1669 ;; want to invoke early in cold init. -- WHN 2001-12-05"
1671 ;; So... that's no longer true. We _do_ associate symbol -> fdefn in genesis.
1672 ;; Additionally, the INFO-VECTOR-FDEFN function is extremely simple and could
1673 ;; easily be implemented in C. However, info-vectors are inevitably
1674 ;; reallocated when new info is attached to a symbol, so the vectors can't be
1675 ;; in static space; they'd gradually become permanent garbage if they did.
1676 ;; That's the real reason for preserving the approach of storing an #<fdefn>
1677 ;; in a symbol's value cell - that location is static, the symbol-info is not.
1679 ;; FIXME: So OK, that's a reasonable reason to do something weird like
1680 ;; this, but this is still a weird thing to do, and we should change
1681 ;; the names to highlight that something weird is going on. Perhaps
1682 ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
1683 ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...
1684 (dolist (symbol sb
!vm
::+c-callable-static-symbols
+)
1685 (cold-set symbol
(cold-fdefinition-object (cold-intern symbol
))))
1687 (cold-set 'sb
!vm
::*current-catch-block
* (make-fixnum-descriptor 0))
1688 (cold-set 'sb
!vm
::*current-unwind-protect-block
* (make-fixnum-descriptor 0))
1690 (cold-set '*free-interrupt-context-index
* (make-fixnum-descriptor 0))
1692 (cold-set '*!initial-layouts
*
1694 (mapcar (lambda (layout)
1695 (cold-cons (cold-intern (car layout
)) (cdr layout
)))
1696 (sort-cold-layouts))))
1699 (cold-set 'sb
!vm
::*free-tls-index
*
1700 (make-descriptor (ash *genesis-tls-counter
* sb
!vm
:word-shift
)))
1702 (dolist (symbol sb
!impl
::*cache-vector-symbols
*)
1703 (cold-set symbol
*nil-descriptor
*))
1705 ;; Symbols for which no call to COLD-INTERN would occur - due to not being
1706 ;; referenced until warm init - must be artificially cold-interned.
1707 ;; Inasmuch as the "offending" things are compiled by ordinary target code
1708 ;; and not cold-init, I think we should use an ordinary DEFPACKAGE for
1709 ;; the added-on bits. What I've done is somewhat of a fragile kludge.
1711 (with-package-iterator (iter '("SB!PCL" "SB!MOP" "SB!GRAY" "SB!SEQUENCE"
1712 "SB!PROFILE" "SB!EXT" "SB!VM"
1713 "SB!C" "SB!FASL" "SB!DEBUG")
1716 (multiple-value-bind (foundp sym accessibility package
) (iter)
1717 (declare (ignore accessibility
))
1718 (cond ((not foundp
) (return))
1719 ((eq (symbol-package sym
) package
) (push sym syms
))))))
1720 (setf syms
(stable-sort syms
#'string
<))
1725 'sb
!impl
::*!initial-symbols
*
1729 (destructuring-bind (pkg-name . pkg-info
) pkgcons
1731 ;; Record shadowing symbols (except from SB-XC) in SB! packages.
1732 (when (eql (mismatch pkg-name
"SB!") 3)
1733 ;; Be insensitive to the host's ordering.
1734 (sort (remove (find-package "SB-XC")
1735 (package-shadowing-symbols (find-package pkg-name
))
1736 :key
#'symbol-package
) #'string
<))))
1737 (write-slots (cdr pkg-info
) ; package
1738 (find-layout 'package
)
1739 :%shadowing-symbols
(list-to-core
1740 (mapcar 'cold-intern shadow
))))
1741 (unless (member pkg-name
'("COMMON-LISP" "KEYWORD") :test
'string
=)
1742 (let ((host-pkg (find-package pkg-name
))
1743 (sb-xc-pkg (find-package "SB-XC"))
1745 ;; Now for each symbol directly present in this host-pkg,
1746 ;; i.e. accessible but not :INHERITED, figure out if the symbol
1747 ;; came from a different package, and if so, make a note of it.
1748 (with-package-iterator (iter host-pkg
:internal
:external
)
1749 (loop (multiple-value-bind (foundp sym accessibility
) (iter)
1750 (unless foundp
(return))
1751 (unless (or (eq (symbol-package sym
) host-pkg
)
1752 (eq (symbol-package sym
) sb-xc-pkg
))
1753 (push (cons sym accessibility
) syms
)))))
1754 (dolist (symcons (sort syms
#'string
< :key
#'car
))
1755 (destructuring-bind (sym . accessibility
) symcons
1756 (record-accessibility accessibility pkg-info
(cold-intern sym
)
1758 (cold-list (cdr pkg-info
)
1759 (vector-in-core (caar pkg-info
))
1760 (vector-in-core (cdar pkg-info
)))))
1761 (sort (%hash-table-alist
*cold-package-symbols
*)
1762 #'string
< :key
#'car
)))) ; Sort by package-name
1764 (dump-symbol-info-vectors
1765 (attach-fdefinitions-to-symbols
1766 (attach-classoid-cells-to-symbols (make-hash-table :test
#'eq
))))
1768 (cold-set '*!initial-debug-sources
* *current-debug-sources
*)
1772 (cold-set 'sb
!vm
::*fp-constant-0d0
* (number-to-core 0d0
))
1773 (cold-set 'sb
!vm
::*fp-constant-1d0
* (number-to-core 1d0
))
1774 (cold-set 'sb
!vm
::*fp-constant-0f0
* (number-to-core 0f0
))
1775 (cold-set 'sb
!vm
::*fp-constant-1f0
* (number-to-core 1f0
))))
1777 ;;;; functions and fdefinition objects
1779 ;;; a hash table mapping from fdefinition names to descriptors of cold
1782 ;;; Note: Since fdefinition names can be lists like '(SETF FOO), and
1783 ;;; we want to have only one entry per name, this must be an 'EQUAL
1784 ;;; hash table, not the default 'EQL.
1785 (defvar *cold-fdefn-objects
*)
1787 (defvar *cold-fdefn-gspace
* nil
)
1789 ;;; Given a cold representation of a symbol, return a warm
1791 (defun warm-symbol (des)
1792 ;; Note that COLD-INTERN is responsible for keeping the
1793 ;; *COLD-SYMBOLS* table up to date, so if DES happens to refer to an
1794 ;; uninterned symbol, the code below will fail. But as long as we
1795 ;; don't need to look up uninterned symbols during bootstrapping,
1797 (multiple-value-bind (symbol found-p
)
1798 (gethash (descriptor-bits des
) *cold-symbols
*)
1799 (declare (type symbol symbol
))
1801 (error "no warm symbol"))
1804 ;;; like CL:CAR, CL:CDR, and CL:NULL but for cold values
1805 (defun cold-car (des)
1806 (aver (= (descriptor-lowtag des
) sb
!vm
:list-pointer-lowtag
))
1807 (read-wordindexed des sb
!vm
:cons-car-slot
))
1808 (defun cold-cdr (des)
1809 (aver (= (descriptor-lowtag des
) sb
!vm
:list-pointer-lowtag
))
1810 (read-wordindexed des sb
!vm
:cons-cdr-slot
))
1811 (defun cold-rplacd (des newval
)
1812 (aver (= (descriptor-lowtag des
) sb
!vm
:list-pointer-lowtag
))
1813 (write-wordindexed des sb
!vm
:cons-cdr-slot newval
)
1815 (defun cold-null (des) (descriptor= des
*nil-descriptor
*))
1817 ;;; Given a cold representation of a function name, return a warm
1819 (declaim (ftype (function ((or symbol descriptor
)) (or symbol list
)) warm-fun-name
))
1820 (defun warm-fun-name (des)
1823 ;; This parallels the logic at the start of COLD-INTERN
1824 ;; which re-homes symbols in SB-XC to COMMON-LISP.
1825 (if (eq (symbol-package des
) (find-package "SB-XC"))
1826 (intern (symbol-name des
) *cl-package
*)
1828 (ecase (descriptor-lowtag des
)
1829 (#.sb
!vm
:list-pointer-lowtag
1830 (aver (not (cold-null des
))) ; function named NIL? please no..
1831 (let ((rest (cold-cdr des
)))
1832 (aver (cold-null (cold-cdr rest
)))
1833 (list (warm-symbol (cold-car des
))
1834 (warm-symbol (cold-car rest
)))))
1835 (#.sb
!vm
:other-pointer-lowtag
1836 (warm-symbol des
))))))
1837 (legal-fun-name-or-type-error result
)
1841 (defun encode-fdefn-raw-addr (fdefn jump-target opcode
)
1842 (let ((disp (- jump-target
1843 (+ (descriptor-bits fdefn
)
1844 (- sb
!vm
:other-pointer-lowtag
)
1845 (ash sb
!vm
:fdefn-raw-addr-slot sb
!vm
:word-shift
)
1847 (logior (ash (ldb (byte 32 0) (the (signed-byte 32) disp
)) 8) opcode
)))
1849 (defun cold-fdefinition-object (cold-name &optional leave-fn-raw
)
1850 (declare (type (or symbol descriptor
) cold-name
))
1851 (declare (special core-file-name
))
1852 (let ((warm-name (warm-fun-name cold-name
)))
1853 (or (gethash warm-name
*cold-fdefn-objects
*)
1854 (let ((fdefn (allocate-header+object
(or *cold-fdefn-gspace
*
1855 #!+immobile-space
*immobile-fixedobj
*
1856 #!-immobile-space
*dynamic
*)
1857 (1- sb
!vm
:fdefn-size
)
1858 sb
!vm
:fdefn-widetag
)))
1859 (setf (gethash warm-name
*cold-fdefn-objects
*) fdefn
)
1860 (write-wordindexed fdefn sb
!vm
:fdefn-name-slot cold-name
)
1861 (unless leave-fn-raw
1862 (write-wordindexed fdefn sb
!vm
:fdefn-fun-slot
*nil-descriptor
*)
1864 (or (lookup-assembler-reference 'sb
!vm
::undefined-tramp core-file-name
)
1865 ;; Our preload for the tramps doesn't happen during host-1,
1866 ;; so substitute a usable value.
1868 (write-wordindexed/raw fdefn sb
!vm
:fdefn-raw-addr-slot
1869 #!+(and immobile-code x86-64
)
1870 (encode-fdefn-raw-addr fdefn tramp
#xE8
)
1871 #!-immobile-code tramp
)))
1874 (defun cold-functionp (descriptor)
1875 (eql (descriptor-lowtag descriptor
) sb
!vm
:fun-pointer-lowtag
))
1877 (defun cold-fun-entry-addr (fun)
1878 (aver (= (descriptor-lowtag fun
) sb
!vm
:fun-pointer-lowtag
))
1879 (+ (descriptor-bits fun
)
1880 (- sb
!vm
:fun-pointer-lowtag
)
1881 (ash sb
!vm
:simple-fun-code-offset sb
!vm
:word-shift
)))
1883 ;;; Handle a DEFUN in cold-load.
1884 (defun cold-fset (name defn source-loc
&optional inline-expansion
)
1885 ;; SOURCE-LOC can be ignored, because functions intrinsically store
1886 ;; their location as part of the code component.
1887 ;; The argument is supplied here only to provide context for
1888 ;; a redefinition warning, which can't happen in cold load.
1889 (declare (ignore source-loc
))
1890 (sb!int
:binding
* (((cold-name warm-name
)
1891 ;; (SETF f) was descriptorized when dumped, symbols were not.
1893 (values (cold-intern name
) name
)
1894 (values name
(warm-fun-name name
))))
1895 (fdefn (cold-fdefinition-object cold-name t
)))
1896 (when (cold-functionp (cold-fdefn-fun fdefn
))
1897 (error "Duplicate DEFUN for ~S" warm-name
))
1898 ;; There can't be any closures or funcallable instances.
1899 (aver (= (logand (descriptor-bits (read-memory defn
)) sb
!vm
:widetag-mask
)
1900 sb
!vm
:simple-fun-widetag
))
1901 (push (cold-cons cold-name inline-expansion
) *!cold-defuns
*)
1902 (write-wordindexed fdefn sb
!vm
:fdefn-fun-slot defn
)
1903 (let ((fun-entry-addr
1904 (+ (logandc2 (descriptor-bits defn
) sb
!vm
:lowtag-mask
)
1905 (ash sb
!vm
:simple-fun-code-offset sb
!vm
:word-shift
))))
1906 (declare (ignorable fun-entry-addr
)) ; sparc and arm don't need
1907 #!+(and immobile-code x86-64
)
1908 (write-wordindexed/raw fdefn sb
!vm
:fdefn-raw-addr-slot
1909 (encode-fdefn-raw-addr fdefn fun-entry-addr
#xE9
))
1912 #!+(or sparc arm
) (write-wordindexed fdefn sb
!vm
:fdefn-raw-addr-slot defn
)
1913 #!-
(or sparc arm
) (write-wordindexed/raw fdefn sb
!vm
:fdefn-raw-addr-slot
1917 ;;; Handle a DEFMETHOD in cold-load. "Very easily done". Right.
1918 (defun cold-defmethod (name &rest stuff
)
1919 (let ((gf (assoc name
*cold-methods
*)))
1921 (setq gf
(cons name nil
))
1922 (push gf
*cold-methods
*))
1923 (push stuff
(cdr gf
))))
1925 (defun initialize-static-fns ()
1926 (let ((*cold-fdefn-gspace
* *static
*))
1927 (dolist (sym sb
!vm
:+static-fdefns
+)
1928 (let* ((fdefn (cold-fdefinition-object (cold-intern sym
)))
1929 (offset (- (+ (- (descriptor-bits fdefn
)
1930 sb
!vm
:other-pointer-lowtag
)
1931 (* sb
!vm
:fdefn-raw-addr-slot sb
!vm
:n-word-bytes
))
1932 (descriptor-bits *nil-descriptor
*)))
1933 (desired (sb!vm
:static-fun-offset sym
)))
1934 (unless (= offset desired
)
1935 (error "Offset from FDEFN ~S to ~S is ~W, not ~W."
1936 sym nil offset desired
))))))
1938 (defun attach-classoid-cells-to-symbols (hashtable)
1939 (let ((num (sb!c
::meta-info-number
(sb!c
::meta-info
:type
:classoid-cell
)))
1940 (layout (gethash 'sb
!kernel
::classoid-cell
*cold-layouts
*)))
1941 (when (plusp (hash-table-count *classoid-cells
*))
1943 ;; Iteration order is immaterial. The symbols will get sorted later.
1944 (maphash (lambda (symbol cold-classoid-cell
)
1945 ;; Some classoid-cells are dumped before the cold layout
1946 ;; of classoid-cell has been made, so fix those cases now.
1947 ;; Obviously it would be better if, in general, ALLOCATE-STRUCT
1948 ;; knew when something later must backpatch a cold layout
1949 ;; so that it could make a note to itself to do those ASAP
1950 ;; after the cold layout became known.
1951 (when (cold-null (cold-layout-of cold-classoid-cell
))
1952 (set-instance-layout cold-classoid-cell layout
))
1953 (setf (gethash symbol hashtable
)
1955 (gethash symbol hashtable
+nil-packed-infos
+)
1956 sb
!impl
::+no-auxilliary-key
+ num cold-classoid-cell
)))
1960 ;; Create pointer from SYMBOL and/or (SETF SYMBOL) to respective fdefinition
1962 (defun attach-fdefinitions-to-symbols (hashtable)
1963 ;; Collect fdefinitions that go with one symbol, e.g. CAR and (SETF CAR),
1964 ;; using the host's code for manipulating a packed info-vector.
1965 (maphash (lambda (warm-name cold-fdefn
)
1966 (with-globaldb-name (key1 key2
) warm-name
1967 :hairy
(error "Hairy fdefn name in genesis: ~S" warm-name
)
1969 (setf (gethash key1 hashtable
)
1971 (gethash key1 hashtable
+nil-packed-infos
+)
1972 key2
+fdefn-info-num
+ cold-fdefn
))))
1973 *cold-fdefn-objects
*)
1976 (defun dump-symbol-info-vectors (hashtable)
1977 ;; Emit in the same order symbols reside in core to avoid
1978 ;; sensitivity to the iteration order of host's maphash.
1979 (loop for
(warm-sym . info
)
1980 in
(sort (%hash-table-alist hashtable
) #'<
1981 :key
(lambda (x) (descriptor-bits (cold-intern (car x
)))))
1982 do
(write-wordindexed
1983 (cold-intern warm-sym
) sb
!vm
:symbol-info-slot
1984 ;; Each vector will have one fixnum, possibly the symbol SETF,
1985 ;; and one or two #<fdefn> objects in it, and/or a classoid-cell.
1987 (map 'list
(lambda (elt)
1989 (symbol (cold-intern elt
))
1990 (fixnum (make-fixnum-descriptor elt
))
1995 ;;;; fixups and related stuff
1997 ;;; an EQUAL hash table
1998 (defvar *cold-foreign-symbol-table
*)
1999 (declaim (type hash-table
*cold-foreign-symbol-table
*))
2001 ;; Read the sbcl.nm file to find the addresses for foreign-symbols in
2003 (defun load-cold-foreign-symbol-table (filename)
2004 (/show
"load-cold-foreign-symbol-table" filename
)
2005 (with-open-file (file filename
)
2006 (loop for line
= (read-line file nil nil
)
2008 ;; UNIX symbol tables might have tabs in them, and tabs are
2009 ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
2010 ;; nice portable way to deal with them within Lisp, alas.
2011 ;; Fortunately, it's easy to use UNIX command line tools like
2012 ;; sed to remove the problem, so it's not too painful for us
2013 ;; to push responsibility for converting tabs to spaces out to
2016 ;; Other non-STANDARD-CHARs are problematic for the same reason.
2017 ;; Make sure that there aren't any..
2018 (let ((ch (find-if (lambda (char)
2019 (not (typep char
'standard-char
)))
2022 (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
2025 (setf line
(string-trim '(#\space
) line
))
2026 (let ((p1 (position #\space line
:from-end nil
))
2027 (p2 (position #\space line
:from-end t
)))
2028 (if (not (and p1 p2
(< p1 p2
)))
2029 ;; KLUDGE: It's too messy to try to understand all
2030 ;; possible output from nm, so we just punt the lines we
2031 ;; don't recognize. We realize that there's some chance
2032 ;; that might get us in trouble someday, so we warn
2034 (warn "ignoring unrecognized line ~S in ~A" line filename
)
2035 (multiple-value-bind (value name
)
2036 (if (string= "0x" line
:end2
2)
2037 (values (parse-integer line
:start
2 :end p1
:radix
16)
2038 (subseq line
(1+ p2
)))
2039 (values (parse-integer line
:end p1
:radix
16)
2040 (subseq line
(1+ p2
))))
2041 ;; KLUDGE CLH 2010-05-31: on darwin, nm gives us
2042 ;; _function but dlsym expects us to look up
2043 ;; function, without the leading _ . Therefore, we
2044 ;; strip it off here.
2046 (when (equal (char name
0) #\_
)
2047 (setf name
(subseq name
1)))
2048 (multiple-value-bind (old-value found
)
2049 (gethash name
*cold-foreign-symbol-table
*)
2051 (not (= old-value value
)))
2052 (warn "redefining ~S from #X~X to #X~X"
2053 name old-value value
)))
2054 (/show
"adding to *cold-foreign-symbol-table*:" name value
)
2055 (setf (gethash name
*cold-foreign-symbol-table
*) value
)
2057 (let ((at-position (position #\
@ name
)))
2059 (let ((name (subseq name
0 at-position
)))
2060 (multiple-value-bind (old-value found
)
2061 (gethash name
*cold-foreign-symbol-table
*)
2063 (not (= old-value value
)))
2064 (warn "redefining ~S from #X~X to #X~X"
2065 name old-value value
)))
2066 (setf (gethash name
*cold-foreign-symbol-table
*)
2070 (defun cold-foreign-symbol-address (name)
2071 (declare (ignorable name
))
2072 #!+crossbuild-test
#xf00fa8
; any random 4-octet-aligned value should do
2074 (or (find-foreign-symbol-in-table name
*cold-foreign-symbol-table
*)
2075 *foreign-symbol-placeholder-value
*
2077 (format *error-output
* "~&The foreign symbol table is:~%")
2078 (maphash (lambda (k v
)
2079 (format *error-output
* "~&~S = #X~8X~%" k v
))
2080 *cold-foreign-symbol-table
*)
2081 (error "The foreign symbol ~S is undefined." name
))))
2083 (defvar *cold-assembler-routines
*)
2085 (defvar *cold-assembler-fixups
*)
2086 (defvar *cold-static-call-fixups
*)
2088 (defun record-cold-assembler-routine (name address
)
2089 (/xhow
"in RECORD-COLD-ASSEMBLER-ROUTINE" name address
)
2090 (push (cons name address
)
2091 *cold-assembler-routines
*))
2093 (defun lookup-assembler-reference (symbol &optional
(errorp t
))
2094 (let ((value (cdr (assoc symbol
*cold-assembler-routines
*))))
2097 (error "Assembler routine ~S not defined." symbol
)))
2100 ;;; Unlike in the target, FOP-KNOWN-FUN sometimes has to backpatch.
2101 (defvar *deferred-known-fun-refs
*)
2103 ;;; In case we need to store code fixups in code objects.
2104 ;;; At present only the x86 backends use this
2105 (defvar *code-fixup-notes
*)
2107 ;;; Given a pointer to a code object and a byte offset relative to the
2108 ;;; tail of the code object's header, return a byte offset relative to the
2109 ;;; (beginning of the) code object.
2111 (declaim (ftype (function (descriptor sb
!vm
:word
)) calc-offset
))
2112 (defun calc-offset (code-object insts-offset-bytes
)
2113 (+ (ash (logand (get-header-data code-object
) sb
!vm
:short-header-max-words
)
2115 insts-offset-bytes
))
2117 (declaim (ftype (function (descriptor sb
!vm
:word sb
!vm
:word
2118 keyword
&optional keyword
) descriptor
)
2120 (defun do-cold-fixup (code-object after-header value kind
&optional flavor
)
2121 (declare (ignorable flavor
))
2122 (let* ((offset-within-code-object (calc-offset code-object after-header
))
2123 (gspace-byte-offset (+ (descriptor-byte-offset code-object
)
2124 offset-within-code-object
)))
2126 (sb!vm
::fixup-code-object code-object gspace-byte-offset value kind
)
2129 (let* ((gspace-data (descriptor-mem code-object
))
2130 (obj-start-addr (logandc2 (descriptor-bits code-object
) sb
!vm
:lowtag-mask
))
2133 (ash (logand (get-header-data code-object
)
2134 sb
!vm
:short-header-max-words
) sb
!vm
:word-shift
)
2136 (read-wordindexed code-object sb
!vm
:code-code-size-slot
))))
2137 (gspace-base (gspace-byte-address (descriptor-gspace code-object
)))
2139 (= (gspace-identifier (descriptor-intuit-gspace code-object
))
2140 dynamic-core-space-id
))
2142 (sb!vm
::sign-extend
(bvref-32 gspace-data gspace-byte-offset
)
2145 (declare (ignorable code-end-addr in-dynamic-space
))
2146 (assert (= obj-start-addr
2147 (+ gspace-base
(descriptor-byte-offset code-object
))))
2149 ;; See FIXUP-CODE-OBJECT in x86-vm.lisp and x86-64-vm.lisp.
2150 ;; Except for the use of saps, this is basically identical.
2153 (setf (bvref-32 gspace-data gspace-byte-offset
)
2154 (the (unsigned-byte 32) addr
))
2155 ;; Absolute fixups are recorded if within the object for x86.
2156 #!+x86
(and in-dynamic-space
2157 (< obj-start-addr addr code-end-addr
))
2158 ;; Absolute :immobile-object fixups are recorded for x86-64.
2159 #!+x86-64
(eq flavor
:immobile-object
))
2160 (:relative
; (used for arguments to X86 relative CALL instruction)
2161 (setf (bvref-32 gspace-data gspace-byte-offset
)
2162 (the (signed-byte 32)
2163 (- addr
(+ gspace-base gspace-byte-offset
4)))) ; 4 = size of rel32off
2164 ;; Relative fixups are recorded if without the object.
2165 ;; Except that read-only space contains calls to asm routines,
2166 ;; and we don't record those fixups.
2167 #!+x86
(and in-dynamic-space
2168 (not (< obj-start-addr addr code-end-addr
)))
2170 (push after-header
(gethash (descriptor-bits code-object
)
2171 *code-fixup-notes
*)))))
2174 (defun resolve-assembler-fixups ()
2175 (dolist (fixup *cold-assembler-fixups
*)
2176 (let* ((routine (car fixup
))
2177 (value (lookup-assembler-reference routine
)))
2179 (do-cold-fixup (second fixup
) (third fixup
) value
(fourth fixup
)))))
2180 ;; Static calls are very similar to assembler routine calls,
2181 ;; so take care of those too.
2182 (dolist (fixup *cold-static-call-fixups
*)
2183 (destructuring-bind (name kind code offset
) fixup
2184 (do-cold-fixup code offset
2185 (cold-fun-entry-addr
2186 (cold-fdefn-fun (cold-fdefinition-object name
)))
2191 (defparameter *dyncore-address
* sb
!vm
::linkage-table-space-start
)
2192 (defparameter *dyncore-linkage-keys
* nil
)
2193 (defparameter *dyncore-table
* (make-hash-table :test
'equal
))
2195 (defun dyncore-note-symbol (symbol-name datap
)
2196 "Register a symbol and return its address in proto-linkage-table."
2197 (let ((key (cons symbol-name datap
)))
2198 (symbol-macrolet ((entry (gethash key
*dyncore-table
*)))
2201 (prog1 *dyncore-address
*
2202 (push key
*dyncore-linkage-keys
*)
2203 (incf *dyncore-address
* sb
!vm
::linkage-table-entry-size
))))))))
2205 ;;; *COLD-FOREIGN-SYMBOL-TABLE* becomes *!INITIAL-FOREIGN-SYMBOLS* in
2206 ;;; the core. When the core is loaded, !LOADER-COLD-INIT uses this to
2207 ;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
2208 ;;; target-load.lisp refers to.
2209 (defun foreign-symbols-to-core ()
2210 (flet ((to-core (list transducer target-symbol
)
2211 (cold-set target-symbol
(vector-in-core (mapcar transducer list
)))))
2213 (to-core (sort (%hash-table-alist
*cold-foreign-symbol-table
*) #'string
< :key
#'car
)
2215 (cold-cons (set-readonly (base-string-to-core (car symbol
)))
2216 (number-to-core (cdr symbol
))))
2217 '*!initial-foreign-symbols
*)
2219 ;; Linkage table is recomputed by Lisp, so foreign symbols have to be listed
2220 ;; in the proper order, which is the reverse of the currently stored order.
2221 (to-core (nreverse *dyncore-linkage-keys
*)
2223 (cold-cons (set-readonly (base-string-to-core (car symbol
)))
2225 'sb
!vm
::+required-runtime-c-symbols
+)
2226 (to-core (sort (copy-list *cold-assembler-routines
*) #'string
< :key
#'car
)
2228 (cold-cons (cold-intern (car rtn
)) (number-to-core (cdr rtn
))))
2229 '*!initial-assembler-routines
*)))
2232 ;;;; general machinery for cold-loading FASL files
2234 (defun pop-fop-stack (stack)
2235 (let ((top (svref stack
0)))
2236 (declare (type index top
))
2238 (error "FOP stack empty"))
2239 (setf (svref stack
0) (1- top
))
2242 ;;; Cause a fop to have a special definition for cold load.
2244 ;;; This is similar to DEFINE-FOP, but unlike DEFINE-FOP, this version
2245 ;;; looks up the encoding for this name (created by a previous DEFINE-FOP)
2246 ;;; instead of creating a new encoding.
2247 (defmacro define-cold-fop
((name &optional arglist
) &rest forms
)
2248 (let* ((code (get name
'opcode
))
2249 (argc (aref (car **fop-signatures
**) code
))
2250 (fname (symbolicate "COLD-" name
)))
2252 (error "~S is not a defined FOP." name
))
2253 (when (and (plusp argc
) (not (singleton-p arglist
)))
2254 (error "~S must take one argument" name
))
2256 (defun ,fname
(.fasl-input.
,@arglist
)
2257 (declare (ignorable .fasl-input.
))
2258 (macrolet ((fasl-input () '(the fasl-input .fasl-input.
))
2259 (fasl-input-stream () '(%fasl-input-stream
(fasl-input)))
2261 '(pop-fop-stack (%fasl-input-stack
(fasl-input)))))
2263 ;; We simply overwrite elements of **FOP-FUNS** since the contents
2264 ;; of the host are never propagated directly into the target core.
2265 ,@(loop for i from code to
(logior code
(if (plusp argc
) 3 0))
2266 collect
`(setf (svref **fop-funs
** ,i
) #',fname
)))))
2268 ;;; Cause a fop to be undefined in cold load.
2269 (defmacro not-cold-fop
(name)
2270 `(define-cold-fop (,name
)
2271 (error "The fop ~S is not supported in cold load." ',name
)))
2273 ;;; COLD-LOAD loads stuff into the core image being built by calling
2274 ;;; LOAD-AS-FASL with the fop function table rebound to a table of cold
2275 ;;; loading functions.
2276 (defun cold-load (filename)
2277 "Load the file named by FILENAME into the cold load image being built."
2278 (write-line (namestring filename
))
2279 (with-open-file (s filename
:element-type
'(unsigned-byte 8))
2280 (load-as-fasl s nil nil
)))
2282 ;;;; miscellaneous cold fops
2284 (define-cold-fop (fop-misc-trap) *unbound-marker
*)
2286 (define-cold-fop (fop-character (c))
2287 (make-character-descriptor c
))
2289 (define-cold-fop (fop-empty-list) nil
)
2290 (define-cold-fop (fop-truth) t
)
2292 (define-cold-fop (fop-struct (size)) ; n-words incl. layout, excluding header
2293 (let* ((layout (pop-stack))
2294 (result (allocate-struct *dynamic
* layout size
))
2295 (bitmap (descriptor-fixnum
2296 (read-slot layout
*host-layout-of-layout
* :bitmap
))))
2297 ;; Raw slots can not possibly work because dump-struct uses
2298 ;; %RAW-INSTANCE-REF/WORD which does not exist in the cross-compiler.
2299 ;; Remove this assertion if that problem is somehow circumvented.
2300 (unless (eql bitmap sb
!kernel
::+layout-all-tagged
+)
2301 (error "Raw slots not working in genesis."))
2302 (loop for index downfrom
(1- size
) to sb
!vm
:instance-data-start
2303 for val
= (pop-stack) then
(pop-stack)
2304 do
(write-wordindexed result
2305 (+ index sb
!vm
:instance-slots-offset
)
2306 (if (logbitp index bitmap
)
2308 (descriptor-word-sized-integer val
))))
2311 (define-cold-fop (fop-layout)
2312 (let* ((bitmap-des (pop-stack))
2313 (length-des (pop-stack))
2314 (depthoid-des (pop-stack))
2315 (cold-inherits (pop-stack))
2317 (old-layout-descriptor (gethash name
*cold-layouts
*)))
2318 (declare (type descriptor length-des depthoid-des cold-inherits
))
2319 (declare (type symbol name
))
2320 ;; If a layout of this name has been defined already
2321 (if old-layout-descriptor
2322 ;; Enforce consistency between the previous definition and the
2323 ;; current definition, then return the previous definition.
2324 (flet ((get-slot (keyword)
2325 (read-slot old-layout-descriptor
*host-layout-of-layout
* keyword
)))
2326 (let ((old-length (descriptor-fixnum (get-slot :length
)))
2327 (old-depthoid (descriptor-fixnum (get-slot :depthoid
)))
2328 (old-bitmap (host-object-from-core (get-slot :bitmap
)))
2329 (length (descriptor-fixnum length-des
))
2330 (depthoid (descriptor-fixnum depthoid-des
))
2331 (bitmap (host-object-from-core bitmap-des
)))
2332 (unless (= length old-length
)
2333 (error "cold loading a reference to class ~S when the compile~%~
2334 time length was ~S and current length is ~S"
2338 (unless (cold-vector-elements-eq cold-inherits
(get-slot :inherits
))
2339 (error "cold loading a reference to class ~S when the compile~%~
2340 time inherits were ~S~%~
2341 and current inherits are ~S"
2343 (listify-cold-inherits cold-inherits
)
2344 (listify-cold-inherits (get-slot :inherits
))))
2345 (unless (= depthoid old-depthoid
)
2346 (error "cold loading a reference to class ~S when the compile~%~
2347 time inheritance depthoid was ~S and current inheritance~%~
2352 (unless (= bitmap old-bitmap
)
2353 (error "cold loading a reference to class ~S when the compile~%~
2354 time raw-slot-bitmap was ~S and is currently ~S"
2355 name bitmap old-bitmap
)))
2356 old-layout-descriptor
)
2357 ;; Make a new definition from scratch.
2358 (make-cold-layout name length-des cold-inherits depthoid-des bitmap-des
))))
2360 ;;;; cold fops for loading symbols
2362 ;;; Load a symbol SIZE characters long from FASL-INPUT, and
2363 ;;; intern that symbol in PACKAGE.
2364 (defun cold-load-symbol (length+flag package fasl-input
)
2365 (let ((string (make-string (ash length
+flag -
1))))
2366 (read-string-as-bytes (%fasl-input-stream fasl-input
) string
)
2367 (push-fop-table (intern string package
) fasl-input
)))
2369 ;; I don't feel like hacking up DEFINE-COLD-FOP any more than necessary,
2370 ;; so this code is handcrafted to accept two operands.
2371 (flet ((fop-cold-symbol-in-package-save (fasl-input length
+flag pkg-index
)
2372 (cold-load-symbol length
+flag
(ref-fop-table fasl-input pkg-index
)
2374 (let ((i (get 'fop-symbol-in-package-save
'opcode
)))
2375 (fill **fop-funs
** #'fop-cold-symbol-in-package-save
:start i
:end
(+ i
4))))
2377 (define-cold-fop (fop-lisp-symbol-save (length+flag
))
2378 (cold-load-symbol length
+flag
*cl-package
* (fasl-input)))
2380 (define-cold-fop (fop-keyword-symbol-save (length+flag
))
2381 (cold-load-symbol length
+flag
*keyword-package
* (fasl-input)))
2383 (define-cold-fop (fop-uninterned-symbol-save (length+flag
))
2384 (let ((name (make-string (ash length
+flag -
1))))
2385 (read-string-as-bytes (fasl-input-stream) name
)
2386 (push-fop-table (get-uninterned-symbol name
) (fasl-input))))
2388 (define-cold-fop (fop-copy-symbol-save (index))
2389 (let* ((symbol (ref-fop-table (fasl-input) index
))
2391 (if (symbolp symbol
)
2392 (symbol-name symbol
)
2393 (base-string-from-core
2394 (read-wordindexed symbol sb
!vm
:symbol-name-slot
)))))
2395 ;; Genesis performs additional coalescing of uninterned symbols
2396 (push-fop-table (get-uninterned-symbol name
) (fasl-input))))
2398 ;;;; cold fops for loading packages
2400 (define-cold-fop (fop-named-package-save (namelen))
2401 (let ((name (make-string namelen
)))
2402 (read-string-as-bytes (fasl-input-stream) name
)
2403 (push-fop-table (find-package name
) (fasl-input))))
2405 ;;;; cold fops for loading lists
2407 ;;; Make a list of the top LENGTH things on the fop stack. The last
2408 ;;; cdr of the list is set to LAST.
2409 (defmacro cold-stack-list
(length last
)
2410 `(do* ((index ,length
(1- index
))
2411 (result ,last
(cold-cons (pop-stack) result
)))
2412 ((= index
0) result
)
2413 (declare (fixnum index
))))
2415 (define-cold-fop (fop-list)
2416 (cold-stack-list (read-byte-arg (fasl-input-stream)) *nil-descriptor
*))
2417 (define-cold-fop (fop-list*)
2418 (cold-stack-list (read-byte-arg (fasl-input-stream)) (pop-stack)))
2419 (define-cold-fop (fop-list-1)
2420 (cold-stack-list 1 *nil-descriptor
*))
2421 (define-cold-fop (fop-list-2)
2422 (cold-stack-list 2 *nil-descriptor
*))
2423 (define-cold-fop (fop-list-3)
2424 (cold-stack-list 3 *nil-descriptor
*))
2425 (define-cold-fop (fop-list-4)
2426 (cold-stack-list 4 *nil-descriptor
*))
2427 (define-cold-fop (fop-list-5)
2428 (cold-stack-list 5 *nil-descriptor
*))
2429 (define-cold-fop (fop-list-6)
2430 (cold-stack-list 6 *nil-descriptor
*))
2431 (define-cold-fop (fop-list-7)
2432 (cold-stack-list 7 *nil-descriptor
*))
2433 (define-cold-fop (fop-list-8)
2434 (cold-stack-list 8 *nil-descriptor
*))
2435 (define-cold-fop (fop-list*-
1)
2436 (cold-stack-list 1 (pop-stack)))
2437 (define-cold-fop (fop-list*-
2)
2438 (cold-stack-list 2 (pop-stack)))
2439 (define-cold-fop (fop-list*-
3)
2440 (cold-stack-list 3 (pop-stack)))
2441 (define-cold-fop (fop-list*-
4)
2442 (cold-stack-list 4 (pop-stack)))
2443 (define-cold-fop (fop-list*-
5)
2444 (cold-stack-list 5 (pop-stack)))
2445 (define-cold-fop (fop-list*-
6)
2446 (cold-stack-list 6 (pop-stack)))
2447 (define-cold-fop (fop-list*-
7)
2448 (cold-stack-list 7 (pop-stack)))
2449 (define-cold-fop (fop-list*-
8)
2450 (cold-stack-list 8 (pop-stack)))
2452 ;;;; cold fops for loading vectors
2454 (define-cold-fop (fop-base-string (len))
2455 (let ((string (make-string len
)))
2456 (read-string-as-bytes (fasl-input-stream) string
)
2457 (set-readonly (base-string-to-core string
))))
2460 (define-cold-fop (fop-character-string (len))
2461 (bug "CHARACTER-STRING[~D] dumped by cross-compiler." len
))
2463 (define-cold-fop (fop-vector (size))
2465 *simple-vector-0-descriptor
*
2466 (let ((result (allocate-vector-object *dynamic
*
2469 sb
!vm
:simple-vector-widetag
)))
2470 (do ((index (1- size
) (1- index
)))
2472 (declare (fixnum index
))
2473 (write-wordindexed result
2474 (+ index sb
!vm
:vector-data-offset
)
2476 (set-readonly result
))))
2478 (define-cold-fop (fop-spec-vector)
2479 (let* ((len (read-word-arg (fasl-input-stream)))
2480 (type (read-byte-arg (fasl-input-stream)))
2481 (sizebits (aref **saetp-bits-per-length
** type
))
2482 (result (progn (aver (< sizebits
255))
2483 (allocate-vector-object *dynamic
* sizebits len type
)))
2484 (start (+ (descriptor-byte-offset result
)
2485 (ash sb
!vm
:vector-data-offset sb
!vm
:word-shift
)))
2487 (ceiling (* len sizebits
)
2488 sb
!vm
:n-byte-bits
))))
2489 (read-bigvec-as-sequence-or-die (descriptor-mem result
)
2493 (set-readonly result
)))
2495 (not-cold-fop fop-array
)
2497 ;; This code is unexercised. The only use of FOP-ARRAY is from target-dump.
2498 ;; It would be a shame to delete it though, as it might come in handy.
2499 (define-cold-fop (fop-array)
2500 (let* ((rank (read-word-arg (fasl-input-stream)))
2501 (data-vector (pop-stack))
2502 (result (allocate-object *dynamic
*
2503 (+ sb
!vm
:array-dimensions-offset rank
)
2504 sb
!vm
:other-pointer-lowtag
)))
2505 (write-header-word result rank sb
!vm
:simple-array-widetag
)
2506 (write-wordindexed result sb
!vm
:array-fill-pointer-slot
*nil-descriptor
*)
2507 (write-wordindexed result sb
!vm
:array-data-slot data-vector
)
2508 (write-wordindexed result sb
!vm
:array-displacement-slot
*nil-descriptor
*)
2509 (write-wordindexed result sb
!vm
:array-displaced-p-slot
*nil-descriptor
*)
2510 (write-wordindexed result sb
!vm
:array-displaced-from-slot
*nil-descriptor
*)
2511 (let ((total-elements 1))
2512 (dotimes (axis rank
)
2513 (let ((dim (pop-stack)))
2514 (unless (is-fixnum-lowtag (descriptor-lowtag dim
))
2515 (error "non-fixnum dimension? (~S)" dim
))
2516 (setf total-elements
(* total-elements
(descriptor-fixnum dim
)))
2517 (write-wordindexed result
2518 (+ sb
!vm
:array-dimensions-offset axis
)
2520 (write-wordindexed result
2521 sb
!vm
:array-elements-slot
2522 (make-fixnum-descriptor total-elements
)))
2526 ;;;; cold fops for loading numbers
2528 (defmacro define-cold-number-fop
(fop &optional arglist
)
2529 ;; Invoke the ordinary warm version of this fop to cons the number.
2530 `(define-cold-fop (,fop
,arglist
)
2531 (number-to-core (,fop
(fasl-input) ,@arglist
))))
2533 (define-cold-number-fop fop-single-float
)
2534 (define-cold-number-fop fop-double-float
)
2535 (define-cold-number-fop fop-word-integer
)
2536 (define-cold-number-fop fop-byte-integer
)
2537 (define-cold-number-fop fop-complex-single-float
)
2538 (define-cold-number-fop fop-complex-double-float
)
2539 (define-cold-number-fop fop-integer
(n-bytes))
2541 (define-cold-fop (fop-ratio)
2542 (let ((den (pop-stack)))
2543 (number-pair-to-core (pop-stack) den sb
!vm
:ratio-widetag
)))
2545 (define-cold-fop (fop-complex)
2546 (let ((im (pop-stack)))
2547 (number-pair-to-core (pop-stack) im sb
!vm
:complex-widetag
)))
2549 ;;;; cold fops for calling (or not calling)
2551 (not-cold-fop fop-eval
)
2552 (not-cold-fop fop-eval-for-effect
)
2554 (defvar *load-time-value-counter
*)
2556 (flet ((pop-args (fasl-input)
2558 (stack (%fasl-input-stack fasl-input
)))
2559 (dotimes (i (read-byte-arg (%fasl-input-stream fasl-input
))
2560 (values (pop-fop-stack stack
) args
))
2561 (push (pop-fop-stack stack
) args
))))
2562 (call (fun-name handler-name args
)
2563 (acond ((get fun-name handler-name
) (apply it args
))
2564 (t (error "Can't ~S ~S in cold load" handler-name fun-name
)))))
2566 (define-cold-fop (fop-funcall)
2567 (multiple-value-bind (fun args
) (pop-args (fasl-input))
2571 ;; Special form #'F fopcompiles into `(FDEFINITION ,f)
2572 (aver (and (singleton-p args
) (symbolp (car args
))))
2573 (target-symbol-function (car args
)))
2574 (cons (cold-cons (first args
) (second args
)))
2575 (symbol-global-value (cold-symbol-value (first args
)))
2576 (t (call fun
:sb-cold-funcall-handler
/for-value args
)))
2577 (let ((counter *load-time-value-counter
*))
2578 (push (cold-list (cold-intern :load-time-value
) fun
2579 (number-to-core counter
)) *!cold-toplevels
*)
2580 (setf *load-time-value-counter
* (1+ counter
))
2581 (make-descriptor 0 :load-time-value counter
)))))
2583 (define-cold-fop (fop-funcall-for-effect)
2584 (multiple-value-bind (fun args
) (pop-args (fasl-input))
2586 (push fun
*!cold-toplevels
*)
2588 (sb!impl
::%defun
(apply #'cold-fset args
))
2589 (sb!pcl
::!trivial-defmethod
(apply #'cold-defmethod
args))
2590 (sb!kernel
::%defstruct
2591 (push args
*known-structure-classoids
*)
2592 (push (apply #'cold-list
(cold-intern 'defstruct
) args
)
2595 (destructuring-bind (name val . rest
) args
2596 (cold-set name
(if (symbolp val
) (cold-intern val
) val
))
2597 (push (cold-cons (cold-intern name
) (list-to-core rest
))
2598 *!cold-defconstants
*)))
2600 (aver (= (length args
) 2))
2601 (cold-set (first args
)
2602 (let ((val (second args
)))
2603 (if (symbolp val
) (cold-intern val
) val
))))
2604 (%svset
(apply 'cold-svset args
))
2605 (t (call fun
:sb-cold-funcall-handler
/for-effect args
)))))))
2607 (defun finalize-load-time-value-noise ()
2608 (cold-set '*!load-time-values
*
2609 (allocate-vector-object *dynamic
*
2611 *load-time-value-counter
*
2612 sb
!vm
:simple-vector-widetag
)))
2615 ;;;; cold fops for fixing up circularities
2617 (define-cold-fop (fop-rplaca)
2618 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
2619 (idx (read-word-arg (fasl-input-stream))))
2620 (write-memory (cold-nthcdr idx obj
) (pop-stack))))
2622 (define-cold-fop (fop-rplacd)
2623 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
2624 (idx (read-word-arg (fasl-input-stream))))
2625 (write-wordindexed (cold-nthcdr idx obj
) 1 (pop-stack))))
2627 (define-cold-fop (fop-svset)
2628 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
2629 (idx (read-word-arg (fasl-input-stream))))
2630 (write-wordindexed obj
2632 (ecase (descriptor-lowtag obj
)
2633 (#.sb
!vm
:instance-pointer-lowtag
1)
2634 (#.sb
!vm
:other-pointer-lowtag
2)))
2637 (define-cold-fop (fop-structset)
2638 (let ((obj (ref-fop-table (fasl-input) (read-word-arg (fasl-input-stream))))
2639 (idx (read-word-arg (fasl-input-stream))))
2640 (write-wordindexed obj
(+ idx sb
!vm
:instance-slots-offset
) (pop-stack))))
2642 (define-cold-fop (fop-nthcdr)
2643 (cold-nthcdr (read-word-arg (fasl-input-stream)) (pop-stack)))
2645 (defun cold-nthcdr (index obj
)
2647 (setq obj
(read-wordindexed obj sb
!vm
:cons-cdr-slot
)))
2650 ;;;; cold fops for loading code objects and functions
2652 (define-cold-fop (fop-fdefn)
2653 (cold-fdefinition-object (pop-stack)))
2655 (define-cold-fop (fop-known-fun)
2656 (let* ((name (pop-stack))
2657 (fun (cold-fdefn-fun (cold-fdefinition-object name
))))
2658 (if (cold-null fun
) `(:known-fun .
,name
) fun
)))
2660 #!-
(or x86
(and x86-64
(not immobile-space
)))
2661 (define-cold-fop (fop-sanctify-for-execution)
2664 ;;; Setting this variable shows what code looks like before any
2665 ;;; fixups (or function headers) are applied.
2666 #!+sb-show
(defvar *show-pre-fixup-code-p
* nil
)
2668 (defun cold-load-code (fasl-input code-size nconst nfuns
)
2669 (macrolet ((pop-stack () '(pop-fop-stack (%fasl-input-stack fasl-input
))))
2670 (let* ((raw-header-n-words (+ sb
!vm
:code-constants-offset nconst
))
2671 ;; Note that the number of constants is rounded up to ensure
2672 ;; that the code vector will be properly aligned.
2673 (header-n-words (round-up raw-header-n-words
2))
2674 (toplevel-p (pop-stack))
2675 (debug-info (pop-stack))
2676 (des (allocate-cold-descriptor
2677 #!-immobile-code
*dynamic
*
2678 ;; toplevel-p is an indicator of whether the code will
2679 ;; will become garbage. If so, put it in dynamic space,
2680 ;; otherwise immobile space.
2682 (if toplevel-p
*dynamic
* *immobile-varyobj
*)
2683 (+ (ash header-n-words sb
!vm
:word-shift
) code-size
)
2684 sb
!vm
:other-pointer-lowtag
)))
2685 (declare (ignorable toplevel-p
))
2686 (write-header-word des header-n-words sb
!vm
:code-header-widetag
)
2687 (write-wordindexed des sb
!vm
:code-code-size-slot
2688 (make-fixnum-descriptor code-size
))
2689 (write-wordindexed des sb
!vm
:code-debug-info-slot debug-info
)
2690 (do ((index (1- raw-header-n-words
) (1- index
)))
2691 ((< index sb
!vm
:code-constants-offset
))
2692 (let ((obj (pop-stack)))
2693 (if (and (consp obj
) (eq (car obj
) :known-fun
))
2694 (push (list* (cdr obj
) des index
) *deferred-known-fun-refs
*)
2695 (write-wordindexed des index obj
))))
2696 (let* ((start (+ (descriptor-byte-offset des
)
2697 (ash header-n-words sb
!vm
:word-shift
)))
2698 (end (+ start code-size
)))
2699 (read-bigvec-as-sequence-or-die (descriptor-mem des
)
2700 (%fasl-input-stream fasl-input
)
2704 ;; Emulate NEW-SIMPLE-FUN in target-core
2705 (loop for fun-index from
(1- nfuns
) downto
0
2706 do
(let ((offset (read-varint-arg fasl-input
)))
2708 (let ((bytes (descriptor-mem des
))
2709 (index (+ (descriptor-byte-offset des
)
2710 (calc-offset des
(ash (1- fun-index
) 2)))))
2711 (aver (eql (bvref-32 bytes index
) 0))
2712 (setf (bvref-32 bytes index
) offset
))
2714 (write-wordindexed/raw
2716 sb
!vm
::code-n-entries-slot
2717 (logior (ash offset
16)
2718 (ash nfuns sb
!vm
:n-fixnum-tag-bits
)))
2720 (write-wordindexed/raw
2722 (logior (ash (logior (ash offset
16) nfuns
) 32)
2723 (read-bits-wordindexed des
0))))))
2726 (when *show-pre-fixup-code-p
*
2727 (format *trace-output
*
2728 "~&/raw code from code-fop ~W ~W:~%"
2731 (do ((i start
(+ i sb
!vm
:n-word-bytes
)))
2733 (format *trace-output
*
2734 "/#X~8,'0x: #X~8,'0x~%"
2735 (+ i
(gspace-byte-address (descriptor-gspace des
)))
2736 (bvref-32 (descriptor-mem des
) i
)))))
2739 (let ((i (get 'fop-code
'opcode
)))
2740 (fill **fop-funs
** #'cold-load-code
:start i
:end
(+ i
4)))
2742 (defun resolve-deferred-known-funs ()
2743 (dolist (item *deferred-known-fun-refs
*)
2744 (let ((fun (cold-fdefn-fun (cold-fdefinition-object (car item
)))))
2745 (aver (not (cold-null fun
)))
2746 (let ((place (cdr item
)))
2747 (write-wordindexed (car place
) (cdr place
) fun
)))))
2749 (define-cold-fop (fop-alter-code (slot))
2750 (let ((value (pop-stack))
2752 (write-wordindexed code slot value
)))
2754 (defvar *simple-fun-metadata
* (make-hash-table :test
'equalp
))
2756 ;; Return an expression that can be used to coalesce type-specifiers
2757 ;; and lambda lists attached to simple-funs. It doesn't have to be
2758 ;; a "correct" host representation, just something that preserves EQUAL-ness.
2759 (defun make-equal-comparable-thing (descriptor)
2760 (labels ((recurse (x)
2761 (cond ((cold-null x
) (return-from recurse nil
))
2762 ((is-fixnum-lowtag (descriptor-lowtag x
))
2763 (return-from recurse
(descriptor-fixnum x
)))
2765 ((is-other-immediate-lowtag (descriptor-lowtag x
))
2766 (let ((bits (descriptor-bits x
)))
2767 (when (= (logand bits sb
!vm
:widetag-mask
)
2768 sb
!vm
:single-float-widetag
)
2769 (return-from recurse
`(:ffloat-bits
,bits
))))))
2770 (ecase (descriptor-lowtag x
)
2771 (#.sb
!vm
:list-pointer-lowtag
2772 (cons (recurse (cold-car x
)) (recurse (cold-cdr x
))))
2773 (#.sb
!vm
:other-pointer-lowtag
2774 (ecase (logand (descriptor-bits (read-memory x
)) sb
!vm
:widetag-mask
)
2775 (#.sb
!vm
:symbol-widetag
2776 (if (cold-null (read-wordindexed x sb
!vm
:symbol-package-slot
))
2777 (get-or-make-uninterned-symbol
2778 (base-string-from-core
2779 (read-wordindexed x sb
!vm
:symbol-name-slot
)))
2782 (#.sb
!vm
:single-float-widetag
2784 ,(read-bits-wordindexed x sb
!vm
:single-float-value-slot
)))
2785 (#.sb
!vm
:double-float-widetag
2787 ,(read-bits-wordindexed x sb
!vm
:double-float-value-slot
)
2789 ,(read-bits-wordindexed
2790 x
(1+ sb
!vm
:double-float-value-slot
))))
2791 (#.sb
!vm
:bignum-widetag
2792 (bignum-from-core x
))
2793 (#.sb
!vm
:simple-base-string-widetag
2794 (base-string-from-core x
))
2795 ;; Why do function lambda lists have simple-vectors in them?
2796 ;; Because we expose all &OPTIONAL and &KEY default forms.
2797 ;; I think this is abstraction leakage, except possibly for
2798 ;; advertised constant defaults of NIL and such.
2799 ;; How one expresses a value as a sexpr should otherwise
2800 ;; be of no concern to a user of the code.
2801 (#.sb
!vm
:simple-vector-widetag
2802 (vector-from-core x
#'recurse
))))))
2803 ;; Return a warm symbol whose name is similar to NAME, coaelescing
2804 ;; all occurrences of #:.WHOLE. across all files, e.g.
2805 (get-or-make-uninterned-symbol (name)
2806 (let ((key `(:uninterned-symbol
,name
)))
2807 (or (gethash key
*simple-fun-metadata
*)
2808 (let ((symbol (make-symbol name
)))
2809 (setf (gethash key
*simple-fun-metadata
*) symbol
))))))
2810 (recurse descriptor
)))
2812 (defun fun-offset (code-object fun-index
)
2814 (bvref-32 (descriptor-mem code-object
)
2815 (+ (descriptor-byte-offset code-object
)
2816 (calc-offset code-object
(ash (1- fun-index
) 2))))
2818 #!-
64-bit
(read-bits-wordindexed code-object sb
!vm
::code-n-entries-slot
)
2819 #!+64-bit
(ldb (byte 32 32) (read-bits-wordindexed code-object
0)))))
2821 (defun compute-fun (code-object fun-index
)
2822 (let* ((offset-from-insns-start (fun-offset code-object fun-index
))
2823 (offset-from-code-start (calc-offset code-object offset-from-insns-start
)))
2824 (unless (zerop (logand offset-from-code-start sb
!vm
:lowtag-mask
))
2825 (error "unaligned function entry ~S ~S" code-object fun-index
))
2826 (make-descriptor (logior (+ (logandc2 (descriptor-bits code-object
) sb
!vm
:lowtag-mask
)
2827 offset-from-code-start
)
2828 sb
!vm
:fun-pointer-lowtag
))))
2830 (defun cold-fop-fun-entry (fasl-input fun-index
)
2831 (binding* (((info type arglist name code-object
)
2832 (macrolet ((pop-stack ()
2833 '(pop-fop-stack (%fasl-input-stack fasl-input
))))
2834 (values (pop-stack) (pop-stack) (pop-stack) (pop-stack) (pop-stack))))
2835 (fn (compute-fun code-object fun-index
)))
2836 #!+(or x86 x86-64
) ; store a machine-native pointer to the function entry
2837 ;; note that the bit pattern looks like fixnum due to alignment
2838 (write-wordindexed/raw fn sb
!vm
:simple-fun-self-slot
2839 (+ (- (descriptor-bits fn
) sb
!vm
:fun-pointer-lowtag
)
2840 (ash sb
!vm
:simple-fun-code-offset sb
!vm
:word-shift
)))
2841 #!-
(or x86 x86-64
) ; store a pointer back to the function itself in 'self'
2842 (write-wordindexed fn sb
!vm
:simple-fun-self-slot fn
)
2843 (write-wordindexed fn sb
!vm
:simple-fun-name-slot name
)
2844 (flet ((coalesce (sexpr) ; a warm symbol or a cold cons tree
2845 (if (symbolp sexpr
) ; will be cold-interned automatically
2847 (let ((representation (make-equal-comparable-thing sexpr
)))
2848 (or (gethash representation
*simple-fun-metadata
*)
2849 (setf (gethash representation
*simple-fun-metadata
*)
2851 (write-wordindexed fn sb
!vm
:simple-fun-arglist-slot
(coalesce arglist
))
2852 (write-wordindexed fn sb
!vm
:simple-fun-type-slot
(coalesce type
)))
2853 (write-wordindexed fn sb
!vm
::simple-fun-info-slot info
)
2856 (let ((i (get 'fop-fun-entry
'opcode
)))
2857 (fill **fop-funs
** #'cold-fop-fun-entry
:start i
:end
(+ i
4)))
2860 (define-cold-fop (fop-symbol-tls-fixup)
2861 (let* ((symbol (pop-stack))
2863 (code-object (pop-stack)))
2864 (do-cold-fixup code-object
2865 (read-word-arg (fasl-input-stream))
2866 (ensure-symbol-tls-index symbol
)
2867 kind
))) ; and re-push code-object
2869 (define-cold-fop (fop-foreign-fixup)
2870 (let* ((kind (pop-stack))
2871 (code-object (pop-stack))
2872 (len (read-byte-arg (fasl-input-stream)))
2873 (sym (make-string len
)))
2874 (read-string-as-bytes (fasl-input-stream) sym
)
2876 (let ((offset (read-word-arg (fasl-input-stream)))
2877 (value (dyncore-note-symbol sym nil
)))
2878 (do-cold-fixup code-object offset value kind
)) ; and re-push code-object
2879 #!-
(and) (format t
"Bad non-plt fixup: ~S~S~%" sym code-object
)
2881 (let ((offset (read-word-arg (fasl-input-stream)))
2882 (value (cold-foreign-symbol-address sym
)))
2883 (do-cold-fixup code-object offset value kind
)))) ; and re-push code-object
2886 (define-cold-fop (fop-foreign-dataref-fixup)
2887 (let* ((kind (pop-stack))
2888 (code-object (pop-stack))
2889 (len (read-byte-arg (fasl-input-stream)))
2890 (sym (make-string len
)))
2891 #!-sb-dynamic-core
(declare (ignore code-object
))
2892 (read-string-as-bytes (fasl-input-stream) sym
)
2894 (let ((offset (read-word-arg (fasl-input-stream)))
2895 (value (dyncore-note-symbol sym t
)))
2896 (do-cold-fixup code-object offset value kind
)) ; and re-push code-object
2899 (maphash (lambda (k v
)
2900 (format *error-output
* "~&~S = #X~8X~%" k v
))
2901 *cold-foreign-symbol-table
*)
2902 (error "shared foreign symbol in cold load: ~S (~S)" sym kind
))))
2904 (define-cold-fop (fop-assembler-code)
2905 (let* ((length (read-word-arg (fasl-input-stream)))
2907 ;; Note: we round the number of constants up to ensure that
2908 ;; the code vector will be properly aligned.
2909 (round-up sb
!vm
:code-constants-offset
2))
2910 (des (allocate-cold-descriptor *read-only
*
2911 (+ (ash header-n-words
2914 sb
!vm
:other-pointer-lowtag
)))
2915 (write-header-word des header-n-words sb
!vm
:code-header-widetag
)
2916 (write-wordindexed des
2917 sb
!vm
:code-code-size-slot
2918 (make-fixnum-descriptor length
))
2919 (write-wordindexed des sb
!vm
:code-debug-info-slot
*nil-descriptor
*)
2921 (let* ((start (+ (descriptor-byte-offset des
)
2922 (ash header-n-words sb
!vm
:word-shift
)))
2923 (end (+ start length
)))
2924 (read-bigvec-as-sequence-or-die (descriptor-mem des
)
2930 (define-cold-fop (fop-assembler-routine)
2931 (let* ((routine (pop-stack))
2933 (offset (calc-offset des
(read-word-arg (fasl-input-stream)))))
2934 (record-cold-assembler-routine
2936 (+ (logandc2 (descriptor-bits des
) sb
!vm
:lowtag-mask
) offset
))
2939 (define-cold-fop (fop-assembler-fixup)
2940 (let* ((routine (pop-stack))
2942 (code-object (pop-stack))
2943 (offset (read-word-arg (fasl-input-stream))))
2944 (push (list routine code-object offset kind
) *cold-assembler-fixups
*)
2947 (define-cold-fop (fop-code-object-fixup)
2948 (let* ((kind (pop-stack))
2949 (code-object (pop-stack))
2950 (offset (read-word-arg (fasl-input-stream)))
2951 (value (descriptor-bits code-object
)))
2952 (do-cold-fixup code-object offset value kind
))) ; and re-push code-object
2955 (define-cold-fop (fop-immobile-obj-fixup)
2956 (let ((obj (pop-stack))
2958 (code-object (pop-stack))
2959 (offset (read-word-arg (fasl-input-stream))))
2960 (do-cold-fixup code-object offset
2961 (descriptor-bits (if (symbolp obj
) (cold-intern obj
) obj
))
2962 kind
:immobile-object
)))
2965 (define-cold-fop (fop-named-call-fixup)
2966 (let ((fdefn (cold-fdefinition-object (pop-stack)))
2968 (code-object (pop-stack))
2969 (offset (read-word-arg (fasl-input-stream))))
2970 (do-cold-fixup code-object offset
2971 (+ (descriptor-bits fdefn
)
2972 (ash sb
!vm
:fdefn-raw-addr-slot sb
!vm
:word-shift
)
2973 (- sb
!vm
:other-pointer-lowtag
))
2977 (define-cold-fop (fop-static-call-fixup)
2978 (let ((name (pop-stack))
2980 (code-object (pop-stack))
2981 (offset (read-word-arg (fasl-input-stream))))
2982 (push (list name kind code-object offset
) *cold-static-call-fixups
*)
2986 ;;;; sanity checking space layouts
2988 (defun check-spaces ()
2989 ;;; Co-opt type machinery to check for intersections...
2991 (flet ((check (start end space
)
2992 (unless (< start end
)
2993 (error "Bogus space: ~A" space
))
2994 (let ((type (specifier-type `(integer ,start
,end
))))
2995 (dolist (other types
)
2996 (unless (eq *empty-type
* (type-intersection (cdr other
) type
))
2997 (error "Space overlap: ~A with ~A" space
(car other
))))
2998 (push (cons space type
) types
))))
2999 (check sb
!vm
:read-only-space-start sb
!vm
:read-only-space-end
:read-only
)
3000 (check sb
!vm
:static-space-start sb
!vm
:static-space-end
:static
)
3002 (check sb
!vm
:dynamic-space-start sb
!vm
:dynamic-space-end
:dynamic
)
3004 ;; Must be a multiple of 32 because it makes the math a nicer
3005 ;; when computing word and bit index into the 'touched' bitmap.
3006 (assert (zerop (rem sb
!vm
:immobile-fixedobj-subspace-size
3007 (* 32 sb
!vm
:immobile-card-bytes
))))
3010 (check sb
!vm
:dynamic-0-space-start sb
!vm
:dynamic-0-space-end
:dynamic-0
)
3011 (check sb
!vm
:dynamic-1-space-start sb
!vm
:dynamic-1-space-end
:dynamic-1
))
3013 (check sb
!vm
:linkage-table-space-start sb
!vm
:linkage-table-space-end
:linkage-table
))))
3015 ;;;; emitting C header file
3017 (defun tailwise-equal (string tail
)
3018 (and (>= (length string
) (length tail
))
3019 (string= string tail
:start1
(- (length string
) (length tail
)))))
3021 (defun write-boilerplate (*standard-output
*)
3024 '("This is a machine-generated file. Please do not edit it by hand."
3025 "(As of sbcl-0.8.14, it came from WRITE-CONFIG-H in genesis.lisp.)"
3027 "This file contains low-level information about the"
3028 "internals of a particular version and configuration"
3029 "of SBCL. It is used by the C compiler to create a runtime"
3030 "support environment, an executable program in the host"
3031 "operating system's native format, which can then be used to"
3032 "load and run 'core' files, which are basically programs"
3033 "in SBCL's own format."))
3034 (format t
" *~@[ ~A~]~%" line
))
3037 (defun c-name (string &optional strip
)
3039 (substitute-if #\_
(lambda (c) (member c
'(#\-
#\
/ #\%
)))
3040 (remove-if (lambda (c) (position c strip
))
3043 (defun c-symbol-name (symbol &optional strip
)
3044 (c-name (symbol-name symbol
) strip
))
3046 (defun write-makefile-features (*standard-output
*)
3047 ;; propagating *SHEBANG-FEATURES* into the Makefiles
3048 (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name
3049 sb-cold
:*shebang-features
*)
3051 (format t
"LISP_FEATURE_~A=1~%" shebang-feature-name
)))
3053 (defun write-config-h (*standard-output
*)
3054 ;; propagating *SHEBANG-FEATURES* into C-level #define's
3055 (dolist (shebang-feature-name (sort (mapcar #'c-symbol-name
3056 sb-cold
:*shebang-features
*)
3058 (format t
"#define LISP_FEATURE_~A~%" shebang-feature-name
))
3060 ;; and miscellaneous constants
3061 (format t
"#define SBCL_VERSION_STRING ~S~%"
3062 (sb!xc
:lisp-implementation-version
))
3063 (format t
"#define CORE_MAGIC 0x~X~%" core-magic
)
3064 (format t
"#ifndef LANGUAGE_ASSEMBLY~2%")
3065 (format t
"#define LISPOBJ(x) ((lispobj)x)~2%")
3066 (format t
"#else /* LANGUAGE_ASSEMBLY */~2%")
3067 (format t
"#define LISPOBJ(thing) thing~2%")
3068 (format t
"#endif /* LANGUAGE_ASSEMBLY */~2%")
3071 (defun write-constants-h (*standard-output
*)
3072 ;; writing entire families of named constants
3073 (let ((constants nil
))
3074 (dolist (package-name '("SB!VM"
3075 ;; We also propagate magic numbers
3076 ;; related to file format,
3077 ;; which live here instead of SB!VM.
3079 (do-external-symbols (symbol (find-package package-name
))
3080 (when (constantp symbol
)
3081 (let ((name (symbol-name symbol
)))
3082 (labels ( ;; shared machinery
3083 (record (string priority suffix
)
3086 (symbol-value symbol
)
3088 (documentation symbol
'variable
))
3090 ;; machinery for old-style CMU CL Lisp-to-C
3091 ;; arbitrary renaming, being phased out in favor of
3092 ;; the newer systematic RECORD-WITH-TRANSLATED-NAME
3094 (record-with-munged-name (prefix string priority
)
3095 (record (concatenate
3098 (delete #\-
(string-capitalize string
)))
3101 (maybe-record-with-munged-name (tail prefix priority
)
3102 (when (tailwise-equal name tail
)
3103 (record-with-munged-name prefix
3108 ;; machinery for new-style SBCL Lisp-to-C naming
3109 (record-with-translated-name (priority large
)
3110 (record (c-name name
) priority
3112 #!+(and win32 x86-64
) "LLU"
3113 #!-
(and win32 x86-64
) "LU"
3115 (maybe-record-with-translated-name (suffixes priority
&key large
)
3116 (when (some (lambda (suffix)
3117 (tailwise-equal name suffix
))
3119 (record-with-translated-name priority large
))))
3120 (maybe-record-with-translated-name '("-LOWTAG") 0)
3121 (maybe-record-with-translated-name '("-WIDETAG" "-SHIFT") 1)
3122 (maybe-record-with-munged-name "-FLAG" "flag_" 2)
3123 (maybe-record-with-munged-name "-TRAP" "trap_" 3)
3124 (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
3125 (maybe-record-with-translated-name '("SHAREABLE+" "SHAREABLE-NONSTD+") 4)
3126 (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
3127 (maybe-record-with-translated-name '("-SIZE" "-INTERRUPTS") 6)
3128 (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES"
3129 "-CARD-BYTES" "-GRANULARITY")
3131 (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8)
3132 (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9)
3133 (maybe-record-with-translated-name '("-CORE-SPACE-ID-FLAG") 9)
3134 (maybe-record-with-translated-name '("-GENERATION+") 10))))))
3135 ;; KLUDGE: these constants are sort of important, but there's no
3136 ;; pleasing way to inform the code above about them. So we fake
3137 ;; it for now. nikodemus on #lisp (2004-08-09) suggested simply
3138 ;; exporting every numeric constant from SB!VM; that would work,
3139 ;; but the C runtime would have to be altered to use Lisp-like names
3140 ;; rather than the munged names currently exported. --njf, 2004-08-09
3141 (dolist (c '(sb!vm
:n-word-bits sb
!vm
:n-word-bytes
3142 sb
!vm
:n-lowtag-bits sb
!vm
:lowtag-mask
3143 sb
!vm
:n-widetag-bits sb
!vm
:widetag-mask
3144 sb
!vm
:n-fixnum-tag-bits sb
!vm
:fixnum-tag-mask
3145 sb
!vm
:short-header-max-words
))
3146 (push (list (c-symbol-name c
)
3147 -
1 ; invent a new priority
3152 ;; One more symbol that doesn't fit into the code above.
3153 (let ((c 'sb
!impl
::+magic-hash-vector-value
+))
3154 (push (list (c-symbol-name c
)
3157 #!+(and win32 x86-64
) "LLU"
3158 #!-
(and win32 x86-64
) "LU"
3161 ;; And still one more
3163 (let ((c 'sb
!vm
::immediate-widetags-mask
))
3164 (push (list (c-symbol-name c
)
3166 (logior (ash 1 (ash sb
!vm
:character-widetag -
2))
3167 (ash 1 (ash sb
!vm
:single-float-widetag -
2))
3168 (ash 1 (ash sb
!vm
:unbound-marker-widetag -
2)))
3174 (lambda (const1 const2
)
3175 (if (= (second const1
) (second const2
))
3176 (if (= (third const1
) (third const2
))
3177 (string< (first const1
) (first const2
))
3178 (< (third const1
) (third const2
)))
3179 (< (second const1
) (second const2
))))))
3180 (let ((prev-priority (second (car constants
))))
3181 (dolist (const constants
)
3182 (destructuring-bind (name priority value suffix doc
) const
3183 (unless (= prev-priority priority
)
3185 (setf prev-priority priority
))
3186 (when (minusp value
)
3187 (error "stub: negative values unsupported"))
3188 (format t
"#define ~A ~A~A /* 0x~X ~@[ -- ~A ~]*/~%" name value suffix value doc
))))
3191 ;; writing information about internal errors
3192 ;; Assembly code needs only the constants for UNDEFINED_[ALIEN_]FUN_ERROR
3193 ;; but to avoid imparting that knowledge here, we'll expose all error
3194 ;; number constants except for OBJECT-NOT-<x>-ERROR ones.
3195 (loop for
(description name
) across sb
!c
:+backend-internal-errors
+
3197 when
(stringp description
)
3198 do
(format t
"#define ~A ~D~%" (c-symbol-name name
) i
))
3200 ;; I'm not really sure why this is in SB!C, since it seems
3201 ;; conceptually like something that belongs to SB!VM. In any case,
3202 ;; it's needed C-side.
3203 (format t
"#define BACKEND_PAGE_BYTES ~DLU~%" sb
!c
:*backend-page-bytes
*)
3207 ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between
3208 ;; platforms. If we export this from the SB!VM package, it gets
3209 ;; written out as #define trap_PseudoAtomic, which is confusing as
3210 ;; the runtime treats trap_ as the prefix for illegal instruction
3211 ;; type things. We therefore don't export it, but instead do
3213 (when (boundp 'sb
!vm
::pseudo-atomic-trap
)
3215 "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%"
3216 sb
!vm
::pseudo-atomic-trap
)
3218 ;; possibly this is another candidate for a rename (to
3219 ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
3220 ;; [possibly applicable to other platforms])
3223 (format t
"#define GC_SAFEPOINT_PAGE_ADDR ((void*)0x~XUL) /* ~:*~A */~%"
3224 sb
!vm
:gc-safepoint-page-addr
)
3226 (dolist (symbol '(sb!vm
::float-traps-byte
3227 sb
!vm
::float-exceptions-byte
3228 sb
!vm
::float-sticky-bits
3229 sb
!vm
::float-rounding-mode
))
3230 (format t
"#define ~A_POSITION ~A /* ~:*0x~X */~%"
3231 (c-symbol-name symbol
)
3232 (sb!xc
:byte-position
(symbol-value symbol
)))
3233 (format t
"#define ~A_MASK 0x~X /* ~:*~A */~%"
3234 (c-symbol-name symbol
)
3235 (sb!xc
:mask-field
(symbol-value symbol
) -
1))))
3237 (defun write-errnames-h (stream)
3238 ;; C code needs strings for describe_internal_error()
3239 (format stream
"#define INTERNAL_ERROR_NAMES ~{\\~%~S~^, ~}~2%"
3240 (map 'list
'sb
!kernel
::!c-stringify-internal-error
3241 sb
!c
:+backend-internal-errors
+))
3242 (format stream
"#define INTERNAL_ERROR_NARGS {~{~S~^, ~}}~2%"
3243 (map 'list
#'cddr sb
!c
:+backend-internal-errors
+)))
3246 (defun write-tagnames-h (out)
3248 ((pretty-name (symbol strip
)
3249 (let ((name (string-downcase symbol
)))
3250 (substitute #\Space
#\-
3251 (subseq name
0 (- (length name
) (length strip
))))))
3252 (list-sorted-tags (tail)
3253 (loop for symbol being the external-symbols of
"SB!VM"
3254 when
(and (constantp symbol
)
3255 (tailwise-equal (string symbol
) tail
)
3256 ;; FIXME: these symbols are obsolete
3258 '(sb!vm
:simple-fun-header-widetag
3259 sb
!vm
:closure-header-widetag
))))
3260 collect symbol into tags
3261 finally
(return (sort tags
#'< :key
#'symbol-value
))))
3262 (write-tags (visibility kind limit ash-count
)
3263 (format out
"~%~Aconst char *~(~A~)_names[] = {~%"
3264 visibility
(subseq kind
1))
3265 (let ((tags (list-sorted-tags kind
)))
3267 (if (eql i
(ash (or (symbol-value (first tags
)) -
1) ash-count
))
3268 (format out
" \"~A\"" (pretty-name (pop tags
) kind
))
3269 (format out
" \"unknown [~D]\"" i
))
3270 (unless (eql i
(1- limit
))
3271 (write-string "," out
))
3273 (write-line "};" out
)))
3274 (write-tags "static " "-LOWTAG" sb
!vm
:lowtag-limit
0)
3275 ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG
3276 ;; ending with the same 2 bits. (#b10)
3277 (write-tags "" "-WIDETAG" (ash (1+ sb
!vm
:widetag-mask
) -
2) -
2))
3278 ;; Inform print_otherptr() of all array types that it's too dumb to print
3279 (let ((array-type-bits (make-array 32 :initial-element
0)))
3281 (multiple-value-bind (ofs bit
) (floor b
8)
3282 (setf (aref array-type-bits ofs
) (ash 1 bit
)))))
3283 (dovector (saetp sb
!vm
:*specialized-array-element-type-properties
*)
3284 (unless (or (typep (sb!vm
:saetp-ctype saetp
) 'character-set-type
)
3285 (eq (sb!vm
:saetp-specifier saetp
) t
))
3286 (toggle (sb!vm
:saetp-typecode saetp
))
3287 (awhen (sb!vm
:saetp-complex-typecode saetp
) (toggle it
)))))
3289 "~%static unsigned char unprintable_array_types[32] =~% {~{~d~^,~}};~%"
3290 (coerce array-type-bits
'list
)))
3291 (dolist (prim-obj '(symbol ratio complex sb
!vm
::code simple-fun
3292 closure funcallable-instance
3293 weak-pointer fdefn sb
!vm
::value-cell
))
3294 (format out
"static char *~A_slots[] = {~%~{ \"~A: \",~} NULL~%};~%"
3295 (c-name (string-downcase prim-obj
))
3296 (mapcar (lambda (x) (c-name (string-downcase (sb!vm
:slot-name x
))))
3297 (remove-if 'sb
!vm
:slot-rest-p
3298 (sb!vm
::primitive-object-slots
3299 (find prim-obj sb
!vm
:*primitive-objects
*
3300 :key
'sb
!vm
:primitive-object-name
))))))
3303 (defun write-primitive-object (obj *standard-output
*)
3304 ;; writing primitive object layouts
3305 (format t
"#ifndef LANGUAGE_ASSEMBLY~2%")
3306 (format t
"struct ~A {~%" (c-name (string-downcase (sb!vm
:primitive-object-name obj
))))
3307 (when (sb!vm
:primitive-object-widetag obj
)
3308 (format t
" lispobj header;~%"))
3309 (dolist (slot (sb!vm
:primitive-object-slots obj
))
3310 (format t
" ~A ~A~@[[1]~];~%"
3311 (getf (sb!vm
:slot-options slot
) :c-type
"lispobj")
3312 (c-name (string-downcase (sb!vm
:slot-name slot
)))
3313 (sb!vm
:slot-rest-p slot
)))
3315 (format t
"#else /* LANGUAGE_ASSEMBLY */~2%")
3316 (format t
"/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%")
3317 (format t
" * so they work directly on tagged addresses. */~2%")
3318 (let ((name (sb!vm
:primitive-object-name obj
))
3319 (lowtag (or (symbol-value (sb!vm
:primitive-object-lowtag obj
))
3321 (dolist (slot (sb!vm
:primitive-object-slots obj
))
3322 (format t
"#define ~A_~A_OFFSET ~D~%"
3323 (c-symbol-name name
)
3324 (c-symbol-name (sb!vm
:slot-name slot
))
3325 (- (* (sb!vm
:slot-offset slot
) sb
!vm
:n-word-bytes
) lowtag
)))
3327 (format t
"#endif /* LANGUAGE_ASSEMBLY */~2%"))
3329 (defun write-structure-object (dd *standard-output
*)
3330 (flet ((cstring (designator) (c-name (string-downcase designator
))))
3331 (format t
"#ifndef LANGUAGE_ASSEMBLY~2%")
3332 (format t
"struct ~A {~%" (cstring (dd-name dd
)))
3333 (format t
" lispobj header; // = word_0_~%")
3334 ;; "self layout" slots are named '_layout' instead of 'layout' so that
3335 ;; classoid's expressly declared layout isn't renamed as a special-case.
3336 #!-compact-instance-header
(format t
" lispobj _layout;~%")
3337 ;; Output exactly the number of Lisp words consumed by the structure,
3338 ;; no more, no less. C code can always compute the padded length from
3339 ;; the precise length, but the other way doesn't work.
3341 (coerce (loop for i from sb
!vm
:instance-data-start below
(dd-length dd
)
3342 collect
(list (format nil
"word_~D_" (1+ i
))))
3344 (dolist (slot (dd-slots dd
))
3345 (let ((cell (aref names
(- (dsd-index slot
) sb
!vm
:instance-data-start
)))
3346 (name (cstring (dsd-name slot
))))
3347 (if (eq (dsd-raw-type slot
) t
)
3349 (rplacd cell name
))))
3350 (loop for slot across names
3351 do
(format t
" lispobj ~A;~@[ // ~A~]~%" (car slot
) (cdr slot
))))
3353 (format t
"#endif /* LANGUAGE_ASSEMBLY */~2%")))
3355 (defun write-static-symbols (stream)
3356 (dolist (symbol (cons nil sb
!vm
:+static-symbols
+))
3357 ;; FIXME: It would be nice to use longer names than NIL and
3358 ;; (particularly) T in #define statements.
3359 (format stream
"#define ~A LISPOBJ(0x~X)~%"
3360 ;; FIXME: It would be nice not to need to strip anything
3361 ;; that doesn't get stripped always by C-SYMBOL-NAME.
3362 (c-symbol-name symbol
"%*.!")
3363 (if *static
* ; if we ran GENESIS
3364 ;; We actually ran GENESIS, use the real value.
3365 (descriptor-bits (cold-intern symbol
))
3366 ;; We didn't run GENESIS, so guess at the address.
3367 (+ sb
!vm
:static-space-start
3369 sb
!vm
:other-pointer-lowtag
3370 (if symbol
(sb!vm
:static-symbol-offset symbol
) 0))))))
3372 (defun write-sc-offset-coding (stream)
3373 (flet ((write-array (name bytes
)
3374 (format stream
"static struct sc_offset_byte ~A[] = {~@
3375 ~{ {~{ ~2D, ~2D ~}}~^,~%~}~@
3378 (mapcar (lambda (byte)
3379 (list (byte-size byte
) (byte-position byte
)))
3381 (format stream
"struct sc_offset_byte {
3385 (write-array "sc_offset_sc_number_bytes" sb
!c
::+sc-offset-scn-bytes
+)
3386 (write-array "sc_offset_offset_bytes" sb
!c
::+sc-offset-offset-bytes
+)))
3388 ;;;; writing map file
3390 ;;; Write a map file describing the cold load. Some of this
3391 ;;; information is subject to change due to relocating GC, but even so
3392 ;;; it can be very handy when attempting to troubleshoot the early
3393 ;;; stages of cold load.
3394 (defun write-map (*standard-output
*)
3395 (let ((*print-pretty
* nil
)
3396 (*print-case
* :upcase
))
3397 (format t
"assembler routines defined in core image:~2%")
3398 (dolist (routine (sort (copy-list *cold-assembler-routines
*) #'<
3400 (format t
"~8,'0X: ~S~%" (cdr routine
) (car routine
)))
3404 (maphash (lambda (name fdefn
&aux
(fun (cold-fdefn-fun fdefn
)))
3405 (push (list (- (descriptor-bits fdefn
) (descriptor-lowtag fdefn
))
3409 (push (list (- (descriptor-bits fun
) (descriptor-lowtag fun
))
3411 *cold-fdefn-objects
*)
3412 (format t
"~%~|~%fdefns (native pointer):
3413 ~:{~%~8,'0X: ~S~}~%" (sort fdefns
#'< :key
#'car
))
3414 (format t
"~%~|~%initially defined functions (native pointer):
3415 ~:{~%~8,'0X: ~S~}~%" (sort funs
#'< :key
#'car
))
3418 (a note about initially undefined function references: These functions
3419 are referred to by code which is installed by GENESIS, but they are not
3420 installed by GENESIS. This is not necessarily a problem; functions can
3421 be defined later, by cold init toplevel forms, or in files compiled and
3422 loaded at warm init, or elsewhere. As long as they are defined before
3423 they are called, everything should be OK. Things are also OK if the
3424 cross-compiler knew their inline definition and used that everywhere
3425 that they were called before the out-of-line definition is installed,
3426 as is fairly common for structure accessors.)
3427 initially undefined function references:~2%")
3429 (setf undefs
(sort undefs
#'string
< :key
#'fun-name-block-name
))
3430 (dolist (name undefs
)
3431 (format t
"~8,'0X: ~S~%"
3432 (descriptor-bits (gethash name
*cold-fdefn-objects
*))
3435 (format t
"~%~|~%layout names:~2%")
3436 (dolist (x (sort-cold-layouts))
3437 (let* ((des (cdr x
))
3438 (inherits (read-slot des
*host-layout-of-layout
* :inherits
)))
3439 (format t
"~8,'0X: ~S[~D]~%~10T~:S~%" (descriptor-bits des
) (car x
)
3440 (cold-layout-length des
) (listify-cold-inherits inherits
))))
3442 (format t
"~%~|~%parsed type specifiers:~2%")
3443 (mapc (lambda (cell)
3444 (format t
"~X: ~S~%" (descriptor-bits (cdr cell
)) (car cell
)))
3445 (sort (%hash-table-alist
*ctype-cache
*) #'<
3446 :key
(lambda (x) (descriptor-bits (cdr x
))))))
3449 ;;;; writing core file
3451 (defvar *core-file
*)
3452 (defvar *data-page
*)
3454 ;;; magic numbers to identify entries in a core file
3456 ;;; (In case you were wondering: No, AFAIK there's no special magic about
3457 ;;; these which requires them to be in the 38xx range. They're just
3458 ;;; arbitrary words, tested not for being in a particular range but just
3459 ;;; for equality. However, if you ever need to look at a .core file and
3460 ;;; figure out what's going on, it's slightly convenient that they're
3461 ;;; all in an easily recognizable range, and displacing the range away from
3462 ;;; zero seems likely to reduce the chance that random garbage will be
3463 ;;; misinterpreted as a .core file.)
3464 (defconstant build-id-core-entry-type-code
3860)
3465 (defconstant new-directory-core-entry-type-code
3861)
3466 (defconstant initial-fun-core-entry-type-code
3863)
3467 (defconstant page-table-core-entry-type-code
3880)
3468 (defconstant end-core-entry-type-code
3840)
3470 (declaim (ftype (function (sb!vm
:word
) sb
!vm
:word
) write-word
))
3471 (defun write-word (num)
3472 (ecase sb
!c
:*backend-byte-order
*
3474 (dotimes (i sb
!vm
:n-word-bytes
)
3475 (write-byte (ldb (byte 8 (* i
8)) num
) *core-file
*)))
3477 (dotimes (i sb
!vm
:n-word-bytes
)
3478 (write-byte (ldb (byte 8 (* (- (1- sb
!vm
:n-word-bytes
) i
) 8)) num
)
3482 (defun output-gspace (gspace)
3483 (force-output *core-file
*)
3484 (let* ((posn (file-position *core-file
*))
3485 (bytes (* (gspace-free-word-index gspace
) sb
!vm
:n-word-bytes
))
3486 (pages (ceiling bytes sb
!c
:*backend-page-bytes
*))
3487 (total-bytes (* pages sb
!c
:*backend-page-bytes
*)))
3489 (file-position *core-file
*
3490 (* sb
!c
:*backend-page-bytes
* (1+ *data-page
*)))
3492 "writing ~S byte~:P [~S page~:P] from ~S~%"
3498 ;; Note: It is assumed that the GSPACE allocation routines always
3499 ;; allocate whole pages (of size *target-page-size*) and that any
3500 ;; empty gspace between the free pointer and the end of page will
3501 ;; be zero-filled. This will always be true under Mach on machines
3502 ;; where the page size is equal. (RT is 4K, PMAX is 4K, Sun 3 is
3504 (write-bigvec-as-sequence (gspace-data gspace
)
3508 (force-output *core-file
*)
3509 (file-position *core-file
* posn
)
3511 ;; Write part of a (new) directory entry which looks like this:
3512 ;; GSPACE IDENTIFIER
3517 (write-word (gspace-identifier gspace
))
3518 (write-word (gspace-free-word-index gspace
))
3519 (write-word *data-page
*)
3520 (multiple-value-bind (floor rem
)
3521 (floor (gspace-byte-address gspace
) sb
!c
:*backend-page-bytes
*)
3526 (incf *data-page
* pages
)))
3528 ;;; Create a core file created from the cold loaded image. (This is
3529 ;;; the "initial core file" because core files could be created later
3530 ;;; by executing SAVE-LISP in a running system, perhaps after we've
3531 ;;; added some functionality to the system.)
3532 (declaim (ftype (function (string)) write-initial-core-file
))
3533 (defun write-initial-core-file (filename)
3535 (let ((filenamestring (namestring filename
))
3538 (format t
"[building initial core file in ~S: ~%" filenamestring
)
3541 (with-open-file (*core-file
* filenamestring
3543 :element-type
'(unsigned-byte 8)
3544 :if-exists
:rename-and-delete
)
3546 ;; Write the magic number.
3547 (write-word core-magic
)
3549 ;; Write the build ID.
3550 (write-word build-id-core-entry-type-code
)
3551 (let ((build-id (with-open-file (s "output/build-id.tmp")
3553 (declare (type simple-string build-id
))
3554 (/show build-id
(length build-id
))
3555 ;; Write length of build ID record: BUILD-ID-CORE-ENTRY-TYPE-CODE
3556 ;; word, this length word, and one word for each char of BUILD-ID.
3557 (write-word (+ 2 (length build-id
)))
3558 (dovector (char build-id
)
3559 ;; (We write each character as a word in order to avoid
3560 ;; having to think about word alignment issues in the
3561 ;; sbcl-0.7.8 version of coreparse.c.)
3562 (write-word (sb!xc
:char-code char
))))
3564 ;; Write the New Directory entry header.
3565 (write-word new-directory-core-entry-type-code
)
3566 (let ((spaces (nconc (list *read-only
* *static
*)
3568 (list *immobile-fixedobj
* *immobile-varyobj
*)
3570 ;; length = (5 words/space) * N spaces + 2 for header.
3571 (write-word (+ (* (length spaces
) 5) 2))
3572 (mapc #'output-gspace spaces
))
3574 ;; Write the initial function.
3575 (write-word initial-fun-core-entry-type-code
)
3577 (let* ((cold-name (cold-intern '!cold-init
))
3579 (cold-fdefn-fun (cold-fdefinition-object cold-name
))))
3581 "~&/(DESCRIPTOR-BITS INITIAL-FUN)=#X~X~%"
3582 (descriptor-bits initial-fun
))
3583 (write-word (descriptor-bits initial-fun
)))
3585 ;; Write the End entry.
3586 (write-word end-core-entry-type-code
)
3589 (format t
"done]~%")
3591 (/show
"leaving WRITE-INITIAL-CORE-FILE")
3594 ;;;; the actual GENESIS function
3596 ;;; Read the FASL files in OBJECT-FILE-NAMES and produce a Lisp core,
3597 ;;; and/or information about a Lisp core, therefrom.
3599 ;;; input file arguments:
3600 ;;; SYMBOL-TABLE-FILE-NAME names a UNIX-style .nm file *with* *any*
3601 ;;; *tab* *characters* *converted* *to* *spaces*. (We push
3602 ;;; responsibility for removing tabs out to the caller it's
3603 ;;; trivial to remove them using UNIX command line tools like
3604 ;;; sed, whereas it's a headache to do it portably in Lisp because
3605 ;;; #\TAB is not a STANDARD-CHAR.) If this file is not supplied,
3606 ;;; a core file cannot be built (but a C header file can be).
3608 ;;; output files arguments (any of which may be NIL to suppress output):
3609 ;;; CORE-FILE-NAME gets a Lisp core.
3610 ;;; C-HEADER-DIR-NAME gets the path in which to place generated headers
3611 ;;; MAP-FILE-NAME gets the name of the textual 'cold-sbcl.map' file
3612 (defun sb-cold:genesis
(&key object-file-names preload-file
3613 core-file-name c-header-dir-name map-file-name
3614 symbol-table-file-name
)
3615 (declare (ignorable symbol-table-file-name
))
3616 (declare (special core-file-name
))
3619 "~&beginning GENESIS, ~A~%"
3621 ;; Note: This output summarizing what we're doing is
3622 ;; somewhat telegraphic in style, not meant to imply that
3623 ;; we're not e.g. also creating a header file when we
3625 (format nil
"creating core ~S" core-file-name
)
3626 (format nil
"creating headers in ~S" c-header-dir-name
)))
3628 (let ((*cold-foreign-symbol-table
* (make-hash-table :test
'equal
)))
3630 #!-
(or sb-dynamic-core crossbuild-test
)
3631 (when core-file-name
3632 (if symbol-table-file-name
3633 (load-cold-foreign-symbol-table symbol-table-file-name
)
3634 (error "can't output a core file without symbol table file input")))
3636 ;; Now that we've successfully read our only input file (by
3637 ;; loading the symbol table, if any), it's a good time to ensure
3638 ;; that there'll be someplace for our output files to go when
3640 (flet ((frob (filename)
3642 (ensure-directories-exist filename
:verbose t
))))
3643 (frob core-file-name
)
3644 (frob map-file-name
))
3646 ;; (This shouldn't matter in normal use, since GENESIS normally
3647 ;; only runs once in any given Lisp image, but it could reduce
3648 ;; confusion if we ever experiment with running, tweaking, and
3649 ;; rerunning genesis interactively.)
3650 (do-all-symbols (sym)
3651 (remprop sym
'cold-intern-info
))
3655 (let* ((*foreign-symbol-placeholder-value
* (if core-file-name nil
0))
3656 (*load-time-value-counter
* 0)
3657 (*cold-fdefn-objects
* (make-hash-table :test
'equal
))
3658 (*cold-symbols
* (make-hash-table :test
'eql
)) ; integer keys
3659 (*cold-package-symbols
* (make-hash-table :test
'equal
)) ; string keys
3660 (*read-only
* (make-gspace :read-only
3661 read-only-core-space-id
3662 sb
!vm
:read-only-space-start
))
3663 (*static
* (make-gspace :static
3664 static-core-space-id
3665 sb
!vm
:static-space-start
))
3667 (*immobile-fixedobj
* (make-gspace :immobile-fixedobj
3668 immobile-fixedobj-core-space-id
3669 sb
!vm
:immobile-space-start
))
3671 (*immobile-varyobj
* (make-gspace :immobile-varyobj
3672 immobile-varyobj-core-space-id
3673 (+ sb
!vm
:immobile-space-start
3674 sb
!vm
:immobile-fixedobj-subspace-size
)))
3675 (*dynamic
* (make-gspace :dynamic
3676 dynamic-core-space-id
3677 #!+gencgc sb
!vm
:dynamic-space-start
3678 #!-gencgc sb
!vm
:dynamic-0-space-start
))
3679 (*nil-descriptor
* (make-nil-descriptor))
3680 (*simple-vector-0-descriptor
* (vector-in-core nil
))
3681 (*known-structure-classoids
* nil
)
3682 (*classoid-cells
* (make-hash-table :test
'eq
))
3683 (*ctype-cache
* (make-hash-table :test
'equal
))
3684 (*cold-layouts
* (make-hash-table :test
'eq
)) ; symbol -> cold-layout
3685 (*cold-layout-names
* (make-hash-table :test
'eql
)) ; addr -> symbol
3686 (*!cold-defconstants
* nil
)
3687 (*!cold-defuns
* nil
)
3688 ;; '*COLD-METHODS* is never seen in the target, so does not need
3689 ;; to adhere to the #\! convention for automatic uninterning.
3690 (*cold-methods
* nil
)
3691 (*!cold-toplevels
* nil
)
3692 (*current-debug-sources
* *nil-descriptor
*)
3693 *cold-static-call-fixups
*
3694 *cold-assembler-fixups
*
3695 *cold-assembler-routines
*
3696 (*code-fixup-notes
* (make-hash-table))
3697 (*deferred-known-fun-refs
* nil
))
3699 ;; If we're given a preload file, it contains tramps and whatnot
3700 ;; that must be loaded before we create any FDEFNs. It can in
3701 ;; theory be loaded any time between binding
3702 ;; *COLD-ASSEMBLER-ROUTINES* above and calling
3703 ;; INITIALIZE-STATIC-FNS below.
3705 (cold-load preload-file
))
3707 ;; Prepare for cold load.
3708 (initialize-layouts)
3709 (initialize-packages)
3710 (initialize-static-symbols)
3711 (initialize-static-fns)
3713 ;; Initialize the *COLD-SYMBOLS* system with the information
3714 ;; from common-lisp-exports.lisp-expr.
3715 ;; Packages whose names match SB!THING were set up on the host according
3716 ;; to "package-data-list.lisp-expr" which expresses the desired target
3717 ;; package configuration, so we can just mirror the host into the target.
3718 ;; But by waiting to observe calls to COLD-INTERN that occur during the
3719 ;; loading of the cross-compiler's outputs, it is possible to rid the
3720 ;; target of accidental leftover symbols, not that it wouldn't also be
3721 ;; a good idea to clean up package-data-list once in a while.
3722 (dolist (exported-name
3723 (sb-cold:read-from-file
"common-lisp-exports.lisp-expr"))
3724 (cold-intern (intern exported-name
*cl-package
*) :access
:external
))
3726 ;; Create SB!KERNEL::*TYPE-CLASSES* as an array of NIL
3727 (cold-set (cold-intern 'sb
!kernel
::*type-classes
*)
3728 (vector-in-core (make-list (length sb
!kernel
::*type-classes
*))))
3731 (dolist (file-name object-file-names
)
3732 (cold-load file-name
))
3734 (when *known-structure-classoids
*
3735 (let ((dd-layout (find-layout 'defstruct-description
)))
3736 (dolist (defstruct-args *known-structure-classoids
*)
3737 (let* ((dd (first defstruct-args
))
3738 (name (warm-symbol (read-slot dd dd-layout
:name
)))
3739 (layout (gethash name
*cold-layouts
*)))
3741 (write-slots layout
*host-layout-of-layout
* :info dd
))))
3742 (format t
"~&; SB!Loader: (~D~@{+~D~}) structs/consts/funs/methods/other~%"
3743 (length *known-structure-classoids
*)
3744 (length *!cold-defconstants
*)
3745 (length *!cold-defuns
*)
3746 (reduce #'+ *cold-methods
* :key
(lambda (x) (length (cdr x
))))
3747 (length *!cold-toplevels
*)))
3749 (dolist (symbol '(*!cold-defconstants
* *!cold-defuns
* *!cold-toplevels
*))
3750 (cold-set symbol
(list-to-core (nreverse (symbol-value symbol
))))
3751 (makunbound symbol
)) ; so no further PUSHes can be done
3754 'sb
!pcl
::*!trivial-methods
*
3756 (loop for
(gf-name . methods
) in
*cold-methods
*
3759 (cold-intern gf-name
)
3761 (loop for
(class qual lambda-list fun source-loc
)
3762 ;; Methods must be sorted because we invoke
3763 ;; only the first applicable one.
3764 in
(stable-sort methods
#'> ; highest depthoid first
3765 :key
(lambda (method)
3766 (class-depthoid (car method
))))
3768 (cold-list (cold-intern
3769 (and (null qual
) (predicate-for-specializer class
)))
3773 lambda-list source-loc
)))))))
3775 ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
3776 (resolve-deferred-known-funs)
3777 (resolve-assembler-fixups)
3778 (foreign-symbols-to-core)
3779 #!+(or x86 immobile-space
)
3780 (dolist (pair (sort (%hash-table-alist
*code-fixup-notes
*) #'< :key
#'car
))
3781 (write-wordindexed (make-random-descriptor (car pair
))
3782 sb
!vm
::code-fixups-slot
3783 #!+x86
(ub32-vector-in-core (cdr pair
))
3784 #!+x86-64
(number-to-core
3785 (sb!c
::pack-code-fixup-locs
(cdr pair
)))))
3787 (/show
"back from FINISH-SYMBOLS")
3788 (finalize-load-time-value-noise)
3790 ;; Tell the target Lisp how much stuff we've allocated.
3791 ;; ALLOCATE-COLD-DESCRIPTOR is a weird trick to locate a space's end,
3792 ;; and it doesn't work on immobile space.
3793 (cold-set 'sb
!vm
:*read-only-space-free-pointer
*
3794 (allocate-cold-descriptor *read-only
*
3796 sb
!vm
:even-fixnum-lowtag
))
3797 (cold-set 'sb
!vm
:*static-space-free-pointer
*
3798 (allocate-cold-descriptor *static
*
3800 sb
!vm
:even-fixnum-lowtag
))
3803 (cold-set 'sb
!vm
:*immobile-fixedobj-free-pointer
*
3804 (make-random-descriptor
3805 (ash (+ (gspace-word-address *immobile-fixedobj
*)
3806 (gspace-free-word-index *immobile-fixedobj
*))
3808 ;; The upper bound of the varyobj subspace is delimited by
3809 ;; a structure with no layout and no slots.
3810 ;; This is necessary because 'coreparse' does not have the actual
3811 ;; value of the free pointer, but the space must not contain any
3812 ;; objects that look like conses (due to the tail of 0 words).
3813 (let ((des (allocate-object *immobile-varyobj
* 1 ; 1 word in total
3814 sb
!vm
:instance-pointer-lowtag nil
)))
3815 (write-wordindexed/raw des
0 sb
!vm
:instance-widetag
)
3816 (write-wordindexed/raw des sb
!vm
:instance-slots-offset
0))
3817 (cold-set 'sb
!vm
:*immobile-space-free-pointer
*
3818 (make-random-descriptor
3819 (ash (+ (gspace-word-address *immobile-varyobj
*)
3820 (gspace-free-word-index *immobile-varyobj
*))
3821 sb
!vm
:word-shift
))))
3823 (/show
"done setting free pointers")
3825 ;; Write results to files.
3827 (with-open-file (stream map-file-name
:direction
:output
:if-exists
:supersede
)
3828 (write-map stream
)))
3829 (let ((filename (format nil
"~A/Makefile.features" c-header-dir-name
)))
3830 (ensure-directories-exist filename
)
3831 (with-open-file (stream filename
:direction
:output
:if-exists
:supersede
)
3832 (write-makefile-features stream
)))
3834 ;; This ".inc" file explicitly does NOT get an inclusion guard.
3835 ;; It may not be the best approach, but it's a heck of a lot better
3836 ;; than what was done before.
3837 (with-open-file (stream (format nil
"~A/specialized-vectors.inc" c-header-dir-name
)
3838 :direction
:output
:if-exists
:supersede
)
3839 (write-boilerplate stream
)
3840 (dovector (x (sort (copy-seq sb
!vm
:*specialized-array-element-type-properties
*)
3841 #'< :key
#'sb
!vm
:saetp-typecode
))
3842 (let ((type (sb!vm
::saetp-primitive-type-name x
)))
3843 (unless (eq type
'simple-vector
)
3844 (format stream
" case ~A_WIDETAG:~%" (c-name (string type
)))))))
3846 (macrolet ((out-to (name &body body
) ; write boilerplate and inclusion guard
3847 `(with-open-file (stream (format nil
"~A/~A.h" c-header-dir-name
,name
)
3848 :direction
:output
:if-exists
:supersede
)
3849 (write-boilerplate stream
)
3851 "#ifndef SBCL_GENESIS_~A~%#define SBCL_GENESIS_~:*~A~%"
3852 (c-name (string-upcase ,name
)))
3854 (format stream
"#endif~%"))))
3855 (out-to "config" (write-config-h stream
))
3856 (out-to "constants" (write-constants-h stream
))
3857 (out-to "errnames" (write-errnames-h stream
))
3858 (out-to "gc-tables" (sb!vm
::write-gc-tables stream
))
3860 (out-to "tagnames" (write-tagnames-h stream
))
3861 (let ((structs (sort (copy-list sb
!vm
:*primitive-objects
*) #'string
<
3862 :key
#'sb
!vm
:primitive-object-name
)))
3863 (dolist (obj structs
)
3864 (out-to (string-downcase (sb!vm
:primitive-object-name obj
))
3865 (write-primitive-object obj stream
)))
3866 (out-to "primitive-objects"
3867 (dolist (obj structs
)
3868 (format stream
"~&#include \"~A.h\"~%"
3869 (string-downcase (sb!vm
:primitive-object-name obj
))))))
3870 (dolist (class '(classoid hash-table layout package
3871 sb
!c
::compiled-debug-info sb
!c
::compiled-debug-fun
))
3872 (out-to (string-downcase class
)
3873 (write-structure-object (layout-info (find-layout class
)) stream
)))
3874 (out-to "static-symbols" (write-static-symbols stream
))
3875 (out-to "sc-offset" (write-sc-offset-coding stream
)))
3877 (when core-file-name
3878 (write-initial-core-file core-file-name
)))))
3880 ;;; Invert the action of HOST-CONSTANT-TO-CORE. If STRICTP is given as NIL,
3881 ;;; then we can produce a host object even if it is not a faithful rendition.
3882 (defun host-object-from-core (descriptor &optional
(strictp t
))
3883 (named-let recurse
((x descriptor
))
3885 (return-from recurse nil
))
3886 (when (eq (descriptor-gspace x
) :load-time-value
)
3887 (error "Can't warm a deferred LTV placeholder"))
3888 (when (is-fixnum-lowtag (descriptor-lowtag x
))
3889 (return-from recurse
(descriptor-fixnum x
)))
3890 (ecase (descriptor-lowtag x
)
3891 (#.sb
!vm
:instance-pointer-lowtag
3892 (if strictp
(error "Can't invert INSTANCE type") "#<instance>"))
3893 (#.sb
!vm
:list-pointer-lowtag
3894 (cons (recurse (cold-car x
)) (recurse (cold-cdr x
))))
3895 (#.sb
!vm
:fun-pointer-lowtag
3897 (error "Can't map cold-fun -> warm-fun")
3898 (let ((name (read-wordindexed x sb
!vm
:simple-fun-name-slot
)))
3899 `(function ,(recurse name
)))))
3900 (#.sb
!vm
:other-pointer-lowtag
3901 (let ((widetag (logand (descriptor-bits (read-memory x
))
3902 sb
!vm
:widetag-mask
)))
3904 (#.sb
!vm
:symbol-widetag
3907 (or (gethash (descriptor-bits x
) *cold-symbols
*) ; first try
3909 (recurse (read-wordindexed x sb
!vm
:symbol-name-slot
))))))
3910 (#.sb
!vm
:simple-base-string-widetag
(base-string-from-core x
))
3911 (#.sb
!vm
:simple-vector-widetag
(vector-from-core x
#'recurse
))
3912 (#.sb
!vm
:bignum-widetag
(bignum-from-core x
))))))))