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