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