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