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