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