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