e88f9ba532c020848c3878fe490d674c04145714
[sbcl.git] / src / compiler / dump.lisp
1 ;;;; stuff that knows about dumping FASL files
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!C")
13
14 ;;; FIXME: Double colons are bad, and there are lots of them in this
15 ;;; file, because both dump logic in SB!C and load logic in SB!IMPL
16 ;;; need to know about fops. Perhaps all the load/dump logic should be
17 ;;; moved into a single package, perhaps called SB-LD.
18 \f
19 ;;;; fasl dumper state
20
21 ;;; The FASL-FILE structure represents everything we need to know
22 ;;; about dumping to a fasl file. We need to objectify the state,
23 ;;; since the fasdumper must be reentrant.
24 (defstruct (fasl-file
25             #-no-ansi-print-object
26             (:print-object (lambda (x s)
27                              (print-unreadable-object (x s :type t)
28                                (prin1 (namestring (fasl-file-stream x)) s)))))
29   ;; the stream we dump to
30   (stream (required-argument) :type stream)
31   ;; hashtables we use to keep track of dumped constants so that we
32   ;; can get them from the table rather than dumping them again. The
33   ;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is
34   ;; used for everything else. We use a separate EQ table to avoid
35   ;; performance patholigies with objects for which EQUAL degnerates
36   ;; to EQL. Everything entered in the EQUAL table is also entered in
37   ;; the EQ table.
38   (equal-table (make-hash-table :test 'equal) :type hash-table)
39   (eq-table (make-hash-table :test 'eq) :type hash-table)
40   ;; the table's current free pointer: the next offset to be used
41   (table-free 0 :type index)
42   ;; an alist (PACKAGE . OFFSET) of the table offsets for each package
43   ;; we have currently located.
44   (packages () :type list)
45   ;; a table mapping from the Entry-Info structures for dumped XEPs to
46   ;; the table offsets of the corresponding code pointers
47   (entry-table (make-hash-table :test 'eq) :type hash-table)
48   ;; a table holding back-patching info for forward references to XEPs.
49   ;; The key is the Entry-Info structure for the XEP, and the value is
50   ;; a list of conses (<code-handle> . <offset>), where <code-handle>
51   ;; is the offset in the table of the code object needing to be
52   ;; patched, and <offset> is the offset that must be patched.
53   (patch-table (make-hash-table :test 'eq) :type hash-table)
54   ;; a list of the table handles for all of the DEBUG-INFO structures
55   ;; dumped in this file. These structures must be back-patched with
56   ;; source location information when the compilation is complete.
57   (debug-info () :type list)
58   ;; This is used to keep track of objects that we are in the process
59   ;; of dumping so that circularities can be preserved. The key is the
60   ;; object that we have previously seen, and the value is the object
61   ;; that we reference in the table to find this previously seen
62   ;; object. (The value is never NIL.)
63   ;;
64   ;; Except with list objects, the key and the value are always the
65   ;; same. In a list, the key will be some tail of the value.
66   (circularity-table (make-hash-table :test 'eq) :type hash-table)
67   ;; a hash table of structures that are allowed to be dumped. If we
68   ;; try to dump a structure that isn't in this hash table, we lose.
69   (valid-structures (make-hash-table :test 'eq) :type hash-table))
70
71 ;;; This structure holds information about a circularity.
72 (defstruct circularity
73   ;; the kind of modification to make to create circularity
74   (type (required-argument) :type (member :rplaca :rplacd :svset :struct-set))
75   ;; the object containing circularity
76   object
77   ;; index in object for circularity
78   (index (required-argument) :type index)
79   ;; the object to be stored at INDEX in OBJECT. This is that the key
80   ;; that we were using when we discovered the circularity.
81   value
82   ;; the value that was associated with VALUE in the
83   ;; CIRCULARITY-TABLE. This is the object that we look up in the
84   ;; EQ-TABLE to locate VALUE.
85   enclosing-object)
86
87 ;;; a list of the CIRCULARITY structures for all of the circularities
88 ;;; detected in the current top-level call to DUMP-OBJECT. Setting
89 ;;; this lobotomizes circularity detection as well, since circular
90 ;;; dumping uses the table.
91 (defvar *circularities-detected*)
92
93 ;;; used to inhibit table access when dumping forms to be read by the
94 ;;; cold loader
95 (defvar *cold-load-dump* nil)
96
97 ;;; used to turn off the structure validation during dumping of source
98 ;;; info
99 (defvar *dump-only-valid-structures* t)
100 ;;;; utilities
101
102 ;;; Write the byte B to the specified fasl-file stream.
103 (defun dump-byte (b fasl-file)
104   (declare (type (unsigned-byte 8) b) (type fasl-file fasl-file))
105   (write-byte b (fasl-file-stream fasl-file)))
106
107 ;;; Dump a 4 byte unsigned integer.
108 (defun dump-unsigned-32 (num fasl-file)
109   (declare (type (unsigned-byte 32) num) (type fasl-file fasl-file))
110   (let ((stream (fasl-file-stream fasl-file)))
111     (dotimes (i 4)
112       (write-byte (ldb (byte 8 (* 8 i)) num) stream))))
113
114 ;;; Dump NUM to the fasl stream, represented by N bytes. This works
115 ;;; for either signed or unsigned integers. There's no range checking
116 ;;; -- if you don't specify enough bytes for the number to fit, this
117 ;;; function cheerfully outputs the low bytes.
118 (defun dump-integer-as-n-bytes  (num bytes file)
119   (declare (integer num) (type index bytes) (type fasl-file file))
120   (do ((n num (ash n -8))
121        (i bytes (1- i)))
122       ((= i 0))
123     (declare (type index i))
124     (dump-byte (logand n #xff) file))
125   (values))
126
127 ;;; Setting this variable to an (UNSIGNED-BYTE 32) value causes
128 ;;; DUMP-FOP to use it as a counter and emit a FOP-NOP4 with the
129 ;;; counter value before every ordinary fop. This can make it easier
130 ;;; to follow the progress of FASLOAD when
131 ;;; debugging/testing/experimenting.
132 #!+sb-show (defvar *fop-nop4-count* nil)
133 #!+sb-show (declaim (type (or (unsigned-byte 32) null) *fop-nop4-count*))
134
135 ;;; Dump the FOP code for the named FOP to the specified fasl-file.
136 ;;;
137 ;;; FIXME: This should be a function, with a compiler macro expansion
138 ;;; for the common constant-FS case. (Among other things, that'll stop
139 ;;; it from EVALing ,FILE multiple times.)
140 ;;;
141 ;;; FIXME: Compiler macros, frozen classes, inlining, and similar
142 ;;; optimizations should be conditional on #!+SB-FROZEN.
143 (defmacro dump-fop (fs file)
144   (let* ((fs (eval fs))
145          (val (get fs 'sb!impl::fop-code)))
146     (if val
147       `(progn
148          #!+sb-show
149          (when *fop-nop4-count*
150            (dump-byte ,(get 'sb!impl::fop-nop4 'sb!impl::fop-code) ,file)
151            (dump-unsigned-32 (mod (incf *fop-nop4-count*) (expt 2 32)) ,file))
152          (dump-byte ',val ,file))
153       (error "compiler bug: ~S is not a legal fasload operator." fs))))
154
155 ;;; Dump a FOP-Code along with an integer argument, choosing the FOP
156 ;;; based on whether the argument will fit in a single byte.
157 ;;;
158 ;;; FIXME: This, like DUMP-FOP, should be a function with a
159 ;;; compiler-macro expansion.
160 (defmacro dump-fop* (n byte-fop word-fop file)
161   (once-only ((n-n n)
162               (n-file file))
163     `(cond ((< ,n-n 256)
164             (dump-fop ',byte-fop ,n-file)
165             (dump-byte ,n-n ,n-file))
166            (t
167             (dump-fop ',word-fop ,n-file)
168             (dump-unsigned-32 ,n-n ,n-file)))))
169
170 ;;; Push the object at table offset Handle on the fasl stack.
171 (defun dump-push (handle file)
172   (declare (type index handle) (type fasl-file file))
173   (dump-fop* handle sb!impl::fop-byte-push sb!impl::fop-push file)
174   (values))
175
176 ;;; Pop the object currently on the fasl stack top into the table, and
177 ;;; return the table index, incrementing the free pointer.
178 (defun dump-pop (file)
179   (prog1
180       (fasl-file-table-free file)
181     (dump-fop 'sb!impl::fop-pop file)
182     (incf (fasl-file-table-free file))))
183
184 ;;; If X is in File's EQUAL-TABLE, then push the object and return T,
185 ;;; otherwise NIL. If *COLD-LOAD-DUMP* is true, then do nothing and
186 ;;; return NIL.
187 (defun equal-check-table (x file)
188   (declare (type fasl-file file))
189   (unless *cold-load-dump*
190     (let ((handle (gethash x (fasl-file-equal-table file))))
191       (cond (handle
192              (dump-push handle file)
193              t)
194             (t
195              nil)))))
196
197 ;;; These functions are called after dumping an object to save the
198 ;;; object in the table. The object (also passed in as X) must already
199 ;;; be on the top of the FOP stack. If *COLD-LOAD-DUMP* is true, then
200 ;;; we don't do anything.
201 (defun eq-save-object (x file)
202   (declare (type fasl-file file))
203   (unless *cold-load-dump*
204     (let ((handle (dump-pop file)))
205       (setf (gethash x (fasl-file-eq-table file)) handle)
206       (dump-push handle file)))
207   (values))
208 (defun equal-save-object (x file)
209   (declare (type fasl-file file))
210   (unless *cold-load-dump*
211     (let ((handle (dump-pop file)))
212       (setf (gethash x (fasl-file-equal-table file)) handle)
213       (setf (gethash x (fasl-file-eq-table file)) handle)
214       (dump-push handle file)))
215   (values))
216
217 ;;; Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is
218 ;;; true. This is called on objects that we are about to dump might
219 ;;; have a circular path through them.
220 ;;;
221 ;;; The object must not currently be in this table, since the dumper
222 ;;; should never be recursively called on a circular reference.
223 ;;; Instead, the dumping function must detect the circularity and
224 ;;; arrange for the dumped object to be patched.
225 (defun note-potential-circularity (x file)
226   (unless *cold-load-dump*
227     (let ((circ (fasl-file-circularity-table file)))
228       (assert (not (gethash x circ)))
229       (setf (gethash x circ) x)))
230   (values))
231
232 ;;; Dump FORM to a fasl file so that it evaluated at load time in normal
233 ;;; load and at cold-load time in cold load. This is used to dump package
234 ;;; frobbing forms.
235 (defun fasl-dump-cold-load-form (form file)
236   (declare (type fasl-file file))
237   (dump-fop 'sb!impl::fop-normal-load file)
238   (let ((*cold-load-dump* t))
239     (dump-object form file))
240   (dump-fop 'sb!impl::fop-eval-for-effect file)
241   (dump-fop 'sb!impl::fop-maybe-cold-load file)
242   (values))
243 \f
244 ;;;; opening and closing fasl files
245
246 ;;; Open a fasl file, write its header, and return a FASL-FILE object
247 ;;; for dumping to it. Some human-readable information about the
248 ;;; source code is given by the string WHERE. If BYTE-P is true, this
249 ;;; file will contain no native code, and is thus largely
250 ;;; implementation independent.
251 (defun open-fasl-file (name where &optional byte-p)
252   (declare (type pathname name))
253   (let* ((stream (open name
254                        :direction :output
255                        :if-exists :new-version
256                        :element-type 'sb!assem:assembly-unit))
257          (res (make-fasl-file :stream stream)))
258
259     ;; Begin the header with the constant machine-readable (and
260     ;; semi-human-readable) string which is used to identify fasl files.
261     (write-string sb!c:*fasl-header-string-start-string* stream)
262
263     ;; The constant string which begins the header is followed by
264     ;; arbitrary human-readable text, terminated by a special
265     ;; character code.
266     (with-standard-io-syntax
267      (format stream
268              "~%  ~
269              compiled from ~S~%  ~
270              at ~A~%  ~
271              on ~A~%  ~
272              using ~A version ~A~%"
273              where
274              (format-universal-time nil (get-universal-time))
275              (machine-instance)
276              (sb!xc:lisp-implementation-type)
277              (sb!xc:lisp-implementation-version)))
278     (dump-byte sb!c:*fasl-header-string-stop-char-code* res)
279
280     ;; Finish the header by outputting fasl file implementation and
281     ;; version in machine-readable form.
282     (multiple-value-bind (implementation version)
283         (if byte-p
284             (values *backend-byte-order*
285                     byte-fasl-file-version)
286             (values *backend-fasl-file-implementation*
287                     *backend-fasl-file-version*))
288       (dump-unsigned-32 (length (symbol-name implementation)) res)
289       (dotimes (i (length (symbol-name implementation)))
290         (dump-byte (char-code (aref (symbol-name implementation) i)) res))
291       (dump-unsigned-32 version res))
292
293     res))
294
295 ;;; Close the specified FASL-FILE, aborting the write if ABORT-P.
296 ;;; We do various sanity checks, then end the group.
297 (defun close-fasl-file (file abort-p)
298   (declare (type fasl-file file))
299   (assert (zerop (hash-table-count (fasl-file-patch-table file))))
300   (dump-fop 'sb!impl::fop-verify-empty-stack file)
301   (dump-fop 'sb!impl::fop-verify-table-size file)
302   (dump-unsigned-32 (fasl-file-table-free file) file)
303   (dump-fop 'sb!impl::fop-end-group file)
304   (close (fasl-file-stream file) :abort abort-p)
305   (values))
306 \f
307 ;;;; main entries to object dumping
308
309 ;;; KLUDGE: This definition doesn't really belong in this file, but at
310 ;;; least it can be compiled without error here, and it's used here.
311 ;;; The definition requires the IGNORE-ERRORS macro, and in
312 ;;; sbcl-0.6.8.11 that's defined in early-target-error.lisp, and all
313 ;;; of the files which would otherwise be natural homes for this
314 ;;; definition (e.g. early-extensions.lisp or late-extensions.lisp)
315 ;;; are compiled before early-target-error.lisp. -- WHN 2000-11-07
316 (defun circular-list-p (list)
317   (and (listp list)
318        (multiple-value-bind (res condition)
319            (ignore-errors (list-length list))
320          (if condition
321            nil
322            (null res)))))
323
324 ;;; This function deals with dumping objects that are complex enough
325 ;;; so that we want to cache them in the table, rather than repeatedly
326 ;;; dumping them. If the object is in the EQ-TABLE, then we push it,
327 ;;; otherwise, we do a type dispatch to a type specific dumping
328 ;;; function. The type specific branches do any appropriate
329 ;;; EQUAL-TABLE check and table entry.
330 ;;;
331 ;;; When we go to dump the object, we enter it in the CIRCULARITY-TABLE.
332 (defun dump-non-immediate-object (x file)
333   (let ((index (gethash x (fasl-file-eq-table file))))
334     (cond ((and index (not *cold-load-dump*))
335            (dump-push index file))
336           (t
337            (typecase x
338              (symbol (dump-symbol x file))
339              (list
340               ;; KLUDGE: The code in this case has been hacked
341               ;; to match Douglas Crosher's quick fix to CMU CL
342               ;; (on cmucl-imp 1999-12-27), applied in sbcl-0.6.8.11
343               ;; with help from Martin Atzmueller. This is not an
344               ;; ideal solution; to quote DTC,
345               ;;   The compiler locks up trying to coalesce the
346               ;;   constant lists. The hack below will disable the
347               ;;   coalescing of lists while dumping and allows
348               ;;   the code to compile. The real fix would be to
349               ;;   take a little more care while dumping these.
350               ;; So if better list coalescing is needed, start here.
351               ;; -- WHN 2000-11-07
352               (if (circular-list-p x)
353                 (progn
354                   (dump-list x file)
355                   (eq-save-object x file))
356               (unless (equal-check-table x file)
357                 (dump-list x file)
358                    (equal-save-object x file))))
359              (layout
360               (dump-layout x file)
361               (eq-save-object x file))
362              (instance
363               (dump-structure x file)
364               (eq-save-object x file))
365              (array
366               ;; FIXME: The comment at the head of
367               ;; DUMP-NON-IMMEDIATE-OBJECT says it's for objects which
368               ;; we want to save, instead of repeatedly dumping them.
369               ;; But then we dump arrays here without doing anything
370               ;; like EQUAL-SAVE-OBJECT. What gives?
371               (dump-array x file))
372              (number
373               (unless (equal-check-table x file)
374                 (etypecase x
375                   (ratio (dump-ratio x file))
376                   (complex (dump-complex x file))
377                   (float (dump-float x file))
378                   (integer (dump-integer x file)))
379                 (equal-save-object x file)))
380              (t
381               ;; This probably never happens, since bad things tend to
382               ;; be detected during IR1 conversion.
383               (error "This object cannot be dumped into a fasl file:~% ~S"
384                      x))))))
385   (values))
386
387 ;;; Dump an object of any type by dispatching to the correct
388 ;;; type-specific dumping function. We pick off immediate objects,
389 ;;; symbols and and magic lists here. Other objects are handled by
390 ;;; DUMP-NON-IMMEDIATE-OBJECT.
391 ;;;
392 ;;; This is the function used for recursive calls to the fasl dumper.
393 ;;; We don't worry about creating circularities here, since it is
394 ;;; assumed that there is a top-level call to DUMP-OBJECT.
395 (defun sub-dump-object (x file)
396   (cond ((listp x)
397          (if x
398              (dump-non-immediate-object x file)
399              (dump-fop 'sb!impl::fop-empty-list file)))
400         ((symbolp x)
401          (if (eq x t)
402              (dump-fop 'sb!impl::fop-truth file)
403              (dump-non-immediate-object x file)))
404         ((target-fixnump x) (dump-integer x file))
405         ((characterp x) (dump-character x file))
406         (t
407          (dump-non-immediate-object x file))))
408
409 ;;; Dump stuff to backpatch already dumped objects. INFOS is the list
410 ;;; of CIRCULARITY structures describing what to do. The patching FOPs
411 ;;; take the value to store on the stack. We compute this value by
412 ;;; fetching the enclosing object from the table, and then CDR'ing it
413 ;;; if necessary.
414 (defun dump-circularities (infos file)
415   (let ((table (fasl-file-eq-table file)))
416     (dolist (info infos)
417       (let* ((value (circularity-value info))
418              (enclosing (circularity-enclosing-object info)))
419         (dump-push (gethash enclosing table) file)
420         (unless (eq enclosing value)
421           (do ((current enclosing (cdr current))
422                (i 0 (1+ i)))
423               ((eq current value)
424                (dump-fop 'sb!impl::fop-nthcdr file)
425                (dump-unsigned-32 i file))
426             (declare (type index i)))))
427
428       (ecase (circularity-type info)
429         (:rplaca (dump-fop 'sb!impl::fop-rplaca file))
430         (:rplacd (dump-fop 'sb!impl::fop-rplacd file))
431         (:svset (dump-fop 'sb!impl::fop-svset file))
432         (:struct-set (dump-fop 'sb!impl::fop-structset file)))
433       (dump-unsigned-32 (gethash (circularity-object info) table) file)
434       (dump-unsigned-32 (circularity-index info) file))))
435
436 ;;; Set up stuff for circularity detection, then dump an object. All
437 ;;; shared and circular structure will be exactly preserved within a
438 ;;; single call to Dump-Object. Sharing between objects dumped by
439 ;;; separate calls is only preserved when convenient.
440 ;;;
441 ;;; We peek at the object type so that we only pay the circular
442 ;;; detection overhead on types of objects that might be circular.
443 (defun dump-object (x file)
444   (if (or (array-header-p x)
445           (simple-vector-p x)
446           (consp x)
447           (typep x 'instance))
448       (let ((*circularities-detected* ())
449             (circ (fasl-file-circularity-table file)))
450         (clrhash circ)
451         (sub-dump-object x file)
452         (when *circularities-detected*
453           (dump-circularities *circularities-detected* file)
454           (clrhash circ)))
455       (sub-dump-object x file)))
456 \f
457 ;;;; LOAD-TIME-VALUE and MAKE-LOAD-FORM support
458
459 ;;; Emit a funcall of the function and return the handle for the
460 ;;; result.
461 (defun fasl-dump-load-time-value-lambda (fun file)
462   (declare (type clambda fun) (type fasl-file file))
463   (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file))))
464     (assert handle)
465     (dump-push handle file)
466     (dump-fop 'sb!impl::fop-funcall file)
467     (dump-byte 0 file))
468   (dump-pop file))
469
470 ;;; Return T iff CONSTANT has not already been dumped. It's been
471 ;;; dumped if it's in the EQ table.
472 (defun fasl-constant-already-dumped (constant file)
473   (if (or (gethash constant (fasl-file-eq-table file))
474           (gethash constant (fasl-file-valid-structures file)))
475       t
476       nil))
477
478 ;;; Use HANDLE whenever we try to dump CONSTANT. HANDLE should have been
479 ;;; returned earlier by FASL-DUMP-LOAD-TIME-VALUE-LAMBDA.
480 (defun fasl-note-handle-for-constant (constant handle file)
481   (let ((table (fasl-file-eq-table file)))
482     (when (gethash constant table)
483       (error "~S already dumped?" constant))
484     (setf (gethash constant table) handle))
485   (values))
486
487 ;;; Note that the specified structure can just be dumped by
488 ;;; enumerating the slots.
489 (defun fasl-validate-structure (structure file)
490   (setf (gethash structure (fasl-file-valid-structures file)) t)
491   (values))
492 \f
493 ;;;; number dumping
494
495 ;;; Dump a ratio
496
497 (defun dump-ratio (x file)
498   (sub-dump-object (numerator x) file)
499   (sub-dump-object (denominator x) file)
500   (dump-fop 'sb!impl::fop-ratio file))
501
502 ;;; Dump an integer.
503
504 (defun dump-integer (n file)
505   (typecase n
506     ((signed-byte 8)
507      (dump-fop 'sb!impl::fop-byte-integer file)
508      (dump-byte (logand #xFF n) file))
509     ((unsigned-byte 31)
510      (dump-fop 'sb!impl::fop-word-integer file)
511      (dump-unsigned-32 n file))
512     ((signed-byte 32)
513      (dump-fop 'sb!impl::fop-word-integer file)
514      (dump-integer-as-n-bytes n 4 file))
515     (t
516      (let ((bytes (ceiling (1+ (integer-length n)) 8)))
517        (dump-fop* bytes
518                   sb!impl::fop-small-integer
519                   sb!impl::fop-integer
520                   file)
521        (dump-integer-as-n-bytes n bytes file)))))
522
523 (defun dump-float (x file)
524   (etypecase x
525     (single-float
526      (dump-fop 'sb!impl::fop-single-float file)
527      (dump-integer-as-n-bytes (single-float-bits x) 4 file))
528     (double-float
529      (dump-fop 'sb!impl::fop-double-float file)
530      (let ((x x))
531        (declare (double-float x))
532        ;; FIXME: Why sometimes DUMP-UNSIGNED-32 and sometimes
533        ;; DUMP-INTEGER-AS-N-BYTES .. 4?
534        (dump-unsigned-32 (double-float-low-bits x) file)
535        (dump-integer-as-n-bytes (double-float-high-bits x) 4 file)))
536     #!+long-float
537     (long-float
538      (dump-fop 'sb!impl::fop-long-float file)
539      (dump-long-float x file))))
540
541 (defun dump-complex (x file)
542   (typecase x
543     #-sb-xc-host
544     ((complex single-float)
545      (dump-fop 'sb!impl::fop-complex-single-float file)
546      (dump-integer-as-n-bytes (single-float-bits (realpart x)) 4 file)
547      (dump-integer-as-n-bytes (single-float-bits (imagpart x)) 4 file))
548     #-sb-xc-host
549     ((complex double-float)
550      (dump-fop 'sb!impl::fop-complex-double-float file)
551      (let ((re (realpart x)))
552        (declare (double-float re))
553        (dump-unsigned-32 (double-float-low-bits re) file)
554        (dump-integer-as-n-bytes (double-float-high-bits re) 4 file))
555      (let ((im (imagpart x)))
556        (declare (double-float im))
557        (dump-unsigned-32 (double-float-low-bits im) file)
558        (dump-integer-as-n-bytes (double-float-high-bits im) 4 file)))
559     #!+(and long-float (not sb-xc))
560     ((complex long-float)
561      (dump-fop 'sb!impl::fop-complex-long-float file)
562      (dump-long-float (realpart x) file)
563      (dump-long-float (imagpart x) file))
564     (t
565      (sub-dump-object (realpart x) file)
566      (sub-dump-object (imagpart x) file)
567      (dump-fop 'sb!impl::fop-complex file))))
568 \f
569 ;;;; symbol dumping
570
571 ;;; Return the table index of PKG, adding the package to the table if
572 ;;; necessary. During cold load, we read the string as a normal string
573 ;;; so that we can do the package lookup at cold load time.
574 ;;;
575 ;;; FIXME: Despite the parallelism in names, the functionality of
576 ;;; this function is not parallel to other functions DUMP-FOO, e.g.
577 ;;; DUMP-SYMBOL and DUMP-LIST. The mapping between names and behavior
578 ;;; should be made more consistent.
579 (defun dump-package (pkg file)
580   (declare (type package pkg) (type fasl-file file) (values index)
581            (inline assoc))
582   (cond ((cdr (assoc pkg (fasl-file-packages file) :test #'eq)))
583         (t
584          (unless *cold-load-dump*
585            (dump-fop 'sb!impl::fop-normal-load file))
586          (dump-simple-string (package-name pkg) file)
587          (dump-fop 'sb!impl::fop-package file)
588          (unless *cold-load-dump*
589            (dump-fop 'sb!impl::fop-maybe-cold-load file))
590          (let ((entry (dump-pop file)))
591            (push (cons pkg entry) (fasl-file-packages file))
592            entry))))
593 \f
594 ;;; dumper for lists
595
596 ;;; Dump a list, setting up patching information when there are
597 ;;; circularities. We scan down the list, checking for CDR and CAR
598 ;;; circularities.
599 ;;;
600 ;;; If there is a CDR circularity, we terminate the list with NIL and
601 ;;; make a CIRCULARITY notation for the CDR of the previous cons.
602 ;;;
603 ;;; If there is no CDR circularity, then we mark the current cons and
604 ;;; check for a CAR circularity. When there is a CAR circularity, we
605 ;;; make the CAR NIL initially, arranging for the current cons to be
606 ;;; patched later.
607 ;;;
608 ;;; Otherwise, we recursively call the dumper to dump the current
609 ;;; element.
610 ;;;
611 ;;; Marking of the conses is inhibited when *COLD-LOAD-DUMP* is true.
612 ;;; This inhibits all circularity detection.
613 (defun dump-list (list file)
614   (assert (and list
615                (not (gethash list (fasl-file-circularity-table file)))))
616   (do* ((l list (cdr l))
617         (n 0 (1+ n))
618         (circ (fasl-file-circularity-table file)))
619        ((atom l)
620         (cond ((null l)
621                (terminate-undotted-list n file))
622               (t
623                (sub-dump-object l file)
624                (terminate-dotted-list n file))))
625     (declare (type index n))
626     (let ((ref (gethash l circ)))
627       (when ref
628         (push (make-circularity :type :rplacd
629                                 :object list
630                                 :index (1- n)
631                                 :value l
632                                 :enclosing-object ref)
633               *circularities-detected*)
634         (terminate-undotted-list n file)
635         (return)))
636
637     (unless *cold-load-dump*
638       (setf (gethash l circ) list))
639
640     (let* ((obj (car l))
641            (ref (gethash obj circ)))
642       (cond (ref
643              (push (make-circularity :type :rplaca
644                                      :object list
645                                      :index n
646                                      :value obj
647                                      :enclosing-object ref)
648                    *circularities-detected*)
649              (sub-dump-object nil file))
650             (t
651              (sub-dump-object obj file))))))
652
653 (defun terminate-dotted-list (n file)
654   (declare (type index n) (type fasl-file file))
655   (case n
656     (1 (dump-fop 'sb!impl::fop-list*-1 file))
657     (2 (dump-fop 'sb!impl::fop-list*-2 file))
658     (3 (dump-fop 'sb!impl::fop-list*-3 file))
659     (4 (dump-fop 'sb!impl::fop-list*-4 file))
660     (5 (dump-fop 'sb!impl::fop-list*-5 file))
661     (6 (dump-fop 'sb!impl::fop-list*-6 file))
662     (7 (dump-fop 'sb!impl::fop-list*-7 file))
663     (8 (dump-fop 'sb!impl::fop-list*-8 file))
664     (T (do ((nn n (- nn 255)))
665            ((< nn 256)
666             (dump-fop 'sb!impl::fop-list* file)
667             (dump-byte nn file))
668          (declare (type index nn))
669          (dump-fop 'sb!impl::fop-list* file)
670          (dump-byte 255 file)))))
671
672 ;;; If N > 255, must build list with one LIST operator, then LIST*
673 ;;; operators.
674
675 (defun terminate-undotted-list (n file)
676   (declare (type index n) (type fasl-file file))
677   (case n
678     (1 (dump-fop 'sb!impl::fop-list-1 file))
679     (2 (dump-fop 'sb!impl::fop-list-2 file))
680     (3 (dump-fop 'sb!impl::fop-list-3 file))
681     (4 (dump-fop 'sb!impl::fop-list-4 file))
682     (5 (dump-fop 'sb!impl::fop-list-5 file))
683     (6 (dump-fop 'sb!impl::fop-list-6 file))
684     (7 (dump-fop 'sb!impl::fop-list-7 file))
685     (8 (dump-fop 'sb!impl::fop-list-8 file))
686     (T (cond ((< n 256)
687               (dump-fop 'sb!impl::fop-list file)
688               (dump-byte n file))
689              (t (dump-fop 'sb!impl::fop-list file)
690                 (dump-byte 255 file)
691                 (do ((nn (- n 255) (- nn 255)))
692                     ((< nn 256)
693                      (dump-fop 'sb!impl::fop-list* file)
694                      (dump-byte nn file))
695                   (declare (type index nn))
696                   (dump-fop 'sb!impl::fop-list* file)
697                   (dump-byte 255 file)))))))
698 \f
699 ;;;; array dumping
700
701 ;;; Dump the array thing.
702 (defun dump-array (x file)
703   (if (vectorp x)
704       (dump-vector x file)
705       (dump-multi-dim-array x file)))
706
707 ;;; Dump the vector object. If it's not simple, then actually dump a
708 ;;; simple version of it. But we enter the original in the EQ or EQUAL
709 ;;; tables.
710 (defun dump-vector (x file)
711   (let ((simple-version (if (array-header-p x)
712                             (coerce x 'simple-array)
713                             x)))
714     (typecase simple-version
715       (simple-base-string
716        (unless (equal-check-table x file)
717          (dump-simple-string simple-version file)
718          (equal-save-object x file)))
719       (simple-vector
720        (dump-simple-vector simple-version file)
721        (eq-save-object x file))
722       ((simple-array single-float (*))
723        (dump-single-float-vector simple-version file)
724        (eq-save-object x file))
725       ((simple-array double-float (*))
726        (dump-double-float-vector simple-version file)
727        (eq-save-object x file))
728       #!+long-float
729       ((simple-array long-float (*))
730        (dump-long-float-vector simple-version file)
731        (eq-save-object x file))
732       ((simple-array (complex single-float) (*))
733        (dump-complex-single-float-vector simple-version file)
734        (eq-save-object x file))
735       ((simple-array (complex double-float) (*))
736        (dump-complex-double-float-vector simple-version file)
737        (eq-save-object x file))
738       #!+long-float
739       ((simple-array (complex long-float) (*))
740        (dump-complex-long-float-vector simple-version file)
741        (eq-save-object x file))
742       (t
743        (dump-i-vector simple-version file)
744        (eq-save-object x file)))))
745
746 ;;; Dump a SIMPLE-VECTOR, handling any circularities.
747 (defun dump-simple-vector (v file)
748   (declare (type simple-vector v) (type fasl-file file))
749   (note-potential-circularity v file)
750   (do ((index 0 (1+ index))
751        (length (length v))
752        (circ (fasl-file-circularity-table file)))
753       ((= index length)
754        (dump-fop* length
755                   sb!impl::fop-small-vector
756                   sb!impl::fop-vector
757                   file))
758     (let* ((obj (aref v index))
759            (ref (gethash obj circ)))
760       (cond (ref
761              (push (make-circularity :type :svset
762                                      :object v
763                                      :index index
764                                      :value obj
765                                      :enclosing-object ref)
766                    *circularities-detected*)
767              (sub-dump-object nil file))
768             (t
769              (sub-dump-object obj file))))))
770
771 (defun dump-i-vector (vec file &key data-only)
772   (declare (type (simple-array * (*)) vec))
773   (let ((len (length vec)))
774     (labels ((dump-unsigned-vector (size bytes)
775                (unless data-only
776                  (dump-fop 'sb!impl::fop-int-vector file)
777                  (dump-unsigned-32 len file)
778                  (dump-byte size file))
779                ;; The case which is easy to handle in a portable way is when
780                ;; the element size is a multiple of the output byte size, and
781                ;; happily that's the only case we need to be portable. (The
782                ;; cross-compiler has to output debug information (including
783                ;; (SIMPLE-ARRAY (UNSIGNED-BYTE 8) *).) The other cases are only
784                ;; needed in the target SBCL, so we let them be handled with
785                ;; unportable bit bashing.
786                (cond ((>= size 8) ; easy cases
787                       (multiple-value-bind (floor rem) (floor size 8)
788                         (assert (zerop rem))
789                         (dovector (i vec)
790                           (dump-integer-as-n-bytes i floor file))))
791                      (t ; harder cases, not supported in cross-compiler
792                       (dump-raw-bytes vec bytes file))))
793              (dump-signed-vector (size bytes)
794                ;; Note: Dumping specialized signed vectors isn't
795                ;; supported in the cross-compiler. (All cases here end
796                ;; up trying to call DUMP-RAW-BYTES, which isn't
797                ;; provided in the cross-compilation host, only on the
798                ;; target machine.)
799                (unless data-only
800                  (dump-fop 'sb!impl::fop-signed-int-vector file)
801                  (dump-unsigned-32 len file)
802                  (dump-byte size file))
803                (dump-raw-bytes vec bytes file)))
804       (etypecase vec
805         ;; KLUDGE: What exactly does the (ASH .. -3) stuff do? -- WHN 19990902
806         (simple-bit-vector
807          (dump-unsigned-vector 1 (ash (+ (the index len) 7) -3)))
808         ((simple-array (unsigned-byte 2) (*))
809          (dump-unsigned-vector 2 (ash (+ (the index (ash len 1)) 7) -3)))
810         ((simple-array (unsigned-byte 4) (*))
811          (dump-unsigned-vector 4 (ash (+ (the index (ash len 2)) 7) -3)))
812         ((simple-array (unsigned-byte 8) (*))
813          (dump-unsigned-vector 8 len))
814         ((simple-array (unsigned-byte 16) (*))
815          (dump-unsigned-vector 16 (* 2 len)))
816         ((simple-array (unsigned-byte 32) (*))
817          (dump-unsigned-vector 32 (* 4 len)))
818         ((simple-array (signed-byte 8) (*))
819          (dump-signed-vector 8 len))
820         ((simple-array (signed-byte 16) (*))
821          (dump-signed-vector 16 (* 2 len)))
822         ((simple-array (signed-byte 30) (*))
823          (dump-signed-vector 30 (* 4 len)))
824         ((simple-array (signed-byte 32) (*))
825          (dump-signed-vector 32 (* 4 len)))))))
826 \f
827 ;;; Dump characters and string-ish things.
828
829 (defun dump-character (ch file)
830   (dump-fop 'sb!impl::fop-short-character file)
831   (dump-byte (char-code ch) file))
832
833 ;;; a helper function shared by DUMP-SIMPLE-STRING and DUMP-SYMBOL
834 (defun dump-characters-of-string (s fasl-file)
835   (declare (type string s) (type fasl-file fasl-file))
836   (dovector (c s)
837     (dump-byte (char-code c) fasl-file))
838   (values))
839
840 ;;; Dump a SIMPLE-BASE-STRING.
841 ;;; FIXME: should be called DUMP-SIMPLE-BASE-STRING then
842 (defun dump-simple-string (s file)
843   (declare (type simple-base-string s))
844   (dump-fop* (length s)
845              sb!impl::fop-small-string
846              sb!impl::fop-string
847              file)
848   (dump-characters-of-string s file)
849   (values))
850
851 ;;; If we get here, it is assumed that the symbol isn't in the table,
852 ;;; but we are responsible for putting it there when appropriate. To
853 ;;; avoid too much special-casing, we always push the symbol in the
854 ;;; table, but don't record that we have done so if *COLD-LOAD-DUMP*
855 ;;; is true.
856 (defun dump-symbol (s file)
857   (let* ((pname (symbol-name s))
858          (pname-length (length pname))
859          (pkg (symbol-package s)))
860
861     (cond ((null pkg)
862            (dump-fop* pname-length
863                       sb!impl::fop-uninterned-small-symbol-save
864                       sb!impl::fop-uninterned-symbol-save
865                       file))
866           ;; CMU CL had FOP-SYMBOL-SAVE/FOP-SMALL-SYMBOL-SAVE fops which
867           ;; used the current value of *PACKAGE*. Unfortunately that's
868           ;; broken w.r.t. ANSI Common Lisp semantics, so those are gone
869           ;; from SBCL.
870           ;;((eq pkg *package*)
871           ;; (dump-fop* pname-length
872           ;;        sb!impl::fop-small-symbol-save
873           ;;        sb!impl::fop-symbol-save file))
874           ((eq pkg sb!int:*cl-package*)
875            (dump-fop* pname-length
876                       sb!impl::fop-lisp-small-symbol-save
877                       sb!impl::fop-lisp-symbol-save
878                       file))
879           ((eq pkg sb!int:*keyword-package*)
880            (dump-fop* pname-length
881                       sb!impl::fop-keyword-small-symbol-save
882                       sb!impl::fop-keyword-symbol-save
883                       file))
884           ((< pname-length 256)
885            (dump-fop* (dump-package pkg file)
886                       sb!impl::fop-small-symbol-in-byte-package-save
887                       sb!impl::fop-small-symbol-in-package-save
888                       file)
889            (dump-byte pname-length file))
890           (t
891            (dump-fop* (dump-package pkg file)
892                       sb!impl::fop-symbol-in-byte-package-save
893                       sb!impl::fop-symbol-in-package-save
894                       file)
895            (dump-unsigned-32 pname-length file)))
896
897     (dump-characters-of-string pname file)
898
899     (unless *cold-load-dump*
900       (setf (gethash s (fasl-file-eq-table file))
901             (fasl-file-table-free file)))
902
903     (incf (fasl-file-table-free file)))
904
905   (values))
906 \f
907 ;;;; component (function) dumping
908
909 (defun dump-segment (segment code-length fasl-file)
910   (declare (type sb!assem:segment segment)
911            (type fasl-file fasl-file))
912   (let* ((stream (fasl-file-stream fasl-file))
913          (nwritten (write-segment-contents segment stream)))
914     ;; In CMU CL there was no enforced connection between the CODE-LENGTH
915     ;; argument and the number of bytes actually written. I added this
916     ;; assertion while trying to debug portable genesis. -- WHN 19990902
917     (unless (= code-length nwritten)
918       (error "internal error, code-length=~D, nwritten=~D"
919              code-length
920              nwritten)))
921   ;; KLUDGE: It's not clear what this is trying to do, but it looks as
922   ;; though it's an implicit undocumented dependence on a 4-byte
923   ;; wordsize which could be painful in porting. Note also that there
924   ;; are other undocumented modulo-4 things scattered throughout the
925   ;; code and conditionalized with GENGC, and I don't know what those
926   ;; do either. -- WHN 19990323
927   #!+gengc (unless (zerop (logand code-length 3))
928              (dotimes (i (- 4 (logand code-length 3)))
929                (dump-byte 0 fasl-file)))
930   (values))
931
932 ;;; Dump all the fixups. Currently there are three flavors of fixup:
933 ;;;  - assembly routines: named by a symbol
934 ;;;  - foreign (C) symbols: named by a string
935 ;;;  - code object references: don't need a name.
936 (defun dump-fixups (fixups fasl-file)
937   (declare (list fixups) (type fasl-file fasl-file))
938   (dolist (info fixups)
939     ;; FIXME: Packing data with LIST in NOTE-FIXUP and unpacking them
940     ;; with FIRST, SECOND, and THIRD here is hard to follow and
941     ;; maintain. Perhaps we could define a FIXUP-INFO structure to use
942     ;; instead, and rename *FIXUPS* to *FIXUP-INFO-LIST*?
943     (let* ((kind (first info))
944            (fixup (second info))
945            (name (fixup-name fixup))
946            (flavor (fixup-flavor fixup))
947            (offset (third info)))
948       ;; FIXME: This OFFSET is not what's called OFFSET in the FIXUP
949       ;; structure, it's what's called POSN in NOTE-FIXUP. (As far as
950       ;; I can tell, FIXUP-OFFSET is not actually an offset, it's an
951       ;; internal label used instead of NAME for :CODE-OBJECT fixups.
952       ;; Notice that in the :CODE-OBJECT case, NAME is ignored.)
953       (dump-fop 'sb!impl::fop-normal-load fasl-file)
954       (let ((*cold-load-dump* t))
955         (dump-object kind fasl-file))
956       (dump-fop 'sb!impl::fop-maybe-cold-load fasl-file)
957       ;; Depending on the flavor, we may have various kinds of
958       ;; noise before the offset.
959       (ecase flavor
960         (:assembly-routine
961          (assert (symbolp name))
962          (dump-fop 'sb!impl::fop-normal-load fasl-file)
963          (let ((*cold-load-dump* t))
964            (dump-object name fasl-file))
965          (dump-fop 'sb!impl::fop-maybe-cold-load fasl-file)
966          (dump-fop 'sb!impl::fop-assembler-fixup fasl-file))
967         (:foreign
968          (assert (stringp name))
969          (dump-fop 'sb!impl::fop-foreign-fixup fasl-file)
970          (let ((len (length name)))
971            (assert (< len 256)) ; (limit imposed by fop definition)
972            (dump-byte len fasl-file)
973            (dotimes (i len)
974              (dump-byte (char-code (schar name i)) fasl-file))))
975         (:code-object
976          (assert (null name))
977          (dump-fop 'sb!impl::fop-code-object-fixup fasl-file)))
978       ;; No matter what the flavor, we'll always dump the offset.
979       (dump-unsigned-32 offset fasl-file)))
980   (values))
981
982 ;;; Dump out the constant pool and code-vector for component, push the
983 ;;; result in the table, and return the offset.
984 ;;;
985 ;;; The only tricky thing is handling constant-pool references to
986 ;;; functions. If we have already dumped the function, then we just
987 ;;; push the code pointer. Otherwise, we must create back-patching
988 ;;; information so that the constant will be set when the function is
989 ;;; eventually dumped. This is a bit awkward, since we don't have the
990 ;;; handle for the code object being dumped while we are dumping its
991 ;;; constants.
992 ;;;
993 ;;; We dump trap objects in any unused slots or forward referenced slots.
994 (defun dump-code-object (component
995                          code-segment
996                          code-length
997                          trace-table-as-list
998                          fixups
999                          fasl-file)
1000
1001   (declare (type component component)
1002            (list trace-table-as-list)
1003            (type index code-length)
1004            (type fasl-file fasl-file))
1005
1006   (let* ((2comp (component-info component))
1007          (constants (ir2-component-constants 2comp))
1008          (header-length (length constants))
1009          (packed-trace-table (pack-trace-table trace-table-as-list))
1010          (total-length (+ code-length
1011                           (* (length packed-trace-table) tt-bytes-per-entry))))
1012
1013     (collect ((patches))
1014
1015       ;; Dump the debug info.
1016       #!+gengc
1017       (let ((info (debug-info-for-component component))
1018             (*dump-only-valid-structures* nil))
1019         (dump-object info fasl-file)
1020         (let ((info-handle (dump-pop fasl-file)))
1021           (dump-push info-handle fasl-file)
1022           (push info-handle (fasl-file-debug-info fasl-file))))
1023
1024       ;; Dump the offset of the trace table.
1025       (dump-object code-length fasl-file)
1026       ;; FIXME: As long as we don't have GENGC, the trace table is
1027       ;; hardwired to be empty. So we might be able to get rid of
1028       ;; trace tables? However, we should probably wait for the first
1029       ;; port to a system where CMU CL uses GENGC to see whether GENGC
1030       ;; is really gone. (I.e. maybe other non-X86 ports will want to
1031       ;; use it, just as in CMU CL.)
1032
1033       ;; Dump the constants, noting any :entries that have to be fixed up.
1034       (do ((i sb!vm:code-constants-offset (1+ i)))
1035           ((>= i header-length))
1036         (let ((entry (aref constants i)))
1037           (etypecase entry
1038             (constant
1039              (dump-object (constant-value entry) fasl-file))
1040             (cons
1041              (ecase (car entry)
1042                (:entry
1043                 (let* ((info (leaf-info (cdr entry)))
1044                        (handle (gethash info
1045                                         (fasl-file-entry-table fasl-file))))
1046                   (cond
1047                    (handle
1048                     (dump-push handle fasl-file))
1049                    (t
1050                     (patches (cons info i))
1051                     (dump-fop 'sb!impl::fop-misc-trap fasl-file)))))
1052                (:load-time-value
1053                 (dump-push (cdr entry) fasl-file))
1054                (:fdefinition
1055                 (dump-object (cdr entry) fasl-file)
1056                 (dump-fop 'sb!impl::fop-fdefinition fasl-file))))
1057             (null
1058              (dump-fop 'sb!impl::fop-misc-trap fasl-file)))))
1059
1060       ;; Dump the debug info.
1061       #!-gengc
1062       (let ((info (debug-info-for-component component))
1063             (*dump-only-valid-structures* nil))
1064         (dump-object info fasl-file)
1065         (let ((info-handle (dump-pop fasl-file)))
1066           (dump-push info-handle fasl-file)
1067           (push info-handle (fasl-file-debug-info fasl-file))))
1068
1069       (let ((num-consts #!+gengc (- header-length
1070                                     sb!vm:code-debug-info-slot)
1071                         #!-gengc (- header-length
1072                                     sb!vm:code-trace-table-offset-slot))
1073             (total-length #!+gengc (ceiling total-length 4)
1074                           #!-gengc total-length))
1075         (cond ((and (< num-consts #x100) (< total-length #x10000))
1076                (dump-fop 'sb!impl::fop-small-code fasl-file)
1077                (dump-byte num-consts fasl-file)
1078                (dump-integer-as-n-bytes total-length 2 fasl-file))
1079               (t
1080                (dump-fop 'sb!impl::fop-code fasl-file)
1081                (dump-unsigned-32 num-consts fasl-file)
1082                (dump-unsigned-32 total-length fasl-file))))
1083
1084       ;; These two dumps are only ones which contribute to our
1085       ;; TOTAL-LENGTH value.
1086       (dump-segment code-segment code-length fasl-file)
1087       (dump-i-vector packed-trace-table fasl-file :data-only t)
1088
1089       ;; DUMP-FIXUPS does its own internal DUMP-FOPs: the bytes it
1090       ;; dumps aren't included in the TOTAL-LENGTH passed to our
1091       ;; FOP-CODE/FOP-SMALL-CODE fop.
1092       (dump-fixups fixups fasl-file)
1093
1094       (dump-fop 'sb!impl::fop-sanctify-for-execution fasl-file)
1095       (let ((handle (dump-pop fasl-file)))
1096         (dolist (patch (patches))
1097           (push (cons handle (cdr patch))
1098                 (gethash (car patch) (fasl-file-patch-table fasl-file))))
1099         handle))))
1100
1101 (defun dump-assembler-routines (code-segment length fixups routines file)
1102   (dump-fop 'sb!impl::fop-assembler-code file)
1103   (dump-unsigned-32 #!+gengc (ceiling length 4)
1104                     #!-gengc length
1105                     file)
1106   (write-segment-contents code-segment (fasl-file-stream file))
1107   (dolist (routine routines)
1108     (dump-fop 'sb!impl::fop-normal-load file)
1109     (let ((*cold-load-dump* t))
1110       (dump-object (car routine) file))
1111     (dump-fop 'sb!impl::fop-maybe-cold-load file)
1112     (dump-fop 'sb!impl::fop-assembler-routine file)
1113     (dump-unsigned-32 (label-position (cdr routine)) file))
1114   (dump-fixups fixups file)
1115   (dump-fop 'sb!impl::fop-sanctify-for-execution file)
1116   (dump-pop file))
1117
1118 ;;; Dump a function-entry data structure corresponding to ENTRY to
1119 ;;; FILE. CODE-HANDLE is the table offset of the code object for the
1120 ;;; component.
1121 ;;;
1122 ;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the
1123 ;;; cold loader can instantiate the definition at cold-load time,
1124 ;;; allowing forward references to functions in top-level forms.
1125 (defun dump-one-entry (entry code-handle file)
1126   (declare (type entry-info entry) (type index code-handle)
1127            (type fasl-file file))
1128   (let ((name (entry-info-name entry)))
1129     (dump-push code-handle file)
1130     (dump-object name file)
1131     (dump-object (entry-info-arguments entry) file)
1132     (dump-object (entry-info-type entry) file)
1133     (dump-fop 'sb!impl::fop-function-entry file)
1134     (dump-unsigned-32 (label-position (entry-info-offset entry)) file)
1135     (let ((handle (dump-pop file)))
1136       (when (and name (or (symbolp name) (listp name)))
1137         (dump-object name file)
1138         (dump-push handle file)
1139         (dump-fop 'sb!impl::fop-fset file))
1140       handle)))
1141
1142 ;;; Alter the code object referenced by CODE-HANDLE at the specified
1143 ;;; OFFSET, storing the object referenced by ENTRY-HANDLE.
1144 (defun dump-alter-code-object (code-handle offset entry-handle file)
1145   (declare (type index code-handle entry-handle offset) (type fasl-file file))
1146   (dump-push code-handle file)
1147   (dump-push entry-handle file)
1148   (dump-fop* offset
1149              sb!impl::fop-byte-alter-code
1150              sb!impl::fop-alter-code
1151              file)
1152   (values))
1153
1154 ;;; Dump the code, constants, etc. for component. We pass in the
1155 ;;; assembler fixups, code vector and node info.
1156 (defun fasl-dump-component (component
1157                             code-segment
1158                             code-length
1159                             trace-table
1160                             fixups
1161                             file)
1162   (declare (type component component) (list trace-table) (type fasl-file file))
1163
1164   (dump-fop 'sb!impl::fop-verify-empty-stack file)
1165   (dump-fop 'sb!impl::fop-verify-table-size file)
1166   (dump-unsigned-32 (fasl-file-table-free file) file)
1167
1168   #!+sb-dyncount
1169   (let ((info (ir2-component-dyncount-info (component-info component))))
1170     (when info
1171       (fasl-validate-structure info file)))
1172
1173   (let ((code-handle (dump-code-object component
1174                                        code-segment
1175                                        code-length
1176                                        trace-table
1177                                        fixups
1178                                        file))
1179         (2comp (component-info component)))
1180     (dump-fop 'sb!impl::fop-verify-empty-stack file)
1181
1182     (dolist (entry (ir2-component-entries 2comp))
1183       (let ((entry-handle (dump-one-entry entry code-handle file)))
1184         (setf (gethash entry (fasl-file-entry-table file)) entry-handle)
1185
1186         (let ((old (gethash entry (fasl-file-patch-table file))))
1187           ;; FIXME: All this code is shared with
1188           ;; FASL-DUMP-BYTE-COMPONENT, and should probably be gathered
1189           ;; up into a named function (DUMP-PATCHES?) called from both
1190           ;; functions.
1191           (when old
1192             (dolist (patch old)
1193               (dump-alter-code-object (car patch)
1194                                       (cdr patch)
1195                                       entry-handle
1196                                       file))
1197             (remhash entry (fasl-file-patch-table file)))))))
1198   (values))
1199
1200 (defun dump-byte-code-object (segment code-length constants file)
1201   (declare (type sb!assem:segment segment)
1202            (type index code-length)
1203            (type vector constants)
1204            (type fasl-file file))
1205   (collect ((entry-patches))
1206
1207     ;; Dump the debug info.
1208     #!+gengc
1209     (let ((info (make-debug-info
1210                  :name (component-name *component-being-compiled*)))
1211           (*dump-only-valid-structures* nil))
1212       (dump-object info file)
1213       (let ((info-handle (dump-pop file)))
1214         (dump-push info-handle file)
1215         (push info-handle (fasl-file-debug-info file))))
1216
1217     ;; The "trace table" is initialized by loader to hold a list of
1218     ;; all byte functions in this code object (for debug info.)
1219     (dump-object nil file)
1220
1221     ;; Dump the constants.
1222     (dotimes (i (length constants))
1223       (let ((entry (aref constants i)))
1224         (etypecase entry
1225           (constant
1226            (dump-object (constant-value entry) file))
1227           (null
1228            (dump-fop 'sb!impl::fop-misc-trap file))
1229           (list
1230            (ecase (car entry)
1231              (:entry
1232               (let* ((info (leaf-info (cdr entry)))
1233                      (handle (gethash info (fasl-file-entry-table file))))
1234                 (cond
1235                  (handle
1236                   (dump-push handle file))
1237                  (t
1238                   (entry-patches (cons info
1239                                        (+ i sb!vm:code-constants-offset)))
1240                   (dump-fop 'sb!impl::fop-misc-trap file)))))
1241              (:load-time-value
1242               (dump-push (cdr entry) file))
1243              (:fdefinition
1244               (dump-object (cdr entry) file)
1245               (dump-fop 'sb!impl::fop-fdefinition file))
1246              (:type-predicate
1247               (dump-object 'load-type-predicate file)
1248               (let ((*unparse-function-type-simplify* t))
1249                 (dump-object (type-specifier (cdr entry)) file))
1250               (dump-fop 'sb!impl::fop-funcall file)
1251               (dump-byte 1 file)))))))
1252
1253     ;; Dump the debug info.
1254     #!-gengc
1255     (let ((info (make-debug-info :name
1256                                  (component-name *component-being-compiled*)))
1257           (*dump-only-valid-structures* nil))
1258       (dump-object info file)
1259       (let ((info-handle (dump-pop file)))
1260         (dump-push info-handle file)
1261         (push info-handle (fasl-file-debug-info file))))
1262
1263     (let ((num-consts #!+gengc (+ (length constants) 2)
1264                       #!-gengc (1+ (length constants)))
1265           (code-length #!+gengc (ceiling code-length 4)
1266                        #!-gengc code-length))
1267       (cond ((and (< num-consts #x100) (< code-length #x10000))
1268              (dump-fop 'sb!impl::fop-small-code file)
1269              (dump-byte num-consts file)
1270              (dump-integer-as-n-bytes code-length 2 file))
1271             (t
1272              (dump-fop 'sb!impl::fop-code file)
1273              (dump-unsigned-32 num-consts file)
1274              (dump-unsigned-32 code-length file))))
1275     (dump-segment segment code-length file)
1276     (let ((code-handle (dump-pop file))
1277           (patch-table (fasl-file-patch-table file)))
1278       (dolist (patch (entry-patches))
1279         (push (cons code-handle (cdr patch))
1280               (gethash (car patch) patch-table)))
1281       code-handle)))
1282
1283 ;;; Dump a BYTE-FUNCTION object. We dump the layout and
1284 ;;; funcallable-instance info, but rely on the loader setting up the
1285 ;;; correct funcallable-instance-function.
1286 (defun dump-byte-function (xep code-handle file)
1287   (let ((nslots (- (get-closure-length xep)
1288                    ;; 1- for header
1289                    (1- sb!vm:funcallable-instance-info-offset))))
1290     (dotimes (i nslots)
1291       (if (zerop i)
1292           (dump-push code-handle file)
1293           (dump-object (%funcallable-instance-info xep i) file)))
1294     (dump-object (%funcallable-instance-layout xep) file)
1295     (dump-fop 'sb!impl::fop-make-byte-compiled-function file)
1296     (dump-byte nslots file))
1297   (values))
1298
1299 ;;; Dump a byte-component. This is similar to FASL-DUMP-COMPONENT, but
1300 ;;; different.
1301 (defun fasl-dump-byte-component (segment length constants xeps file)
1302   (declare (type sb!assem:segment segment)
1303            (type index length)
1304            (type vector constants)
1305            (type list xeps)
1306            (type fasl-file file))
1307
1308   (let ((code-handle (dump-byte-code-object segment length constants file)))
1309     (dolist (noise xeps)
1310       (let* ((lambda (car noise))
1311              (info (lambda-info lambda))
1312              (xep (cdr noise)))
1313         (dump-byte-function xep code-handle file)
1314         (let* ((entry-handle (dump-pop file))
1315                (patch-table (fasl-file-patch-table file))
1316                (old (gethash info patch-table)))
1317           (setf (gethash info (fasl-file-entry-table file)) entry-handle)
1318           (when old
1319             (dolist (patch old)
1320               (dump-alter-code-object (car patch)
1321                                       (cdr patch)
1322                                       entry-handle
1323                                       file))
1324             (remhash info patch-table))))))
1325   (values))
1326
1327 ;;; Dump a FOP-FUNCALL to call an already dumped top-level lambda at
1328 ;;; load time.
1329 (defun fasl-dump-top-level-lambda-call (fun file)
1330   (declare (type clambda fun) (type fasl-file file))
1331   (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file))))
1332     (assert handle)
1333     (dump-push handle file)
1334     (dump-fop 'sb!impl::fop-funcall-for-effect file)
1335     (dump-byte 0 file))
1336   (values))
1337
1338 ;;; Compute the correct list of DEBUG-SOURCE structures and backpatch
1339 ;;; all of the dumped DEBUG-INFO structures. We clear the
1340 ;;; FASL-FILE-DEBUG-INFO, so that subsequent components with different
1341 ;;; source info may be dumped.
1342 (defun fasl-dump-source-info (info file)
1343   (declare (type source-info info) (type fasl-file file))
1344   (let ((res (debug-source-for-info info))
1345         (*dump-only-valid-structures* nil))
1346     (dump-object res file)
1347     (let ((res-handle (dump-pop file)))
1348       (dolist (info-handle (fasl-file-debug-info file))
1349         (dump-push res-handle file)
1350         (dump-fop 'sb!impl::fop-structset file)
1351         (dump-unsigned-32 info-handle file)
1352         (dump-unsigned-32 2 file))))
1353
1354   (setf (fasl-file-debug-info file) ())
1355   (values))
1356 \f
1357 ;;;; dumping structures
1358
1359 (defun dump-structure (struct file)
1360   (when *dump-only-valid-structures*
1361     (unless (gethash struct (fasl-file-valid-structures file))
1362       (error "attempt to dump invalid structure:~%  ~S~%How did this happen?"
1363              struct)))
1364   (note-potential-circularity struct file)
1365   (do ((index 0 (1+ index))
1366        (length (%instance-length struct))
1367        (circ (fasl-file-circularity-table file)))
1368       ((= index length)
1369        (dump-fop* length
1370                   sb!impl::fop-small-struct
1371                   sb!impl::fop-struct
1372                   file))
1373     (let* ((obj (%instance-ref struct index))
1374            (ref (gethash obj circ)))
1375       (cond (ref
1376              (push (make-circularity :type :struct-set
1377                                      :object struct
1378                                      :index index
1379                                      :value obj
1380                                      :enclosing-object ref)
1381                    *circularities-detected*)
1382              (sub-dump-object nil file))
1383             (t
1384              (sub-dump-object obj file))))))
1385
1386 (defun dump-layout (obj file)
1387   (when (layout-invalid obj)
1388     (compiler-error "attempt to dump reference to obsolete class: ~S"
1389                     (layout-class obj)))
1390   (let ((name (sb!xc:class-name (layout-class obj))))
1391     (unless name
1392       (compiler-error "dumping anonymous layout: ~S" obj))
1393     (dump-fop 'sb!impl::fop-normal-load file)
1394     (let ((*cold-load-dump* t))
1395       (dump-object name file))
1396     (dump-fop 'sb!impl::fop-maybe-cold-load file))
1397   (sub-dump-object (layout-inherits obj) file)
1398   (sub-dump-object (layout-depthoid obj) file)
1399   (sub-dump-object (layout-length obj) file)
1400   (dump-fop 'sb!impl::fop-layout file))