1 ;;;; stuff that knows about dumping FASL files
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;;; fasl dumper state
16 ;;; The FASL-OUTPUT structure represents everything we need to
17 ;;; know about dumping to a fasl file. (We need to objectify the
18 ;;; state because the fasdumper must be reentrant.)
19 (defstruct (fasl-output
20 (:print-object
(lambda (x s
)
21 (print-unreadable-object (x s
:type t
)
22 (prin1 (namestring (fasl-output-stream x
))
25 ;; the stream we dump to
26 (stream (missing-arg) :type stream
)
27 ;; scratch space for computing varint encodings
28 ;; FIXME: can't use the theoretical max of 10 bytes
29 ;; due to constraint in WRITE-VAR-INTEGER.
30 (varint-buf (make-array 10 :element-type
'(unsigned-byte 8) :fill-pointer t
))
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 ;; SIMILAR-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 pathologies with objects for which SIMILAR
36 ;; degenerates to EQL. Everything entered in the SIMILAR table is
37 ;; also entered in the EQ table.
38 (similar-table (make-similarity-table) :type hash-table
:read-only t
)
39 (eq-table (make-hash-table :test
'eq
) :type hash-table
:read-only t
)
40 ;; the INSTANCE table maps dumpable instances to unique IDs for calculating
41 ;; a similarity hash of composite objects that contain instances.
42 ;; A user-defined hash function can not use address-based hashing, and it is
43 ;; better not to add a new lazy stable hash slot to instances as a
44 ;; side-effect of compiling.
45 (instance-id-table (make-hash-table :test
'eq
) :type hash-table
:read-only t
)
46 ;; Hashtable mapping a string to a list of fop-table indices of
47 ;; symbols whose name is that string. For any name as compared
48 ;; by STRING= there can be a symbol whose name is a base string
49 ;; and/or a symbol whose name is not a base string.
50 (string=-table
(make-hash-table :test
'equal
) :type hash-table
)
51 ;; the fasloader table's current free pointer: the next offset to be used
52 (table-free 0 :type index
)
53 ;; an alist (PACKAGE . OFFSET) of the table offsets for each package
54 ;; we have currently located.
55 (packages () :type list
)
56 ;; a table mapping from the ENTRY-INFO structures for dumped XEPs to
57 ;; the table offsets of the corresponding code pointers
58 (entry-table (make-hash-table :test
'eq
) :type hash-table
)
59 ;; a table holding back-patching info for forward references to XEPs.
60 ;; The key is the ENTRY-INFO structure for the XEP, and the value is
61 ;; a list of conses (<code-handle> . <offset>), where <code-handle>
62 ;; is the offset in the table of the code object needing to be
63 ;; patched, and <offset> is the offset that must be patched.
64 (patch-table (make-hash-table :test
'eq
) :type hash-table
)
65 ;; a list of the table handles for all of the DEBUG-INFO structures
66 ;; dumped in this file. These structures must be back-patched with
67 ;; source location information when the compilation is complete.
68 (debug-info () :type list
)
69 ;; This is used to keep track of objects that we are in the process
70 ;; of dumping so that circularities can be preserved. The key is the
71 ;; object that we have previously seen, and the value is the object
72 ;; that we reference in the table to find this previously seen
73 ;; object. (The value is never NIL.)
75 ;; Except with list objects, the key and the value are always the
76 ;; same. In a list, the key will be some tail of the value.
77 (circularity-table (make-hash-table :test
'eq
) :type hash-table
)
78 ;; a hash table of structures that are allowed to be dumped. If we
79 ;; try to dump a structure that isn't in this hash table, we lose.
80 (valid-structures (make-hash-table :test
'eq
) :type hash-table
)
81 ;; a hash table of slots to be saved when dumping an instance.
82 (saved-slot-names (make-hash-table :test
'eq
) :type hash-table
))
83 (declaim (freeze-type fasl-output
))
85 ;;; Similarity hash table logic.
86 ;;; It really seems bogus to me that we do similarity checking in both
87 ;;; the IR1 namespace and the fasl dumper, even going so far as to use
88 ;;; two different ways to decide that an object is "harmless" to look up
89 ;;; (i.e. has no cyclic references).
94 ;; Do almost the same thing that EQUAL does, but:
95 ;; - consider strings to be dissimilar if their element types differ.
96 ;; - scan elements of all specialized numeric vectors (BIT is done by EQUAL)
97 (named-let recurse
((x x
) (y y
))
102 (recurse (car x
) (car y
))
103 (recurse (cdr x
) (cdr y
))))
105 ;; Incidentally, if we want to preserve non-simpleness of dumped arrays
106 ;; (which is permissible but not required), this case (and below for arrays)
107 ;; would be where to do it by returning non-similar.
109 ;; (= (widetag-of ...)) would be too strict, because a simple string
110 ;; can be be similar to a non-simple string.
111 (eq (array-element-type x
)
112 (array-element-type y
))
114 ((or pathname bit-vector
) ; fall back to EQUAL
115 ;; This could be slightly wrong, but so it always was, because we use
116 ;; (and have used) EQUAL for PATHNAME in FIND-CONSTANT, but:
117 ;; "Two pathnames S and C are similar if all corresponding pathname components are similar."
118 ;; and we readily admit that similarity of strings requires equal element types.
119 ;; So this is slightly dubious:
120 ;; (EQUAL (MAKE-PATHNAME :NAME (COERCE "A" 'SB-KERNEL:SIMPLE-CHARACTER-STRING))
121 ;; (MAKE-PATHNAME :NAME (COERCE "A" 'BASE-STRING))) => T
122 ;; On the other hand, nothing says that the pathname constructors such as
123 ;; MAKE-PATHNAME and MERGE-PATHNAMES don't convert to a canonical representation
124 ;; which renders them EQUAL when all strings are STRING=.
125 ;; This area of the language spec seems to have been a clusterfsck.
127 ;; We would need to enhance COALESCE-TREE-P to detect cycles involving
128 ;; SIMPLE-VECTOR before recursing, otherwise this could exhaust stack.
130 (and (sb-xc:typep y
'(simple-array * 1))
131 (= (length x
) (length y
))
132 (equal (array-element-type x
) (array-element-type y
))
133 (or (typep x
'(array nil
(*)))
134 (dotimes (i (length x
) t
)
135 (unless (= (aref x i
) (aref y i
)) (return nil
))))))
136 ;; How do SIMPLE-VECTOR and other array types get here?
137 ;; Answer: COALESCE-TREE-P is "weaker than" the the local COALESCE-P function in FIND-CONSTANT,
138 ;; so it may return T on trees that contain atoms that COALESCE-P would have returned NIL on.
139 ;; Therefore DUMP-NON-IMMEDIATE-OBJECT may call SIMILARP on an object for which COALESCE-P
140 ;; would have said NIL.
141 ;; As mentioned at the top of this file, this seems incredibly bad,
142 ;; But users do not tend to have object cycles involving SIMPLE-VECTOR and such, I guess?
143 ;; Anyway, the answer has to be "no" for everything else: un-EQL objects are not similar.
145 ;; This hash function is an amalgam of SXHASH and PSHASH with the following properties:
146 ;; - numbers must have the same type to be similar (same as SXHASH)
147 ;; - instances must be EQ to be similar (same as SXHASH)
148 ;; - strings and characters are compared case-sensitively (same as SXHASH)
149 ;; - arrays must have the same type to be similar
150 ;; Unlike EQUAL-HASH, we never call EQ-HASH, because there is generally no reason
151 ;; to try to look up an object that lacks a content-based hash value.
152 (defun similar-hash (x)
153 (declare (special *compile-object
*))
154 (named-let recurse
((x x
))
155 ;; There is no depth cutoff - X must not be circular,
156 ;; which was already determined as a precondition to calling this,
157 ;; except that as pointed out, we must not descend into simple-vector
158 ;; because there was no circularity checking done for arrays.
161 ((atom x
) (mix (if x
(recurse x
) #xD00F
) hash
))
162 ;; mix the hash of the CARs only, without consuming stack
163 ;; proportional to list length.
164 (setf hash
(mix (recurse (car x
)) hash
)
167 (number (sb-impl::number-sxhash x
))
168 (pathname (sb-impl::pathname-sxhash x
))
170 (let ((idmap (fasl-output-instance-id-table *compile-object
*)))
171 (values (ensure-gethash x idmap
172 (let ((c (1+ (hash-table-count idmap
))))
174 ;; Arrays disregard simplicity.
175 ((array nil
(*)) #xdead
) ; don't access the data in these bastards
177 (let* ((simple-array (coerce x
'(simple-array * (*))))
178 (widetag (%other-pointer-widetag simple-array
))
179 (saetp (find widetag sb-vm
:*specialized-array-element-type-properties
*
180 :key
#'sb-vm
:saetp-typecode
))
181 (n-data-words (ceiling (sb-vm::vector-n-data-octets simple-array saetp
)
183 (hash (word-mix (length x
) widetag
)))
184 (declare (word hash
))
185 (dotimes (i n-data-words
(logand hash most-positive-fixnum
))
186 ;; FIXME: the last word of {1,2,4}-bit-per-element vectors
187 ;; needs to be masked. At worst, this fails to coalesce
188 ;; similar vectors, so it's not fatal.
189 (setq hash
(word-mix hash
(%vector-raw-bits x i
))))))
190 (character (char-code x
))
192 (defun make-similarity-table ()
193 (make-hash-table :hash-function
#'similar-hash
:test
#'similarp
))
196 ;;; When cross-compiling, it's good enough to approximate similarity as EQUAL.
198 (defun make-similarity-table () (make-hash-table :test
'equal
))
200 (defmacro get-similar
(key table
) `(gethash ,key
,table
))
202 ;;; This structure holds information about a circularity.
203 (defstruct (circularity (:copier nil
))
204 ;; the kind of modification to make to create circularity
205 (type (missing-arg) :type
(member :rplaca
:rplacd
:svset
:struct-set
:slot-set
))
206 ;; the object containing circularity
208 ;; index in object for circularity
209 (index (missing-arg) :type index
)
210 ;; slot name in object for circularity
211 (slot-name nil
:type symbol
)
212 ;; the object to be stored at INDEX in OBJECT. This is that the key
213 ;; that we were using when we discovered the circularity.
215 ;; the value that was associated with VALUE in the
216 ;; CIRCULARITY-TABLE. This is the object that we look up in the
217 ;; EQ-TABLE to locate VALUE.
220 ;;; a list of the CIRCULARITY structures for all of the circularities
221 ;;; detected in the current top level call to DUMP-OBJECT. Setting
222 ;;; this lobotomizes circularity detection as well, since circular
223 ;;; dumping uses the table.
224 (defvar *circularities-detected
*)
228 ;;; Write the byte B to the specified FASL-OUTPUT stream.
229 (defun dump-byte (b fasl-output
)
230 (declare (type (unsigned-byte 8) b
) (type fasl-output fasl-output
))
231 (write-byte b
(fasl-output-stream fasl-output
)))
233 ;; Dump a word-sized integer.
234 (defun dump-word (num fasl-output
)
235 (declare (type sb-vm
:word num
) (type fasl-output fasl-output
))
236 (let ((stream (fasl-output-stream fasl-output
)))
237 (dotimes (i sb-vm
:n-word-bytes
)
238 (write-byte (ldb (byte 8 (* 8 i
)) num
) stream
))))
240 ;; Dump a 32-bit integer.
241 (defun dump-unsigned-byte-32 (num fasl-output
)
242 (declare (type (unsigned-byte 32) num
) (type fasl-output fasl-output
))
243 (let ((stream (fasl-output-stream fasl-output
)))
245 (write-byte (ldb (byte 8 (* 8 i
)) num
) stream
))))
247 ;;; Dump NUM to the fasl stream, represented by N bytes. This works
248 ;;; for either signed or unsigned integers. There's no range checking
249 ;;; -- if you don't specify enough bytes for the number to fit, this
250 ;;; function cheerfully outputs the low bytes.
251 ;;; Multi-byte integers written by this function are always little-endian.
252 (defun dump-integer-as-n-bytes (num bytes fasl-output
)
253 (declare (integer num
) (type index bytes
))
254 (declare (type fasl-output fasl-output
))
255 (do ((n num
(ash n -
8))
258 (declare (type index i
))
259 (dump-byte (logand n
#xff
) fasl-output
))
262 (defun dump-varint (n fasl-output
)
263 (let ((buf (fasl-output-varint-buf fasl-output
)))
264 (setf (fill-pointer buf
) 0)
265 (write-var-integer n buf
)
266 (write-sequence buf
(fasl-output-stream fasl-output
))))
268 (defun dump-fop+operands
(fasl-output opcode arg1
269 &optional
(arg2 0 arg2p
) (arg3 0 arg3p
))
270 (declare (type (unsigned-byte 8) opcode
) (type word arg1 arg2 arg3
))
271 (dump-byte opcode fasl-output
)
272 (dump-varint arg1 fasl-output
)
273 (when arg2p
(dump-varint arg2 fasl-output
))
274 (when arg3p
(dump-varint arg3 fasl-output
)))
276 ;;; Dump the FOP code for the named FOP to the specified FASL-OUTPUT.
277 ;;; This macro is supposed to look functional in that it evals its
278 ;;; args, but it wants to evaluate the first arg at compile-time. For
279 ;;; this reason it should really not be a quoted symbol, but I think
280 ;;; this used to actually be a function which had to look up the fop's
281 ;;; opcode every time called. The named FOP is also treated as a string
282 ;;; designator which is interned in the package defining the FOPs.
283 (defmacro dump-fop
(fop-symbol file
&rest args
)
285 ;; EVAL is too much. Just ascertain we have a quoted symbol
286 (if (typep fop-symbol
'(cons (eql quote
) (cons symbol null
)))
288 (error "Bad 1st arg to DUMP-FOP: ~S" fop-symbol
)))
289 (val (or (gethash (intern (symbol-name fop-symbol
) #.
(find-package "SB-FASL"))
290 *fop-name-to-opcode
*)
291 (error "compiler bug: ~S is not a legal fasload operator."
293 (fop-argc (aref (car **fop-signatures
**) val
)))
295 ((not (eql (length args
) fop-argc
))
296 (error "~S takes ~D argument~:P" fop-symbol fop-argc
))
298 `(dump-byte ,val
,file
))
300 `(dump-fop+operands
,file
,val
,@args
)))))
302 ;;; Push the object at table offset Handle on the fasl stack.
303 (defun dump-push (handle fasl-output
)
304 (declare (type index handle
) (type fasl-output fasl-output
))
305 (dump-fop 'fop-push fasl-output handle
)
308 ;;; Pop the object currently on the fasl stack top into the table, and
309 ;;; return the table index, incrementing the free pointer.
310 (defun dump-pop (fasl-output)
312 (fasl-output-table-free fasl-output
)
313 (dump-fop 'fop-pop fasl-output
)
314 (incf (fasl-output-table-free fasl-output
))))
316 (defun dump-to-table (fasl-output)
318 (fasl-output-table-free fasl-output
)
319 (dump-fop 'fop-move-to-table fasl-output
)
320 (incf (fasl-output-table-free fasl-output
))))
322 (defun cdr-similarity-p (index fasl-output
)
324 (destructuring-bind (list . nthcdr
) index
325 (let ((index (gethash list
(fasl-output-eq-table fasl-output
))))
326 (when (fixnump index
)
327 (dump-push index fasl-output
)
328 (dump-fop 'fop-nthcdr fasl-output nthcdr
)
331 ;;; If X is in File's SIMILAR-TABLE, then push the object and return T,
333 (defun similar-check-table (x fasl-output
)
334 (declare (type fasl-output fasl-output
))
335 (let ((index (get-similar x
(fasl-output-similar-table fasl-output
))))
336 (cond ((fixnump index
)
337 (dump-push index fasl-output
)
339 ((cdr-similarity-p index fasl-output
)))))
341 ;;; These functions are called after dumping an object to save the
342 ;;; object in the table. The object (also passed in as X) must already
343 ;;; be on the top of the FOP stack.
344 (defun eq-save-object (x fasl-output
)
345 (declare (type fasl-output fasl-output
))
346 (setf (gethash x
(fasl-output-eq-table fasl-output
))
347 (dump-to-table fasl-output
))
349 (defun similar-save-object (x fasl-output
)
350 (declare (type fasl-output fasl-output
))
351 (let ((handle (dump-to-table fasl-output
)))
352 (setf (get-similar x
(fasl-output-similar-table fasl-output
)) handle
)
353 (setf (gethash x
(fasl-output-eq-table fasl-output
)) handle
))
355 ;;; Record X in File's CIRCULARITY-TABLE. This is called on objects
356 ;;; that we are about to dump might have a circular path through them.
358 ;;; The object must not currently be in this table, since the dumper
359 ;;; should never be recursively called on a circular reference.
360 ;;; Instead, the dumping function must detect the circularity and
361 ;;; arrange for the dumped object to be patched.
362 (defun note-potential-circularity (x fasl-output
)
363 (let ((circ (fasl-output-circularity-table fasl-output
)))
364 (aver (not (gethash x circ
)))
365 (setf (gethash x circ
) x
))
368 ;;;; opening and closing fasl files
370 ;;; Open a fasl file, write its header, and return a FASL-OUTPUT
371 ;;; object for dumping to it. Some human-readable information about
372 ;;; the source code is given by the string WHERE.
373 (defun open-fasl-output (name where
)
374 (declare (type pathname name
))
375 (flet ((fasl-write-string (string stream
)
376 ;; UTF-8 is safe to use, because +FASL-HEADER-STRING-STOP-CHAR-CODE+
377 ;; may not appear in UTF-8 encoded bytes
378 (write-sequence (string-to-octets string
:external-format
:utf-8
)
380 (let* ((stream (open name
382 :if-exists
:supersede
383 :element-type
'sb-assem
:assembly-unit
))
384 (res (make-fasl-output :stream stream
)))
385 ;; Before the actual FASL header, write a shebang line using the current
386 ;; runtime path, so our fasls can be executed directly from the shell.
387 #-sb-xc-host
; cross-compiled fasls are not directly executable
388 (when *runtime-pathname
*
390 (format nil
"#!~A --script~%"
391 (native-namestring *runtime-pathname
* :as-file t
))
393 ;; Begin the header with the constant machine-readable (and
394 ;; semi-human-readable) string which is used to identify fasl files.
395 (fasl-write-string *fasl-header-string-start-string
* stream
)
396 ;; The constant string which begins the header is followed by
397 ;; arbitrary human-readable text, terminated by
398 ;; +FASL-HEADER-STRING-STOP-CHAR-CODE+.
400 (with-standard-io-syntax
401 (let ((*print-readably
* nil
)
402 (*print-pretty
* nil
))
406 using ~A version ~A~%"
408 (lisp-implementation-type)
409 (lisp-implementation-version))))
411 (dump-byte +fasl-header-string-stop-char-code
+ res
)
412 ;; Finish the header by outputting fasl file implementation,
413 ;; version, and key *FEATURES*.
414 (flet ((dump-counted-string (string)
415 ;; The count is dumped as a 32-bit unsigned-byte even on 64-bit
416 ;; platforms. This ensures that a x86-64 SBCL can gracefully
417 ;; detect an error when trying to read a x86 fasl, instead
418 ;; of choking on a ridiculously long counted string.
419 ;; -- JES, 2005-12-30
420 (dump-unsigned-byte-32 (length string
) res
)
421 (dotimes (i (length string
))
422 (dump-byte (char-code (aref string i
)) res
))))
423 (dump-counted-string (symbol-name +backend-fasl-file-implementation
+))
424 (dump-word +fasl-file-version
+ res
)
425 (dump-counted-string (lisp-implementation-version))
426 (dump-counted-string (compute-features-affecting-fasl-format)))
429 ;;; Close the specified FASL-OUTPUT, aborting the write if ABORT-P.
430 (defun close-fasl-output (fasl-output abort-p
)
431 (declare (type fasl-output fasl-output
))
435 (aver (zerop (hash-table-count (fasl-output-patch-table fasl-output
))))
437 (dump-fop 'fop-end-group fasl-output
(fasl-output-table-free fasl-output
)))
439 ;; That's all, folks.
440 (close (fasl-output-stream fasl-output
) :abort abort-p
)
443 ;;;; main entries to object dumping
445 ;;; This function deals with dumping objects that are complex enough
446 ;;; so that we want to cache them in the table, rather than repeatedly
447 ;;; dumping them. If the object is in the EQ-TABLE, then we push it,
448 ;;; otherwise, we do a type dispatch to a type specific dumping
449 ;;; function. The type specific branches do any appropriate
450 ;;; SIMILAR-TABLE check and table entry.
452 ;;; When we go to dump the object, we enter it in the CIRCULARITY-TABLE.
453 (defun dump-non-immediate-object (x file
)
454 (let ((index (gethash x
(fasl-output-eq-table file
))))
455 (cond ((fixnump index
)
456 (dump-push index file
))
457 ((cdr-similarity-p index file
))
460 (symbol (dump-symbol x file
))
462 (cond ((not (coalesce-tree-p x
))
464 (eq-save-object x file
))
465 ((not (similar-check-table x file
))
467 (similar-save-object x file
))))
470 (eq-save-object x file
))
473 (aver (not (classoid-p x
)))
474 (dump-object 'values-specifier-type file
)
475 (dump-object (type-specifier x
) file
)
476 (dump-fop 'fop-funcall file
1))
478 (multiple-value-bind (slot-names slot-names-p
)
479 (gethash x
(fasl-output-saved-slot-names file
))
481 (dump-instance-saving-slots x slot-names file
)
482 (dump-structure x file
)))
483 (eq-save-object x file
))
485 ;; DUMP-ARRAY (and its callees) are responsible for
486 ;; updating the EQ and SIMILAR hash tables.
489 (unless (similar-check-table x file
)
491 (ratio (dump-ratio x file
))
492 (complex (dump-complex x file
))
493 (float (dump-float x file
))
494 (integer (dump-integer x file
)))
495 (similar-save-object x file
)))
496 #+(and (not sb-xc-host
) sb-simd-pack
)
498 (unless (similar-check-table x file
)
499 (dump-fop 'fop-simd-pack file
)
500 (dump-integer-as-n-bytes (%simd-pack-tag x
) 8 file
)
501 (dump-integer-as-n-bytes (%simd-pack-low x
) 8 file
)
502 (dump-integer-as-n-bytes (%simd-pack-high x
) 8 file
)
503 (similar-save-object x file
)))
504 #+(and (not sb-xc-host
) sb-simd-pack-256
)
506 (unless (similar-check-table x file
)
507 (dump-simd-pack-256 x file
)
508 (similar-save-object x file
)))
510 ;; This probably never happens, since bad things tend to
511 ;; be detected during IR1 conversion.
512 (error "This object cannot be dumped into a fasl file:~% ~S"
516 #+(and (not sb-xc-host
) sb-simd-pack-256
)
517 (defun dump-simd-pack-256 (x file
)
518 (dump-fop 'fop-simd-pack file
)
519 (dump-integer-as-n-bytes (logior (%simd-pack-256-tag x
) (ash 1 6)) 8 file
)
520 (dump-integer-as-n-bytes (%simd-pack-256-0 x
) 8 file
)
521 (dump-integer-as-n-bytes (%simd-pack-256-1 x
) 8 file
)
522 (dump-integer-as-n-bytes (%simd-pack-256-2 x
) 8 file
)
523 (dump-integer-as-n-bytes (%simd-pack-256-3 x
) 8 file
))
525 ;;; Dump an object of any type by dispatching to the correct
526 ;;; type-specific dumping function. We pick off immediate objects,
527 ;;; symbols and magic lists here. Other objects are handled by
528 ;;; DUMP-NON-IMMEDIATE-OBJECT.
530 ;;; This is the function used for recursive calls to the fasl dumper.
531 ;;; We don't worry about creating circularities here, since it is
532 ;;; assumed that there is a top level call to DUMP-OBJECT.
533 (defun sub-dump-object (x file
)
536 (dump-non-immediate-object x file
)
537 (dump-fop 'fop-empty-list file
)))
540 (dump-fop 'fop-truth file
)
541 (dump-non-immediate-object x file
)))
542 ((fixnump x
) (dump-integer x file
))
544 (dump-fop 'fop-character file
(char-code x
)))
546 (dump-push (dump-package x file
) file
))
548 ((system-area-pointer-p x
)
549 (dump-fop 'fop-word-pointer file
)
550 (dump-integer-as-n-bytes (sap-int x
) sb-vm
:n-word-bytes file
))
552 (dump-non-immediate-object x file
))))
554 ;;; Dump stuff to backpatch already dumped objects. INFOS is the list
555 ;;; of CIRCULARITY structures describing what to do. The patching FOPs
556 ;;; take the value to store on the stack. We compute this value by
557 ;;; fetching the enclosing object from the table, and then CDR'ing it
559 (defun dump-circularities (infos file
)
560 (let ((table (fasl-output-eq-table file
)))
563 (let* ((value (circularity-value info
))
564 (enclosing (circularity-enclosing-object info
)))
565 (dump-push (gethash enclosing table
) file
)
566 (unless (eq enclosing value
)
567 (do ((current enclosing
(cdr current
))
570 (dump-fop 'fop-nthcdr file i
))
571 (declare (type index i
)))))
573 (macrolet ((fop-op (symbol)
574 (gethash (intern (symbol-name symbol
) "SB-FASL")
575 *fop-name-to-opcode
*)))
576 (dump-byte (ecase (circularity-type info
)
577 (:rplaca
(fop-op fop-rplaca
))
578 (:rplacd
(fop-op fop-rplacd
))
579 (:svset
(fop-op fop-svset
))
580 (:struct-set
(fop-op fop-structset
))
582 (dump-object (circularity-slot-name info
) file
)
583 (fop-op fop-slotset
)))
585 (dump-varint (gethash (circularity-object info
) table
) file
)
586 (dump-varint (circularity-index info
) file
))))
588 ;;; Set up stuff for circularity detection, then dump an object. All
589 ;;; shared and circular structure will be exactly preserved within a
590 ;;; single call to DUMP-OBJECT. Sharing between objects dumped by
591 ;;; separate calls is only preserved when convenient.
593 ;;; We peek at the object type so that we only pay the circular
594 ;;; detection overhead on types of objects that might be circular.
595 (defun dump-object (x file
)
596 (if (compound-object-p x
)
597 (let ((*circularities-detected
* ())
598 (circ (fasl-output-circularity-table file
)))
600 (sub-dump-object x file
)
601 (when *circularities-detected
*
602 (dump-circularities *circularities-detected
* file
)
604 (sub-dump-object x file
)))
606 ;;;; LOAD-TIME-VALUE and MAKE-LOAD-FORM support
608 ;;; Emit a funcall of the function and return the handle for the
610 (defun fasl-dump-load-time-value-lambda (fun file
)
611 (declare (type clambda fun
) (type fasl-output file
))
612 (let ((handle (gethash (leaf-info fun
)
613 (fasl-output-entry-table file
))))
615 (dump-push handle file
)
616 (dump-fop 'fop-funcall file
0))
619 ;;; Return T iff CONSTANT has already been dumped. It's been dumped if
620 ;;; it's in the EQ table.
622 ;;; Note: historically (1) the above comment was "T iff ... has not been dumped",
623 ;;; (2) the test was was also true if the constant had been validated / was in
624 ;;; the valid objects table. This led to substructures occasionally skipping the
625 ;;; validation, and hence failing the "must have been validated" test.
626 (defun fasl-constant-already-dumped-p (constant file
)
627 (and (gethash constant
(fasl-output-eq-table file
)) t
))
629 ;;; Use HANDLE whenever we try to dump CONSTANT. HANDLE should have been
630 ;;; returned earlier by FASL-DUMP-LOAD-TIME-VALUE-LAMBDA.
631 (defun fasl-note-handle-for-constant (constant handle file
)
632 (let ((table (fasl-output-eq-table file
)))
633 (when (gethash constant table
)
634 (error "~S already dumped?" constant
))
635 (setf (gethash constant table
) handle
))
638 ;;; Note that the specified structure can just be dumped by
639 ;;; enumerating the slots.
640 (defun fasl-validate-structure (structure file
)
641 (setf (gethash structure
(fasl-output-valid-structures file
)) t
)
644 ;;; Note that the specified standard object can just be dumped by
645 ;;; saving its slot values.
646 (defun fasl-note-instance-saves-slots (instance slot-names file
)
647 (setf (gethash instance
(fasl-output-saved-slot-names file
)) slot-names
)
652 (defun dump-ratio (x file
)
653 (sub-dump-object (numerator x
) file
)
654 (sub-dump-object (denominator x
) file
)
655 (dump-fop 'fop-ratio file
))
657 (defun dump-integer (n file
)
661 (0 (dump-fop 'fop-int-const0 file
))
662 (1 (dump-fop 'fop-int-const1 file
))
663 (2 (dump-fop 'fop-int-const2 file
))
664 (-1 (dump-fop 'fop-int-const-neg1 file
))
665 (t (dump-fop 'fop-byte-integer file
)
666 (dump-byte (logand #xFF n
) file
))))
667 ((unsigned-byte #.
(1- sb-vm
:n-word-bits
))
668 (dump-fop 'fop-word-integer file
)
671 (dump-fop 'fop-word-integer file
)
672 (dump-integer-as-n-bytes n sb-vm
:n-word-bytes file
))
674 (let ((bytes (ceiling (1+ (integer-length n
)) 8)))
675 (dump-fop 'fop-integer file bytes
)
676 (dump-integer-as-n-bytes n bytes file
)))))
678 (defun dump-float (x file
)
681 (dump-fop 'fop-single-float file
)
682 (dump-integer-as-n-bytes (single-float-bits x
) 4 file
))
684 (dump-fop 'fop-double-float file
)
685 (dump-integer-as-n-bytes (double-float-low-bits x
) 4 file
)
686 (dump-integer-as-n-bytes (double-float-high-bits x
) 4 file
))
689 (dump-fop 'fop-long-float file
)
690 (dump-long-float x file
))))
692 (defun dump-complex (x file
)
693 (let ((re (realpart x
))
696 ((complex single-float
)
697 (dump-fop 'fop-complex-single-float file
)
698 (dump-integer-as-n-bytes (single-float-bits re
) 4 file
)
699 (dump-integer-as-n-bytes (single-float-bits im
) 4 file
))
700 ((complex double-float
)
701 (dump-fop 'fop-complex-double-float file
)
702 (dump-integer-as-n-bytes (double-float-low-bits re
) 4 file
)
703 (dump-integer-as-n-bytes (double-float-high-bits re
) 4 file
)
704 (dump-integer-as-n-bytes (double-float-low-bits im
) 4 file
)
705 (dump-integer-as-n-bytes (double-float-high-bits im
) 4 file
))
707 ((complex long-float
)
708 (dump-fop 'fop-complex-long-float file
)
709 (dump-long-float re file
)
710 (dump-long-float im file
))
712 (sub-dump-object re file
)
713 (sub-dump-object im file
)
714 (dump-fop 'fop-complex file
)))))
718 ;;; Return the table index of PKG, adding the package to the table if
719 ;;; necessary. During cold load, we read the string as a normal string
720 ;;; so that we can do the package lookup at cold load time.
722 ;;; FIXME: Despite the parallelism in names, the functionality of
723 ;;; this function is not parallel to other functions DUMP-FOO, e.g.
724 ;;; DUMP-SYMBOL and DUMP-LIST. The mapping between names and behavior
725 ;;; should be made more consistent.
726 (declaim (ftype (function (package fasl-output
) index
) dump-package
))
727 (defun dump-package (pkg file
)
728 (declare (inline assoc
))
729 (cond ((cdr (assoc pkg
(fasl-output-packages file
) :test
#'eq
)))
731 (let ((s (sb-xc:package-name pkg
)))
732 (dump-fop 'fop-named-package-save file
(length s
))
733 ;; Package names are always dumped as varint-encoded character strings
734 ;; except on non-unicode builds.
735 (dump-chars (coerce s
'(simple-array character
(*))) file nil
))
736 (let ((entry (fasl-output-table-free file
)))
737 (incf (fasl-output-table-free file
))
738 (push (cons pkg entry
) (fasl-output-packages file
))
743 ;;; Dump a list, setting up patching information when there are
744 ;;; circularities. We scan down the list, checking for CDR and CAR
747 ;;; If there is a CDR circularity, we terminate the list with NIL and
748 ;;; make a CIRCULARITY notation for the CDR of the previous cons.
750 ;;; If there is no CDR circularity, then we mark the current cons and
751 ;;; check for a CAR circularity. When there is a CAR circularity, we
752 ;;; make the CAR NIL initially, arranging for the current cons to be
755 ;;; Otherwise, we recursively call the dumper to dump the current
757 (defun dump-list (list file
&optional coalesce
)
759 (not (gethash list
(fasl-output-circularity-table file
)))))
760 (let ((circ (fasl-output-circularity-table file
)))
761 (flet ((cdr-circularity (obj n
)
762 ;; COALESCE means there's no cycles
763 (let ((ref (gethash obj circ
)))
765 (push (make-circularity :type
:rplacd
769 :enclosing-object ref
)
770 *circularities-detected
*)
771 (terminate-undotted-list n file
)
773 (do* ((l list
(cdr l
))
777 (terminate-undotted-list n file
))
779 (cond ((cdr-circularity l n
))
781 (sub-dump-object l file
)
782 (terminate-dotted-list n file
))))))
783 (declare (type index n
))
784 (when (cdr-circularity l n
)
787 ;; if this CONS is EQ to some other object we have already
788 ;; dumped, dump a reference to that instead.
789 (let* ((table (if coalesce
790 (fasl-output-similar-table file
)
791 (fasl-output-eq-table file
)))
792 (index (gethash l table
)))
793 (cond ((fixnump index
)
794 (dump-push index file
)
795 (terminate-dotted-list n file
)
797 ((cdr-similarity-p index file
)
799 (terminate-dotted-list n file
))
802 ;; put an entry for this cons into the fasl output cons table,
803 ;; for the benefit of dumping later constants
804 (let ((index (cons list n
)))
805 (setf (gethash l
(fasl-output-eq-table file
)) index
)
807 (setf (gethash l
(fasl-output-similar-table file
)) index
))))
809 (setf (gethash l circ
) list
)
812 (ref (gethash obj circ
)))
814 (push (make-circularity :type
:rplaca
818 :enclosing-object ref
)
819 *circularities-detected
*)
820 (sub-dump-object nil file
))
821 ;; Avoid coalescing if COALESCE-TREE-P decided not to
823 ;; This is the same as DUMP-NON-IMMEDIATE-OBJECT but
824 ;; without calling COALESCE-TREE-P again.
825 (let ((index (gethash obj
(fasl-output-eq-table file
))))
826 (cond ((fixnump index
)
827 (dump-push index file
))
828 ((cdr-similarity-p index file
))
831 (eq-save-object obj file
))
832 ((not (similar-check-table obj file
))
833 (dump-list obj file t
)
834 (similar-save-object obj file
)))))
836 (sub-dump-object obj file
))))))))
838 (defconstant fop-list-base-opcode
128)
840 (defun terminate-dotted-list (n file
)
841 (declare (type index n
) (type fasl-output file
))
844 (dump-byte (logior fop-list-base-opcode
#b10000 n
) file
))
846 (dump-byte (logior fop-list-base-opcode
#b10000
) file
)
847 (dump-varint (- n
16) file
))))
849 (defun terminate-undotted-list (n file
)
850 (declare (type index n
) (type fasl-output file
))
853 (dump-byte (logior fop-list-base-opcode n
) file
))
855 (dump-byte (logior fop-list-base-opcode
) file
)
856 (dump-varint (- n
16) file
))))
860 ;;; Dump the array thing.
861 (defun dump-array (x file
)
864 #-sb-xc-host
(dump-multi-dim-array x file
)
865 #+sb-xc-host
(bug "Can't dump multi-dim array")))
867 ;;; Dump the vector object. If it's not simple, then actually dump a
868 ;;; simple realization of it. But we enter the original in the EQ or SIMILAR
870 (defun dump-vector (x file
)
871 (let ((simple-version (if (array-header-p x
)
872 (coerce x
`(simple-array
873 ,(array-element-type x
)
876 (typecase simple-version
877 ;; On the host, take all strings to be simple-base-string.
878 ;; In the target, really test for simple-base-string.
879 (#+sb-xc-host simple-string
#-sb-xc-host simple-base-string
880 (unless (similar-check-table x file
)
881 (dump-fop 'fop-base-string file
(length simple-version
))
882 (dump-chars simple-version file t
)
883 (similar-save-object x file
)))
885 ((simple-array character
(*))
886 #-sb-unicode
(bug "how did we get here?")
887 (unless (similar-check-table x file
)
888 (dump-fop 'fop-character-string file
(length simple-version
))
889 (dump-chars simple-version file nil
)
890 (similar-save-object x file
)))
891 ;; SB-XC:SIMPLE-VECTOR will not match an array whose element type
892 ;; the host upgraded to T but whose expressed type was not T.
894 (dump-simple-vector simple-version file
)
895 (eq-save-object x file
)
896 (unless (eq x simple-version
)
897 ;; In case it has circularities that need to be patched
899 (setf (gethash simple-version
(fasl-output-eq-table file
))
900 (gethash x
(fasl-output-eq-table file
)))))
902 (unless (similar-check-table x file
)
903 (dump-specialized-vector simple-version file
)
904 (similar-save-object x file
))))))
906 ;;; Dump a SIMPLE-VECTOR, handling any circularities.
907 (defun dump-simple-vector (v file
)
908 (declare (type simple-vector v
) (type fasl-output file
))
909 (note-potential-circularity v file
)
910 (do ((index 0 (1+ index
))
912 (circ (fasl-output-circularity-table file
)))
914 (dump-fop 'fop-vector file length
))
915 (let* ((obj (aref v index
))
916 (ref (gethash obj circ
)))
918 (push (make-circularity :type
:svset
922 :enclosing-object ref
)
923 *circularities-detected
*)
924 (sub-dump-object nil file
))
926 (sub-dump-object obj file
))))))
928 (defun dump-specialized-vector (vector file
&key data-only
)
929 ;; The DATA-ONLY option was for the now-obsolete trace-table,
930 ;; but it seems like a good option to keep around.
931 #-sb-xc-host
(declare (type (simple-unboxed-array (*)) vector
))
932 (let* ((length (length vector
))
933 (widetag (%other-pointer-widetag vector
))
934 (bits-per-elt (sb-vm::simple-array-widetag-
>bits-per-elt widetag
)))
936 ;; fop-spec-vector doesn't grok trailing #\null convention.
937 (aver (and (/= widetag sb-vm
:simple-base-string-widetag
)
938 (/= widetag sb-vm
:simple-vector-widetag
)))
939 (dump-fop 'fop-spec-vector file length
)
940 (dump-byte widetag file
))
943 (when (or (= widetag sb-vm
:simple-array-fixnum-widetag
)
944 (= widetag sb-vm
:simple-array-unsigned-fixnum-widetag
))
945 ;; Fixnum vector contents are tagged numbers. Make a copy.
946 (setq vector
(map 'vector
(lambda (x) (ash x sb-vm
:n-fixnum-tag-bits
))
949 ;; cross-io doesn't know about fasl streams, so use actual stream.
950 (sb-impl::buffer-output
(fasl-output-stream file
)
953 (ceiling (* length bits-per-elt
) sb-vm
:n-byte-bits
)
954 #+sb-xc-host bits-per-elt
)))
956 ;;; Dump string-ish things.
958 ;;; Dump a SIMPLE-STRING.
959 (defun dump-chars (s fasl-output base-string-p
)
960 (declare (type simple-string s
))
961 (if (or base-string-p
#-sb-unicode t
) ; if non-unicode, every char is 1 byte
963 (dump-byte (char-code c
) fasl-output
))
964 (dovector (c s
) ; varint (a/k/a LEB128) is better for this than UTF-8.
965 (dump-varint (char-code c
) fasl-output
))))
967 ;;; If we get here, it is assumed that the symbol isn't in the table,
968 ;;; but we are responsible for putting it there when appropriate.
969 (defun dump-symbol (s file
)
970 (declare (type fasl-output file
))
971 (let* ((pname (symbol-name s
))
972 (pname-length (length pname
))
973 ;; If no unicode, then all strings are base-string-p.
974 ;; On the host, everything is base-string-p.
975 (base-string-p (and #-sb-xc-host
(typep pname
'base-string
)))
976 (length+flag
(logior (ash pname-length
1) (if base-string-p
1 0)))
978 (pkg (sb-xc:symbol-package s
)))
980 (let ((this-base-p base-string-p
))
981 (dolist (lookalike (gethash pname
(fasl-output-string=-table file
))
982 (dump-fop 'fop-uninterned-symbol-save
984 ;; Find the right kind of lookalike symbol.
985 ;; [what about a symbol whose name is a (simple-array nil (0))?]
987 (and #-sb-xc-host
(typep (symbol-name lookalike
) 'base-string
))))
988 (when (or (and this-base-p that-base-p
)
989 (and (not this-base-p
) (not that-base-p
)))
990 (dump-fop 'fop-copy-symbol-save file
991 (gethash lookalike
(fasl-output-eq-table file
)))
992 (return (setq dumped-as-copy t
)))))))
993 ((eq pkg
*cl-package
*)
994 (dump-fop 'fop-lisp-symbol-save file length
+flag
))
995 ((eq pkg
*keyword-package
*)
996 (dump-fop 'fop-keyword-symbol-save file length
+flag
))
998 (let ((pkg-index (dump-package pkg file
)))
999 (if (eq (find-symbol pname pkg
) :inherited
)
1000 (dump-fop 'fop-symbol-in-package-save file length
+flag pkg-index
)
1001 (dump-fop 'fop-symbol-in-package-internal-save file length
+flag pkg-index
)))))
1003 (unless dumped-as-copy
1004 (dump-chars pname file base-string-p
)
1005 (push s
(gethash (symbol-name s
) (fasl-output-string=-table file
))))
1007 (setf (gethash s
(fasl-output-eq-table file
))
1008 (fasl-output-table-free file
))
1010 (incf (fasl-output-table-free file
)))
1014 ;;;; component (function) dumping
1016 (defun dump-segment (segment code-length fasl-output
)
1017 (declare (type sb-assem
:segment segment
)
1018 (type fasl-output fasl-output
))
1019 (let* ((stream (fasl-output-stream fasl-output
))
1020 (n-written (write-segment-contents segment stream
)))
1021 ;; In CMU CL there was no enforced connection between the CODE-LENGTH
1022 ;; argument and the number of bytes actually written. I added this
1023 ;; assertion while trying to debug portable genesis. -- WHN 19990902
1024 (unless (= code-length n-written
)
1025 (bug "code-length=~W, n-written=~W" code-length n-written
)))
1028 (eval-when (:compile-toplevel
)
1029 (assert (<= (length +fixup-kinds
+) 16))) ; fixup-kind fits in 4 bits
1031 (defconstant-eqx +fixup-flavors
+
1033 :card-table-index-mask
:symbol-tls-index
1034 :alien-code-linkage-index
:alien-data-linkage-index
1035 :foreign
:foreign-dataref
1037 :layout
:immobile-symbol
:fdefn-call
:static-call
1042 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
1043 (defun encoded-fixup-flavor (flavor)
1044 (or (position flavor
+fixup-flavors
+)
1045 (error "Bad fixup flavor ~s" flavor
))))
1047 ;;; Pack the aspects of a fixup into an integer.
1048 ;;; DATA is for asm routine fixups. The routine can be represented in 8 bits,
1049 ;;; so the fixup can be reduced to one word instead of an integer and a symbol.
1050 (declaim (inline !pack-fixup-info
))
1051 (defun !pack-fixup-info
(offset kind flavor data
)
1053 (the (mod 16) (or (position kind
+fixup-kinds
+)
1054 (error "Bad fixup kind ~s" kind
)))
1056 (ash (the (mod 16) (encoded-fixup-flavor flavor
)) 4)
1058 (ash (the (mod 256) data
) 8)
1059 ;; whatever it needs
1062 #-
(or x86 x86-64
) ; these two architectures provide an overriding definition
1063 (defun pack-fixups-for-reapplication (fixup-notes)
1065 (dolist (note fixup-notes
(pack-code-fixup-locs nil nil result
))
1066 (let ((fixup (fixup-note-fixup note
)))
1067 (when (eq (fixup-flavor fixup
) :card-table-index-mask
)
1068 (push (fixup-note-position note
) result
))))))
1070 ;;; Fasl files encode <flavor,kind> in a packed integer. Dispatching on the integer
1071 ;;; is simple, but the case keys still want to be symbols.
1072 (defmacro fixup-flavor-case
(flavor-id &rest clauses
)
1073 (declare (notinline position
))
1075 ,@(mapcar (lambda (clause)
1076 (if (eq (car clause
) t
)
1078 (cons (mapcar (lambda (kwd) (encoded-fixup-flavor kwd
))
1079 (ensure-list (car clause
)))
1083 ;;; Dump all the fixups. The two CASE statements below check that each
1084 ;;; fixnum has a NAME of the type appropriate to the flavor.
1085 (defun dump-fixups (fixup-notes alloc-points fasl-output
&aux
(nelements 2))
1086 (declare (type list fixup-notes
) (type fasl-output fasl-output
))
1087 ;; "retained" fixups are those whose offset in the code needs to be
1088 ;; remembered for subsequent reapplication by the garbage collector,
1089 ;; or in some cases, on core startup.
1090 (dump-object (pack-fixups-for-reapplication fixup-notes
) fasl-output
)
1091 (dump-object alloc-points fasl-output
)
1092 (dolist (note fixup-notes nelements
)
1093 (let* ((fixup (fixup-note-fixup note
))
1094 (name (fixup-name fixup
))
1095 (flavor (fixup-flavor fixup
))
1096 (flavor-id (encoded-fixup-flavor flavor
))
1098 (fixup-flavor-case flavor-id
1099 ((:code-object
:card-table-index-mask
)
1101 1) ; avoid dumping a general operand
1102 #-sb-xc-host
; ASM routine indices aren't known to the cross-compiler
1104 (the (integer 1 *) ; must not be nonzero. 0 decodes as no numeric operand
1105 (cddr (gethash name
(%asm-routine-table
*assembler-routines
*)))))))
1107 (!pack-fixup-info
(fixup-note-position note
) (fixup-note-kind note
)
1108 flavor
(or numeric-operand
0))))
1109 (dump-object info fasl-output
)
1111 (incf nelements
) ; used 1 element of the fasl stack
1113 (fixup-flavor-case flavor-id
1114 ((:alien-code-linkage-index
:alien-data-linkage-index
1115 :foreign
:foreign-dataref
) (the string name
))
1119 (layout-classoid-name name
)))
1120 (:layout-id
(the layout name
))
1123 ;; Only #+immobile-space can use the following two flavors.
1124 ;; An :IMMOBILE-SYMBOL fixup references the symbol itself,
1125 ;; whereas a :SYMBOL-VALUE fixup references the value of the symbol.
1126 ;; In the latter case, the symbol's address doesn't matter,
1127 ;; but its global value must be an immobile object.
1128 :immobile-symbol
:symbol-value
)
1130 (t name
)))) ; function name
1131 (dump-object operand fasl-output
)
1132 (incf nelements
2))))))
1134 ;;; Dump out the constant pool and code-vector for component, push the
1135 ;;; result in the table, and return the offset.
1137 ;;; The only tricky thing is handling constant-pool references to
1138 ;;; functions. If we have already dumped the function, then we just
1139 ;;; push the code pointer. Otherwise, we must create back-patching
1140 ;;; information so that the constant will be set when the function is
1141 ;;; eventually dumped. This is a bit awkward, since we don't have the
1142 ;;; handle for the code object being dumped while we are dumping its
1145 ;;; We dump trap objects in any unused slots or forward referenced slots.
1146 (defun dump-code-object (component code-segment code-length fixups alloc-points fasl-output
)
1147 (declare (type component component
)
1148 (type index code-length
)
1149 (type fasl-output fasl-output
))
1150 (let* ((2comp (component-info component
))
1151 (constants (ir2-component-constants 2comp
))
1152 (header-length (length constants
))
1156 ;; Dump the constants, noting any :ENTRY constants that have to
1158 (loop for i from sb-vm
:code-constants-offset below header-length do
1159 (binding* ((entry (aref constants i
))
1161 (if (listp entry
) (values (car entry
) (cadr entry
)))))
1164 (cond ((leaf-has-source-name-p entry
)
1165 (named-constants (cons (leaf-source-name entry
) i
))
1166 (dump-fop 'fop-misc-trap fasl-output
))
1168 (dump-object (constant-value entry
) fasl-output
))))
1170 (dump-fop 'fop-misc-trap fasl-output
))
1173 (:constant
; anything that has not been wrapped in a #<CONSTANT>
1174 (dump-object payload fasl-output
))
1176 (let* ((info (leaf-info payload
))
1177 (handle (gethash info
1178 (fasl-output-entry-table fasl-output
))))
1179 (declare (type entry-info info
))
1180 (cond (handle (dump-push handle fasl-output
))
1182 (patches (cons info i
))
1183 (dump-fop 'fop-misc-trap fasl-output
)))))
1185 (dump-push payload fasl-output
))
1187 ;; It's possible for other fdefns to be found in the header, but they can't
1188 ;; have resulted from IR2 conversion. They would have had to come from
1189 ;; something like (load-time-value (find-or-create-fdefn ...))
1190 ;; which is fine, but they don't count for this purpose.
1192 (dump-object payload fasl-output
)
1193 (dump-fop 'fop-fdefn fasl-output
))
1195 (dump-object payload fasl-output
)
1196 (dump-fop 'fop-known-fun fasl-output
))
1198 ;; Avoid the coalescence done by DUMP-VECTOR
1199 (dump-specialized-vector (make-array (cdr entry
)
1200 :element-type
'(unsigned-byte 8)
1201 :initial-element
#xFF
)
1205 (dump-object payload fasl-output
)
1206 (dump-fop 'fop-tls-index fasl-output
)))))))
1208 ;; Dump the debug info.
1209 (let ((info (debug-info-for-component component
)))
1210 (fasl-validate-structure info fasl-output
)
1211 (dump-object info fasl-output
)
1212 (push (dump-to-table fasl-output
)
1213 (fasl-output-debug-info fasl-output
)))
1215 (let ((n-fixup-elts (dump-fixups fixups alloc-points fasl-output
)))
1216 (dump-fop 'fop-load-code fasl-output
1217 (logior (ash header-length
1)
1218 (if (code-immobile-p component
) 1 0))
1221 ;; Fasl dumper/loader convention allows at most 3 integer args.
1222 ;; Others have to be written with explicit calls.
1223 (dump-integer-as-n-bytes (length (ir2-component-entries 2comp
))
1226 (dump-integer-as-n-bytes (the (unsigned-byte 22) n-fdefns
)
1229 (dump-segment code-segment code-length fasl-output
)
1231 (let ((handle (dump-pop fasl-output
)))
1232 (dolist (patch (patches))
1233 (push (cons handle
(cdr patch
))
1234 (gethash (car patch
)
1235 (fasl-output-patch-table fasl-output
))))
1236 (dolist (named-constant (named-constants))
1237 (dump-object (car named-constant
) fasl-output
)
1238 (dump-push handle fasl-output
)
1239 (dump-fop 'fop-named-constant-set fasl-output
(cdr named-constant
)))
1242 ;;; This is only called from assemfile, which doesn't exist in the target.
1244 (defun dump-assembler-routines (code-segment octets fixups alloc-points routines file
)
1245 (let ((n-fixup-elts (dump-fixups fixups alloc-points file
)))
1246 ;; The name -> address table has to be created before applying fixups
1247 ;; because a fixup may refer to an entry point in the same code component.
1248 ;; So these go on the stack last, i.e. nearest the top.
1249 ;; Reversing sorts the entry points in ascending address order
1250 ;; except possibly when there are multiple entry points to one routine
1251 (unless (= (length (remove-duplicates (mapcar 'car routines
)))
1253 (error "Duplicated asm routine name"))
1254 (dolist (routine (reverse routines
))
1255 (dump-object (car routine
) file
)
1256 (dump-integer (+ (label-position (cadr routine
)) (caddr routine
))
1258 (dump-fop 'fop-assembler-code file
)
1259 (dump-word (length routines
) file
)
1260 (dump-word (length octets
) file
)
1261 (dump-word n-fixup-elts file
)
1262 (write-segment-contents code-segment
(fasl-output-stream file
))
1265 ;;; Alter the code object referenced by CODE-HANDLE at the specified
1266 ;;; OFFSET, storing the object referenced by ENTRY-HANDLE.
1267 (defun dump-alter-code-object (code-handle offset entry-handle file
)
1268 (declare (type index code-handle entry-handle offset
))
1269 (declare (type fasl-output file
))
1270 (dump-push code-handle file
)
1271 (dump-push entry-handle file
)
1272 (dump-fop 'fop-alter-code file offset
)
1275 ;;; Dump the code, constants, etc. for component. We pass in the
1276 ;;; assembler fixups, code vector and node info.
1277 (defun fasl-dump-component (component code-segment code-length fixups alloc-points file
)
1278 (declare (type component component
))
1279 (declare (type fasl-output file
))
1282 (let ((info (ir2-component-dyncount-info (component-info component
))))
1284 (fasl-validate-structure info file
)))
1286 (let* ((2comp (component-info component
))
1287 (entries (ir2-component-entries 2comp
))
1288 (nfuns (length entries
))
1290 ;; fill in the placeholder elements of constants
1291 ;; with the NAME, ARGLIST, TYPE, INFO slots of each simple-fun.
1292 (let ((constants (ir2-component-constants 2comp
))
1293 (wordindex (+ sb-vm
:code-constants-offset
1294 (* sb-vm
:code-slots-per-simple-fun nfuns
))))
1295 (dolist (entry entries
)
1296 ;; Process in reverse order of ENTRIES.
1297 ;; See also MAKE-CORE-COMPONENT which does the same thing.
1298 (decf wordindex sb-vm
:code-slots-per-simple-fun
)
1299 (setf (aref constants
(+ wordindex sb-vm
:simple-fun-name-slot
))
1300 `(:constant
,(entry-info-name entry
))
1301 (aref constants
(+ wordindex sb-vm
:simple-fun-arglist-slot
))
1302 `(:constant
,(entry-info-arguments entry
))
1303 (aref constants
(+ wordindex sb-vm
:simple-fun-source-slot
))
1304 `(:constant
,(entry-info-form/doc entry
))
1305 (aref constants
(+ wordindex sb-vm
:simple-fun-info-slot
))
1306 `(:constant
,(entry-info-type/xref entry
))))
1307 (dump-code-object component code-segment code-length fixups
1308 alloc-points file
)))
1311 (dolist (entry entries
)
1312 (dump-push code-handle file
)
1313 (dump-fop 'fop-fun-entry file
(decf fun-index
))
1314 (let ((entry-handle (dump-pop file
)))
1315 ;; When cross compiling, if the entry is a DEFUN, then we also
1316 ;; dump a FOP-FSET so that the cold loader can instantiate the
1317 ;; definition at cold-load time, allowing forward references
1318 ;; to functions in top-level forms. If the entry is a
1319 ;; DEFMETHOD, we dump a FOP-MSET so that the cold loader
1320 ;; recognizes the method definition.
1322 (let ((name (entry-info-name entry
)))
1323 (cond ((legal-fun-name-p name
)
1324 (dump-object name file
)
1325 (dump-push entry-handle file
)
1326 (dump-fop 'fop-fset file
))
1328 (eq (first name
) 'sb-pcl
::fast-method
))
1329 (let ((method (second name
))
1330 (qualifiers (butlast (cddr name
)))
1331 (specializers (first (last name
))))
1332 (dump-object method file
)
1333 (dump-object qualifiers file
)
1334 (dump-object specializers file
)
1335 (dump-push entry-handle file
)
1336 (dump-fop 'fop-mset file
)))))
1337 (setf (gethash entry
(fasl-output-entry-table file
)) entry-handle
)
1338 (let ((old (gethash entry
(fasl-output-patch-table file
))))
1341 (dump-alter-code-object (car patch
)
1345 (remhash entry
(fasl-output-patch-table file
)))))))
1348 ;;; Dump a FOP-FUNCALL to call an already-dumped top level lambda at
1350 (defun fasl-dump-toplevel-lambda-call (fun fasl-output
)
1351 (declare (type clambda fun
) (type fasl-output fasl-output
))
1352 (let ((handle (gethash (leaf-info fun
)
1353 (fasl-output-entry-table fasl-output
))))
1355 (dump-push handle fasl-output
)
1356 (dump-fop 'fop-funcall-for-effect fasl-output
0))
1359 ;;; Dump some information to allow partial reconstruction of the
1360 ;;; DEBUG-SOURCE structure.
1361 (defun fasl-dump-partial-source-info (info file
)
1362 (declare (type source-info info
) (type fasl-output file
))
1363 (let ((partial (debug-source-for-info info
)))
1364 (dump-object (debug-source-namestring partial
) file
)
1365 (dump-object (debug-source-created partial
) file
)
1366 (dump-object (debug-source-plist partial
) file
)
1367 (dump-fop 'fop-note-partial-source-info file
)))
1369 ;;; Compute the correct list of DEBUG-SOURCE structures and backpatch
1370 ;;; all of the dumped DEBUG-INFO structures. We clear the
1371 ;;; FASL-OUTPUT-DEBUG-INFO, so that subsequent components with
1372 ;;; different source info may be dumped.
1373 (defun fasl-dump-source-info (info file
)
1374 (declare (type source-info info
) (type fasl-output file
))
1375 (let ((res (debug-source-for-info info
)))
1376 (fasl-validate-structure res file
)
1377 (dump-object res file
)
1378 (let ((res-handle (dump-pop file
)))
1379 (dolist (info-handle (fasl-output-debug-info file
))
1380 (dump-push res-handle file
)
1382 ((debug-info-source-index
1383 (let ((dd (find-defstruct-description 'debug-info
)))
1384 (dsd-index (find 'source
(dd-slots dd
)
1385 :key
#'dsd-name
:test
'string
=)))))
1386 (dump-fop 'fop-structset file info-handle debug-info-source-index
)))))
1388 (setf (fasl-output-debug-info file
) nil
)
1391 ;;;; dumping structures
1393 (defun dump-structure (struct file
)
1394 (unless (gethash struct
(fasl-output-valid-structures file
))
1395 (error "attempt to dump invalid structure:~% ~S~%How did this happen?"
1397 (note-potential-circularity struct file
)
1398 (do* ((length (%instance-length struct
))
1399 (layout (%instance-layout struct
))
1400 (bitmap (layout-bitmap layout
))
1401 (circ (fasl-output-circularity-table file
))
1402 (index sb-vm
:instance-data-start
(1+ index
)))
1404 (dump-non-immediate-object layout file
)
1405 (dump-fop 'fop-struct file length
))
1406 (let* ((obj (if (logbitp index bitmap
)
1407 (%instance-ref struct index
)
1408 (%raw-instance-ref
/word struct index
)))
1409 (ref (gethash obj circ
)))
1410 (sub-dump-object (cond (ref
1411 (push (make-circularity :type
:struct-set
1415 :enclosing-object ref
)
1416 *circularities-detected
*)
1421 (defun dump-layout (obj file
)
1422 (when (layout-invalid obj
)
1423 (compiler-error "attempt to dump reference to obsolete class: ~S"
1424 (layout-classoid obj
)))
1425 ;; STANDARD-OBJECT could in theory be dumpable, but nothing else,
1426 ;; because all its subclasses can evolve to have new layouts.
1427 (aver (not (logtest (layout-flags obj
) +pcl-object-layout-flag
+)))
1428 (let ((name (layout-classoid-name obj
)))
1429 ;; Q: Shouldn't we aver that NAME is the proper name for its classoid?
1431 (compiler-error "dumping anonymous layout: ~S" obj
))
1432 ;; The target lisp can save some space in fasls (sometimes),
1433 ;; but the cross-compiler can't because we need to construct the
1434 ;; cold representation of all layouts, not reference host layouts.
1436 (let ((fop (known-layout-fop name
)))
1438 (return-from dump-layout
(dump-byte fop file
))))
1439 (dump-object name file
))
1440 (sub-dump-object (layout-bitmap obj
) file
)
1441 (sub-dump-object (layout-inherits obj
) file
)
1442 (dump-fop 'fop-layout file
1443 (1+ (layout-depthoid obj
)) ; non-stack args can't be negative
1444 (logand (layout-flags obj
) sb-kernel
::layout-flags-mask
)
1445 (layout-length obj
)))
1447 ;;;; dumping instances which just save their slots
1449 (defun dump-instance-saving-slots (object slot-names file
)
1450 (note-potential-circularity object file
)
1451 (let ((circ (fasl-output-circularity-table file
)))
1452 (dolist (slot-name slot-names
)
1453 (if (slot-boundp object slot-name
)
1454 (let* ((value (slot-value object slot-name
))
1455 (ref (gethash value circ
)))
1457 (push (make-circularity :type
:slot-set
1460 :slot-name slot-name
1462 :enclosing-object ref
)
1463 *circularities-detected
*)
1464 (sub-dump-object nil file
))
1466 (sub-dump-object value file
))))
1467 (dump-fop 'fop-misc-trap file
))
1468 (sub-dump-object slot-name file
)))
1469 (sub-dump-object (class-name (class-of object
)) file
)
1470 (dump-fop 'fop-instance file
(length slot-names
)))
1474 (defun dump-code-coverage-records (cc file
)
1475 (declare (type list cc
))
1476 (dump-object cc file
)
1477 (dump-fop 'fop-record-code-coverage file
))
1479 (defun dump-emitted-full-calls (hash-table fasl
)
1480 (let ((list (%hash-table-alist hash-table
)))
1481 #+sb-xc-host
; enforce host-insensitive reproducible ordering
1482 (labels ((symbol< (a b
)
1483 (cond ((string< a b
) t
)
1485 ;; this does find a few pairs of lookalikes
1486 (string< (cl:package-name
(sb-xc:symbol-package a
))
1487 (cl:package-name
(sb-xc:symbol-package b
))))))
1489 (cond ((and (atom a
) (atom b
)) (symbol< a b
))
1490 ((atom a
) t
) ; symbol < list
1491 ((atom b
) nil
) ; opposite
1492 ((symbol< (cadr a
) (cadr b
))))))
1493 (setq list
(sort list
#'fname
< :key
#'car
)))
1494 (dump-object list fasl
)
1495 (dump-fop 'fop-note-full-calls fasl
)))