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