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