/[cmucl]/src/compiler/dump.lisp
ViewVC logotype

Contents of /src/compiler/dump.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.92 - (show annotations)
Wed Feb 2 13:07:57 2011 UTC (3 years, 2 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, HEAD
Changes since 1.91: +8 -2 lines
Don't dump fdefinitions for local flet/labels functions.  Suggested by
Helmut Eller, cmucl-imp 2011-01-19.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/dump.lisp,v 1.92 2011/02/02 13:07:57 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains stuff that knows about dumping FASL files.
13 ;;;
14 (in-package "C")
15 (intl:textdomain "cmucl")
16
17 (declaim (special compiler-version))
18
19 ;;;; Fasl dumper state:
20
21 ;;; We do some buffering in front of the stream that represents the output file
22 ;;; so as to speed things up a bit.
23 ;;;
24 (defconstant fasl-buffer-size 2048)
25
26 ;;; The Fasl-File structure represents everything we need to know about dumping
27 ;;; to a fasl file. We need to objectify the state, since the fasdumper must
28 ;;; be reentrant.
29 ;;;
30 (defstruct (fasl-file
31 (:print-function
32 (lambda (s stream d)
33 (declare (ignore d) (stream stream))
34 (format stream "#<Fasl-File ~S>"
35 (namestring (fasl-file-stream s))))))
36 ;;
37 ;; The stream we dump to.
38 (stream (required-argument) :type stream)
39 ;;
40 ;; The buffer we accumulate output in before blasting it out to the stream
41 ;; with SYS:OUTPUT-RAW-BYTES.
42 (buffer (make-array fasl-buffer-size :element-type '(unsigned-byte 8))
43 :type (simple-array (unsigned-byte 8) (*)))
44 ;;
45 ;; The index of the first free byte in Buffer. Note that there is always at
46 ;; least one byte free.
47 (buffer-index 0 :type index)
48 ;;
49 ;; Hashtables we use to keep track of dumped constants so that we can get
50 ;; them from the table rather than dumping them again. The EQUAL-TABLE is
51 ;; used for lists and strings, and the EQ-TABLE is used for everything else.
52 ;; We use a separate EQ table to avoid performance patholigies with objects
53 ;; for which EQUAL degnerates to EQL. Everything entered in the EQUAL table
54 ;; is also entered in the EQ table.
55 (equal-table (make-hash-table :test #'equal) :type hash-table)
56 (eq-table (make-hash-table :test #'eq) :type hash-table)
57 ;;
58 ;; The table's current free pointer: the next offset to be used.
59 (table-free 0 :type index)
60 ;;
61 ;; Alist (Package . Offset) of the table offsets for each package we have
62 ;; currently located.
63 (packages () :type list)
64 ;;
65 ;; Table mapping from the Entry-Info structures for dumped XEPs to the table
66 ;; offsets of the corresponding code pointers.
67 (entry-table (make-hash-table :test #'eq) :type hash-table)
68 ;;
69 ;; Table holding back-patching info for forward references to XEPs. The key
70 ;; is the Entry-Info structure for the XEP, and the value is a list of conses
71 ;; (<code-handle> . <offset>), where <code-handle> is the offset in the table
72 ;; of the code object needing to be patched, and <offset> is the offset that
73 ;; must be patched.
74 (patch-table (make-hash-table :test #'eq) :type hash-table)
75 ;;
76 ;; A list of the table handles for all of the DEBUG-INFO structures dumped in
77 ;; this file. These structures must be back-patched with source location
78 ;; information when the compilation is complete.
79 (debug-info () :type list)
80 ;;
81 ;; Used to keep track of objects that we are in the process of dumping so
82 ;; that circularities can be preserved. The key is the object that we have
83 ;; previously seen, and the value is the object that we reference in the
84 ;; table to find this previously seen object. (The value is never NIL.)
85 ;;
86 ;; Except with list objects, the key and the value are always the same. In a
87 ;; list, the key will be some tail of the value.
88 (circularity-table (make-hash-table :test #'eq) :type hash-table)
89 ;;
90 ;; Hash table of structures that are allowed to be dumped. If we try to
91 ;; dump a structure that isn't in this hash table, we lose.
92 (valid-structures (make-hash-table :test #'eq) :type hash-table))
93
94 ;;; This structure holds information about a circularity.
95 ;;;
96 (defstruct circularity
97 ;;
98 ;; Kind of modification to make to create circularity.
99 (type (required-argument) :type (member :rplaca :rplacd :svset :struct-set))
100 ;;
101 ;; Object containing circularity.
102 object
103 ;;
104 ;; Index in object for circularity.
105 (index (required-argument) :type index)
106 ;;
107 ;; The object to be stored at Index in Object. This is that the key that we
108 ;; were using when we discovered the circularity.
109 value
110 ;;
111 ;; The value that was associated with Value in the CIRCULARITY-TABLE. This
112 ;; is the object that we look up in the EQ-TABLE to locate Value.
113 enclosing-object)
114
115
116 ;;; A list of the Circularity structures for all of the circularities detected
117 ;;; in the current top-level call to Dump-Object. Setting this lobotomizes
118 ;;; circularity detection as well, since circular dumping uses the table.
119 ;;;
120 (defvar *circularities-detected*)
121
122
123 ;;; Used to inhibit table access when dumping forms to be read by the cold
124 ;;; loader.
125 ;;;
126 (defvar *cold-load-dump* nil)
127
128
129 ;;; Used to turn off the structure validation during dumping of source info.
130 ;;;
131 (defvar *dump-only-valid-structures* t)
132
133
134 ;;;; Utilities:
135
136 ;;; FLUSH-FASL-FILE-BUFFER -- Internal
137 ;;;
138 ;;; Write out the contents of File's buffer to its stream.
139 ;;;
140 (defun flush-fasl-file-buffer (file)
141 (system:output-raw-bytes (fasl-file-stream file)
142 (fasl-file-buffer file)
143 0
144 (fasl-file-buffer-index file))
145 (setf (fasl-file-buffer-index file) 0)
146 (undefined-value))
147
148
149 ;;; Dump-Byte -- Internal
150 ;;;
151 ;;; Write the byte B to the specified fasl-file stream.
152 ;;;
153 (declaim (maybe-inline dump-byte))
154 (defun dump-byte (b file)
155 (declare (type (unsigned-byte 8) b) (type fasl-file file)
156 (optimize (speed 3) (safety 0)))
157 (let ((idx (fasl-file-buffer-index file))
158 (buf (fasl-file-buffer file)))
159 (setf (aref buf idx) b)
160 (let ((new (1+ idx)))
161 (setf (fasl-file-buffer-index file) new)
162 (when (= new fasl-buffer-size)
163 (flush-fasl-file-buffer file))))
164 (undefined-value))
165
166
167 ;;; DUMP-UNSIGNED-32 -- Internal
168 ;;;
169 ;;; Dump a 4 byte unsigned integer.
170 ;;;
171 (defun dump-unsigned-32 (num file)
172 (declare (type (unsigned-byte 32) num) (type fasl-file file)
173 (optimize (speed 3) (safety 0)))
174 (let* ((idx (fasl-file-buffer-index file))
175 (buf (fasl-file-buffer file))
176 (new (+ idx 4)))
177 (when (>= new fasl-buffer-size)
178 (flush-fasl-file-buffer file)
179 (setq idx 0 new 4))
180 (setf (aref buf (+ idx 0)) (ldb (byte 8 0) num))
181 (setf (aref buf (+ idx 1)) (ldb (byte 8 8) num))
182 (setf (aref buf (+ idx 2)) (ldb (byte 8 16) num))
183 (setf (aref buf (+ idx 3)) (ldb (byte 8 24) num))
184 (setf (fasl-file-buffer-index file) new))
185 (undefined-value))
186
187
188 ;;; Dump-Var-Signed -- Internal
189 ;;;
190 ;;; Dump Num to the fasl stream, represented by the specified number of
191 ;;; bytes.
192 ;;;
193 (defun dump-var-signed (num bytes file)
194 (declare (integer num) (type index bytes) (type fasl-file file)
195 (inline dump-byte))
196 (do ((n num (ash n -8))
197 (i bytes (1- i)))
198 ((= i 0))
199 (declare (type index i))
200 (dump-byte (logand n #xFF) file))
201 (undefined-value))
202
203
204 ;;; DUMP-BYTES -- Internal
205 ;;;
206 ;;; Dump the first N bytes in Vec out to File. Vec is some sort of unboxed
207 ;;; vector-like thing that we can BLT from.
208 ;;;
209 (defun dump-bytes (vec n file)
210 (declare (type index n) (type fasl-file file)
211 (optimize (speed 3) (safety 0)))
212 (let* ((idx (fasl-file-buffer-index file))
213 (buf (fasl-file-buffer file))
214 (new (+ idx n)))
215 (cond ((< new fasl-buffer-size)
216 (bit-bash-copy vec vector-data-bit-offset
217 buf
218 (+ vector-data-bit-offset
219 (the index (* idx vm:byte-bits)))
220 (* n vm:byte-bits))
221 (setf (fasl-file-buffer-index file) new))
222 (t
223 (flush-fasl-file-buffer file)
224 (cond ((>= n fasl-buffer-size)
225 (system:output-raw-bytes (fasl-file-stream file)
226 vec 0 n))
227 (t
228 (bit-bash-copy vec vector-data-bit-offset
229 buf vector-data-bit-offset
230 (* n vm:byte-bits))
231 (setf (fasl-file-buffer-index file) n))))))
232 (undefined-value))
233
234 ;;; Dump-FOP -- Internal
235 ;;;
236 ;;; Dump the FOP code for the named FOP to the specified fasl-file.
237 ;;;
238 (defmacro dump-fop (fs file)
239 (let* ((fs (eval fs))
240 (val (get fs 'lisp::fop-code)))
241 (assert val () (intl:gettext "Compiler bug: ~S not a legal fasload operator.") fs)
242 `(dump-byte ',val ,file)))
243
244
245 ;;; Dump-FOP* -- Internal
246 ;;;
247 ;;; Dump a FOP-Code along with an integer argument, choosing the FOP based
248 ;;; on whether the argument will fit in a single byte.
249 ;;;
250 (defmacro dump-fop* (n byte-fop word-fop file)
251 (once-only ((n-n n)
252 (n-file file))
253 `(cond ((< ,n-n 256)
254 (dump-fop ',byte-fop ,n-file)
255 (dump-byte ,n-n ,n-file))
256 (t
257 (dump-fop ',word-fop ,n-file)
258 (dump-unsigned-32 ,n-n ,n-file)))))
259
260
261 ;;; Dump-Push -- Internal
262 ;;;
263 ;;; Push the object at table offset Handle on the fasl stack.
264 ;;;
265 (defun dump-push (handle file)
266 (declare (type index handle) (type fasl-file file))
267 (dump-fop* handle lisp::fop-byte-push lisp::fop-push file)
268 (undefined-value))
269
270
271 ;;; Dump-Pop -- Internal
272 ;;;
273 ;;; Pop the object currently on the fasl stack top into the table, and
274 ;;; return the table index, incrementing the free pointer.
275 ;;;
276 (defun dump-pop (file)
277 (prog1 (fasl-file-table-free file)
278 (dump-fop 'lisp::fop-pop file)
279 (incf (fasl-file-table-free file))))
280
281 ;;; non-circular-cons-p -- Internal
282 ;;;
283 ;;; Return true if LIST is definitely not circular.
284
285 (defun non-circular-list-p (list)
286 (declare (list list))
287 (or (null list)
288 (labels ((safe-cddr (obj)
289 (when (and (consp obj) (consp (cdr obj)))
290 (cddr obj))))
291 (loop for tortoise = list then (cdr tortoise)
292 for hare = (safe-cddr list) then (safe-cddr hare)
293 when (not (consp tortoise)) return t
294 when (consp (car tortoise)) return nil
295 when (eq hare tortoise) return nil))))
296
297 ;;; EQUAL-CHECK-TABLE -- Internal
298 ;;;
299 ;;; If X is in File's EQUAL-TABLE, then push the object and return T,
300 ;;; otherwise NIL. If *COLD-LOAD-DUMP* is true, then do nothing and return
301 ;;; NIL.
302 ;;;
303 (defun equal-check-table (x file)
304 (declare (type fasl-file file))
305 (unless *cold-load-dump*
306 (let ((handle (gethash x (fasl-file-equal-table file))))
307 (cond (handle
308 (dump-push handle file)
309 t)
310 (t
311 nil)))))
312
313
314 ;;; EQ-SAVE-OBJECT, EQUAL-SAVE-OBJECT -- Internal
315 ;;;
316 ;;; These functions are called after dumping an object to save the object in
317 ;;; the table. The object (also passed in as X) must already be on the top of
318 ;;; the FOP stack. If *COLD-LOAD-DUMP* is true, then we don't do anything.
319 ;;;
320 (defun eq-save-object (x file)
321 (declare (type fasl-file file))
322 (unless *cold-load-dump*
323 (let ((handle (dump-pop file)))
324 (setf (gethash x (fasl-file-eq-table file)) handle)
325 (dump-push handle file)))
326 (undefined-value))
327 ;;;
328 (defun equal-save-object (x file)
329 (declare (type fasl-file file))
330 (unless *cold-load-dump*
331 (let ((handle (dump-pop file)))
332 (setf (gethash x (fasl-file-equal-table file)) handle)
333 (setf (gethash x (fasl-file-eq-table file)) handle)
334 (dump-push handle file)))
335 (undefined-value))
336
337
338 ;;; NOTE-POTENTIAL-CIRCULARITY -- Internal
339 ;;;
340 ;;; Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is true.
341 ;;; This is called on objects that we are about to dump might have a circular
342 ;;; path through them.
343 ;;;
344 ;;; The object must not currently be in this table, since the dumper should
345 ;;; never be recursively called on a circular reference. Instead, the dumping
346 ;;; function must detect the circularity and arrange for the dumped object to
347 ;;; be patched.
348 ;;;
349 (defun note-potential-circularity (x file)
350 (unless *cold-load-dump*
351 (let ((circ (fasl-file-circularity-table file)))
352 (assert (not (gethash x circ)))
353 (setf (gethash x circ) x)))
354 (undefined-value))
355
356
357 ;;; Fasl-Dump-Cold-Load-Form -- Interface
358 ;;;
359 ;;; Dump Form to a fasl file so that it evaluated at load time in normal
360 ;;; load and at cold-load time in cold load. This is used to dump package
361 ;;; frobbing forms.
362 ;;;
363 (defun fasl-dump-cold-load-form (form file)
364 (declare (type fasl-file file))
365 (dump-fop 'lisp::fop-normal-load file)
366 (let ((*cold-load-dump* t))
367 (dump-object form file))
368 (dump-fop 'lisp::fop-eval-for-effect file)
369 (dump-fop 'lisp::fop-maybe-cold-load file)
370 (undefined-value))
371
372
373 ;;;; Opening and closing:
374
375 ;;; Open-Fasl-File -- Interface
376 ;;;
377 ;;; Return a Fasl-File object for dumping to the named file. Some
378 ;;; information about the source is specified by the string Where. If byte-p
379 ;;; is true, this file will contain no native code, and is thus largely
380 ;;; implementation independent.
381 ;;;
382 (defun open-fasl-file (name where &optional byte-p)
383 (declare (type pathname name))
384 (let* ((stream (open name :direction :output
385 :if-exists :rename-and-delete
386 :element-type '(unsigned-byte 8)
387 :class 'binary-text-stream))
388 (res (make-fasl-file :stream stream)))
389 (multiple-value-bind
390 (version f-vers f-imp)
391 (if byte-p
392 (values "Byte code"
393 byte-fasl-file-version
394 (backend-byte-fasl-file-implementation *backend*))
395 (values (backend-version *backend*)
396 (backend-fasl-file-version *backend*)
397 (backend-fasl-file-implementation *backend*)))
398 (format stream
399 "FASL FILE output from ~A.~@
400 Compiled ~A on ~A~@
401 Compiler ~A, Lisp ~A~@
402 CMUCL dumped on: ~A on ~A~@
403 Targeted for ~A, FASL version ~X~%"
404 where
405 (ext:format-universal-time nil (get-universal-time) :style :iso8601)
406 (machine-instance) compiler-version
407 (lisp-implementation-version)
408 (let ((dump-time (if (boundp 'lisp::*cmucl-core-dump-time*)
409 lisp::*cmucl-core-dump-time*
410 nil)))
411 (when dump-time
412 (ext:format-universal-time nil dump-time :style :iso8601)))
413 lisp::*cmucl-core-dump-host*
414 version f-vers)
415 ;;
416 ;; Terminate header.
417 (dump-byte 255 res)
418 ;;
419 ;; Specify code format.
420 (dump-fop 'lisp::fop-long-code-format res)
421 (dump-byte f-imp res)
422 (dump-unsigned-32 f-vers res))
423 res))
424
425
426 ;;; Close-Fasl-File -- Interface
427 ;;;
428 ;;; Close the specified Fasl-File, aborting the write if Abort-P is true.
429 ;;; We do various sanity checks, then end the group.
430 ;;;
431 (defun close-fasl-file (file abort-p)
432 (declare (type fasl-file file))
433 (assert (zerop (hash-table-count (fasl-file-patch-table file))))
434 (dump-fop 'lisp::fop-verify-empty-stack file)
435 (dump-fop 'lisp::fop-verify-table-size file)
436 (dump-unsigned-32 (fasl-file-table-free file) file)
437 (dump-fop 'lisp::fop-end-group file)
438 (flush-fasl-file-buffer file)
439 (close (fasl-file-stream file) :abort abort-p)
440 (undefined-value))
441
442
443 ;;;; Component (function) dumping:
444
445 (defun dump-segment (segment code-length file)
446 (declare (type new-assem:segment segment)
447 (type fasl-file file))
448 (flush-fasl-file-buffer file)
449 (let* ((stream (fasl-file-stream file))
450 (posn (file-position stream)))
451 (new-assem:segment-map-output
452 segment
453 #'(lambda (sap amount)
454 (system:output-raw-bytes stream sap 0 amount)))
455 (unless (= (- (file-position stream) posn) code-length)
456 (error (intl:gettext "Tried to output ~D bytes, but only ~D made it.")
457 code-length (- (file-position stream) posn))))
458 (when (backend-featurep :gengc)
459 (unless (zerop (logand code-length 3))
460 (dotimes (i (- 4 (logand code-length 3)))
461 (dump-byte 0 file))))
462 (undefined-value))
463
464 ;;; Dump-Code-Object -- Internal
465 ;;;
466 ;;; Dump out the constant pool and code-vector for component, push the
467 ;;; result in the table and return the offset.
468 ;;;
469 ;;; The only tricky thing is handling constant-pool references to functions.
470 ;;; If we have already dumped the function, then we just push the code pointer.
471 ;;; Otherwise, we must create back-patching information so that the constant
472 ;;; will be set when the function is eventually dumped. This is a bit awkward,
473 ;;; since we don't have the handle for the code object being dumped while we
474 ;;; are dumping its constants.
475 ;;;
476 ;;; We dump trap objects in any unused slots or forward referenced slots.
477 ;;;
478 (defun dump-code-object (component code-segment code-length
479 trace-table fixups file)
480 (declare (type component component) (type fasl-file file)
481 (list trace-table) (type index code-length))
482 (let* ((2comp (component-info component))
483 (constants (ir2-component-constants 2comp))
484 (gengc (backend-featurep :gengc))
485 (header-length (length constants))
486 (trace-table (pack-trace-table trace-table))
487 (trace-table-length (length trace-table))
488 (total-length (+ code-length (* trace-table-length 2))))
489 (collect ((patches))
490 ;; Dump the debug info.
491 (when gengc
492 (let ((info (debug-info-for-component component))
493 (*dump-only-valid-structures* nil))
494 (dump-object info file)
495 (let ((info-handle (dump-pop file)))
496 (dump-push info-handle file)
497 (push info-handle (fasl-file-debug-info file)))))
498
499 ;; Dump the offset of the trace table.
500 (dump-object code-length file)
501
502 ;; Dump the constants, noting any :entries that have to be fixed up.
503 (do ((i vm:code-constants-offset (1+ i)))
504 ((>= i header-length))
505 (let ((entry (aref constants i)))
506 (etypecase entry
507 (constant
508 (dump-object (constant-value entry) file))
509 (cons
510 (ecase (car entry)
511 (:entry
512 (let* ((info (leaf-info (cdr entry)))
513 (handle (gethash info (fasl-file-entry-table file))))
514 (cond
515 (handle
516 (dump-push handle file))
517 (t
518 (patches (cons info i))
519 (dump-fop 'lisp::fop-misc-trap file)))))
520 (:load-time-value
521 (dump-push (cdr entry) file))
522 (:fdefinition
523 (dump-object (cdr entry) file)
524 (dump-fop 'lisp::fop-fdefinition file))))
525 (null
526 (dump-fop 'lisp::fop-misc-trap file)))))
527
528 ;; Dump the debug info.
529 (unless gengc
530 (let ((info (debug-info-for-component component))
531 (*dump-only-valid-structures* nil))
532 (dump-object info file)
533 (let ((info-handle (dump-pop file)))
534 (dump-push info-handle file)
535 (push info-handle (fasl-file-debug-info file)))))
536
537 (let ((num-consts (if gengc
538 (- header-length vm:code-debug-info-slot)
539 (- header-length vm:code-trace-table-offset-slot)))
540 (total-length (if gengc
541 (ceiling total-length 4)
542 total-length)))
543 (cond ((and (< num-consts #x100) (< total-length #x10000))
544 (dump-fop 'lisp::fop-small-code file)
545 (dump-byte num-consts file)
546 (dump-var-signed total-length 2 file))
547 (t
548 (dump-fop 'lisp::fop-code file)
549 (dump-unsigned-32 num-consts file)
550 (dump-unsigned-32 total-length file))))
551
552 (dump-segment code-segment code-length file)
553 (dump-i-vector trace-table file t)
554 (dump-fixups fixups file)
555 (dump-fop 'lisp::fop-sanctify-for-execution file)
556 (let ((handle (dump-pop file)))
557 (dolist (patch (patches))
558 (push (cons handle (cdr patch))
559 (gethash (car patch) (fasl-file-patch-table file))))
560 handle))))
561
562
563 (defun dump-assembler-routines (code-segment length fixups routines file)
564 (dump-fop 'lisp::fop-assembler-code file)
565 (dump-unsigned-32 (if (backend-featurep :gengc)
566 (ceiling length 4)
567 length)
568 file)
569 (flush-fasl-file-buffer file)
570 (let ((stream (fasl-file-stream file)))
571 (new-assem:segment-map-output
572 code-segment
573 #'(lambda (sap amount)
574 (system:output-raw-bytes stream sap 0 amount))))
575 (dolist (routine routines)
576 (dump-fop 'lisp::fop-normal-load file)
577 (let ((*cold-load-dump* t))
578 (dump-object (car routine) file))
579 (dump-fop 'lisp::fop-maybe-cold-load file)
580 (dump-fop 'lisp::fop-assembler-routine file)
581 (dump-unsigned-32 (label-position (cdr routine)) file))
582 (dump-fixups fixups file)
583 (dump-fop 'lisp::fop-sanctify-for-execution file)
584 (dump-pop file))
585
586 ;;; Dump-Fixups -- Internal
587 ;;;
588 ;;; Dump all the fixups. Currently there are three flavors of fixup:
589 ;;; - assembly routines: named by a symbol
590 ;;; - foreign (C) symbols: named by a string
591 ;;; - code object references: don't need a name.
592 ;;;
593 (defun dump-fixups (fixups file)
594 (declare (list fixups) (type fasl-file file))
595 (dolist (info fixups)
596 (let* ((kind (first info))
597 (fixup (second info))
598 (name (fixup-name fixup))
599 (flavor (fixup-flavor fixup))
600 (offset (third info)))
601 (dump-fop 'lisp::fop-normal-load file)
602 (let ((*cold-load-dump* t))
603 (dump-object kind file))
604 (dump-fop 'lisp::fop-maybe-cold-load file)
605 (ecase flavor
606 (:assembly-routine
607 (assert (symbolp name))
608 (dump-fop 'lisp::fop-normal-load file)
609 (let ((*cold-load-dump* t))
610 (dump-object name file))
611 (dump-fop 'lisp::fop-maybe-cold-load file)
612 (dump-fop 'lisp::fop-assembler-fixup file))
613 ((:foreign :foreign-data)
614 (assert (stringp name))
615 (if (eq flavor :foreign)
616 (dump-fop 'lisp::fop-foreign-fixup file)
617 (dump-fop 'lisp::fop-foreign-data-fixup file))
618 (let ((len (length name)))
619 (assert (< len 256))
620 (dump-byte len file)
621 #-unicode
622 (dotimes (i len)
623 (dump-byte (char-code (schar name i)) file))
624 #+unicode
625 (dump-data-maybe-byte-swapping name (* vm:char-bytes len) vm:char-bits file)))
626 (:code-object
627 (dump-fop 'lisp::fop-code-object-fixup file)))
628 (dump-unsigned-32 offset file)))
629 (undefined-value))
630
631
632 ;;; Dump-One-Entry -- Internal
633 ;;;
634 ;;; Dump a function-entry data structure corresponding to Entry to File.
635 ;;; Code-Handle is the table offset of the code object for the component.
636 ;;;
637 ;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the cold
638 ;;; loader can instantiate the definition at cold-load time, allowing forward
639 ;;; references to functions in top-level forms.
640 ;;;
641 (defun dump-one-entry (entry code-handle file)
642 (declare (type entry-info entry) (type index code-handle)
643 (type fasl-file file))
644 (let ((name (entry-info-name entry)))
645 (dump-push code-handle file)
646 (dump-object name file)
647 (dump-object (entry-info-arguments entry) file)
648 (dump-object (entry-info-type entry) file)
649 (dump-fop 'lisp::fop-function-entry file)
650 (dump-unsigned-32 (label-position (entry-info-offset entry)) file)
651 (let ((handle (dump-pop file)))
652 (when (and name (or (symbolp name)
653 (and (listp name)
654 ;; Skip over any entries for
655 ;; flet/labels functions. We don't
656 ;; need them stored because we can't
657 ;; really do anything with them.
658 (not (member (car name) '(flet labels) :test 'eq) ))))
659 (dump-object name file)
660 (dump-push handle file)
661 (dump-fop 'lisp::fop-fset file))
662 handle)))
663
664 ;;; Alter-Code-Object -- Internal
665 ;;;
666 ;;; Alter the code object referenced by Code-Handle at the specified Offset,
667 ;;; storing the object referenced by Entry-Handle.
668 ;;;
669 (defun alter-code-object (code-handle offset entry-handle file)
670 (declare (type index code-handle entry-handle offset) (type fasl-file file))
671 (dump-push code-handle file)
672 (dump-push entry-handle file)
673 (dump-fop* offset lisp::fop-byte-alter-code lisp::fop-alter-code file)
674 (undefined-value))
675
676
677 ;;; Fasl-Dump-Component -- Interface
678 ;;;
679 ;;; Dump the code, constants, etc. for component. We pass in the assembler
680 ;;; fixups, code vector and node info.
681 ;;;
682 (defun fasl-dump-component (component code-segment length trace-table
683 fixups file)
684 (declare (type component component) (list trace-table) (type fasl-file file))
685
686 (dump-fop 'lisp::fop-verify-empty-stack file)
687 (dump-fop 'lisp::fop-verify-table-size file)
688 (dump-unsigned-32 (fasl-file-table-free file) file)
689
690 (let ((info (ir2-component-dyncount-info (component-info component))))
691 (when info
692 (fasl-validate-structure info file)))
693
694 (let ((code-handle (dump-code-object component code-segment
695 length trace-table fixups file))
696 (2comp (component-info component)))
697 (dump-fop 'lisp::fop-verify-empty-stack file)
698
699 (dolist (entry (ir2-component-entries 2comp))
700 (let ((entry-handle (dump-one-entry entry code-handle file)))
701 (setf (gethash entry (fasl-file-entry-table file)) entry-handle)
702
703 (let ((old (gethash entry (fasl-file-patch-table file))))
704 (when old
705 (dolist (patch old)
706 (alter-code-object (car patch) (cdr patch) entry-handle file))
707 (remhash entry (fasl-file-patch-table file)))))))
708 (undefined-value))
709
710
711 ;;; DUMP-BYTE-CODE-OBJECT -- internal.
712 ;;;
713 (defun dump-byte-code-object (segment length constants file)
714 (declare (type new-assem:segment segment)
715 (type index length)
716 (type vector constants)
717 (type fasl-file file))
718 (let ((gengc (backend-featurep :gengc)))
719 (collect ((entry-patches))
720 ;; Dump the debug info.
721 (when gengc
722 (let ((info (make-debug-info :name
723 (component-name *compile-component*)))
724 (*dump-only-valid-structures* nil))
725 (dump-object info file)
726 (let ((info-handle (dump-pop file)))
727 (dump-push info-handle file)
728 (push info-handle (fasl-file-debug-info file)))))
729
730 ;; "trace table" is initialized by loader to hold a list of all byte
731 ;; functions in this code object (for debug info.)
732 (dump-object nil file)
733
734 ;; Dump the constants.
735 (dotimes (i (length constants))
736 (let ((entry (aref constants i)))
737 (etypecase entry
738 (constant
739 (dump-object (constant-value entry) file))
740 (null
741 (dump-fop 'lisp::fop-misc-trap file))
742 (list
743 (ecase (car entry)
744 (:entry
745 (let* ((info (leaf-info (cdr entry)))
746 (handle (gethash info (fasl-file-entry-table file))))
747 (cond
748 (handle
749 (dump-push handle file))
750 (t
751 (entry-patches (cons info (+ i vm:code-constants-offset)))
752 (dump-fop 'lisp::fop-misc-trap file)))))
753 (:load-time-value
754 (dump-push (cdr entry) file))
755 (:fdefinition
756 (dump-object (cdr entry) file)
757 (dump-fop 'lisp::fop-fdefinition file))
758 (:type-predicate
759 (dump-object 'load-type-predicate file)
760 (let ((*unparse-function-type-simplify* t))
761 (dump-object (type-specifier (cdr entry)) file))
762 (dump-fop 'lisp::fop-funcall file)
763 (dump-byte 1 file)))))))
764
765 ;; Dump the debug info.
766 (unless gengc
767 (let ((info (make-debug-info :name
768 (component-name *compile-component*)))
769 (*dump-only-valid-structures* nil))
770 (dump-object info file)
771 (let ((info-handle (dump-pop file)))
772 (dump-push info-handle file)
773 (push info-handle (fasl-file-debug-info file)))))
774
775 (let ((num-consts (if gengc
776 (+ (length constants) 2)
777 (1+ (length constants))))
778 (length (if gengc
779 (ceiling length 4)
780 length)))
781 (cond ((and (< num-consts #x100) (< length #x10000))
782 (dump-fop 'lisp::fop-small-code file)
783 (dump-byte num-consts file)
784 (dump-var-signed length 2 file))
785 (t
786 (dump-fop 'lisp::fop-code file)
787 (dump-unsigned-32 num-consts file)
788 (dump-unsigned-32 length file))))
789
790 (dump-segment segment length file)
791 (let ((code-handle (dump-pop file))
792 (patch-table (fasl-file-patch-table file)))
793 (dolist (patch (entry-patches))
794 (push (cons code-handle (cdr patch))
795 (gethash (car patch) patch-table)))
796 code-handle))))
797
798
799 ;;; DUMP-BYTE-FUNCTION -- Internal
800 ;;;
801 ;;; Dump a BYTE-FUNCTION object. We dump the layout and
802 ;;; funcallable-instance info, but rely on the loader setting up the correct
803 ;;; funcallable-instance-function.
804 ;;;
805 (defun dump-byte-function (xep code-handle file)
806 (let ((nslots (- (get-closure-length xep)
807 ;; 1- for header
808 (1- vm:funcallable-instance-info-offset))))
809 (dotimes (i nslots)
810 (if (zerop i)
811 (dump-push code-handle file)
812 (dump-object (%funcallable-instance-info xep i) file)))
813 (dump-object (%funcallable-instance-layout xep) file)
814 (dump-fop 'lisp::fop-make-byte-compiled-function file)
815 (dump-byte nslots file))
816 (undefined-value))
817
818
819 ;;; FASL-DUMP-BYTE-COMPONENT -- Interface
820 ;;;
821 ;;; Dump a byte-component. This is similar to FASL-DUMP-COMPONENT, but
822 ;;; different.
823 ;;;
824 (defun fasl-dump-byte-component (segment length constants xeps file)
825 (declare (type new-assem:segment segment)
826 (type index length)
827 (type vector constants)
828 (type list xeps)
829 (type fasl-file file))
830
831 (let ((code-handle (dump-byte-code-object segment length constants file)))
832 (dolist (noise xeps)
833 (let* ((lambda (car noise))
834 (info (lambda-info lambda))
835 (xep (cdr noise)))
836 (dump-byte-function xep code-handle file)
837 (let* ((entry-handle (dump-pop file))
838 (patch-table (fasl-file-patch-table file))
839 (old (gethash info patch-table)))
840 (setf (gethash info (fasl-file-entry-table file)) entry-handle)
841 (when old
842 (dolist (patch old)
843 (alter-code-object (car patch) (cdr patch)
844 entry-handle file))
845 (remhash info patch-table))))))
846 (undefined-value))
847
848
849 ;;; FASL-DUMP-TOP-LEVEL-LAMBDA-CALL -- Interface
850 ;;;
851 ;;; Dump a FOP-FUNCALL to call an already dumped top-level lambda at load
852 ;;; time.
853 ;;;
854 (defun fasl-dump-top-level-lambda-call (fun file)
855 (declare (type clambda fun) (type fasl-file file))
856 (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file))))
857 (assert handle)
858 (dump-push handle file)
859 (dump-fop 'lisp::fop-funcall-for-effect file)
860 (dump-byte 0 file))
861 (undefined-value))
862
863
864 ;;; FASL-DUMP-SOURCE-INFO -- Interface
865 ;;;
866 ;;; Compute the correct list of DEBUG-SOURCE structures and backpatch all of
867 ;;; the dumped DEBUG-INFO structures. We clear the FASL-FILE-DEBUG-INFO,
868 ;;; so that subsequent components with different source info may be dumped.
869 ;;;
870 (defun fasl-dump-source-info (info file)
871 (declare (type source-info info) (type fasl-file file))
872 (let ((res (debug-source-for-info info))
873 (*dump-only-valid-structures* nil))
874 (dump-object res file)
875 (let ((res-handle (dump-pop file)))
876 (dolist (info-handle (fasl-file-debug-info file))
877 (dump-push res-handle file)
878 (dump-fop 'lisp::fop-structset file)
879 (dump-unsigned-32 info-handle file)
880 (dump-unsigned-32 2 file))))
881
882 (setf (fasl-file-debug-info file) ())
883 (undefined-value))
884
885
886 ;;;; Main entries to object dumping:
887
888 ;;; Dump-Non-Immediate-Object -- Internal
889 ;;;
890 ;;; This function deals with dumping objects that are complex enough so that
891 ;;; we want to cache them in the table, rather than repeatedly dumping them.
892 ;;; If the object is in the EQ-TABLE, then we push it, otherwise, we do a type
893 ;;; dispatch to a type specific dumping function. The type specific branches
894 ;;; do any appropriate EQUAL-TABLE check and table entry.
895 ;;;
896 ;;; When we go to dump the object, we enter it in the CIRCULARITY-TABLE.
897 ;;;
898 (defun dump-non-immediate-object (x file)
899 (let ((index (gethash x (fasl-file-eq-table file))))
900 (cond ((and index (not *cold-load-dump*))
901 (dump-push index file))
902 (t
903 (typecase x
904 (symbol (dump-symbol x file))
905 (list
906 (cond ((and *coalesce-constants* (non-circular-list-p x))
907 (unless (equal-check-table x file)
908 (dump-list x file)
909 (equal-save-object x file)))
910 (t
911 (dump-list x file)
912 (eq-save-object x file))))
913 (layout
914 (dump-layout x file)
915 (eq-save-object x file))
916 (instance
917 (dump-structure x file)
918 (eq-save-object x file))
919 (array
920 (dump-array x file))
921 (number
922 (unless (equal-check-table x file)
923 (etypecase x
924 (ratio (dump-ratio x file))
925 (complex (dump-complex x file))
926 (float (dump-float x file))
927 (integer (dump-integer x file)))
928 (equal-save-object x file)))
929 (t
930 ;;
931 ;; This probably never happens, since bad things are detected
932 ;; during IR1 conversion.
933 (error (intl:gettext "This object cannot be dumped into a fasl file:~% ~S")
934 x))))))
935 (undefined-value))
936
937
938 ;;; Sub-Dump-Object -- Internal
939 ;;;
940 ;;; Dump an object of any type by dispatching to the correct type-specific
941 ;;; dumping function. We pick off immediate objects, symbols and and magic
942 ;;; lists here. Other objects are handled by Dump-Non-Immediate-Object.
943 ;;;
944 ;;; This is the function used for recursive calls to the fasl dumper. We don't
945 ;;; worry about creating circularities here, since it is assumed that there is
946 ;;; a top-level call to Dump-Object.
947 ;;;
948 (defun sub-dump-object (x file)
949 (cond ((listp x)
950 (if x
951 (dump-non-immediate-object x file)
952 (dump-fop 'lisp::fop-empty-list file)))
953 ((symbolp x)
954 (if (eq x t)
955 (dump-fop 'lisp::fop-truth file)
956 (dump-non-immediate-object x file)))
957 ((fixnump x) (dump-integer x file))
958 ((characterp x) (dump-character x file))
959 (t
960 (dump-non-immediate-object x file))))
961
962
963 ;;; Dump-Circularities -- Internal
964 ;;;
965 ;;; Dump stuff to backpatch already dumped objects. Infos is the list of
966 ;;; Circularity structures describing what to do. The patching FOPs take the
967 ;;; value to store on the stack. We compute this value by fetching the
968 ;;; enclosing object from the table, and then CDR'ing it if necessary.
969 ;;;
970 (defun dump-circularities (infos file)
971 (let ((table (fasl-file-eq-table file)))
972 (dolist (info infos)
973 (let* ((value (circularity-value info))
974 (enclosing (circularity-enclosing-object info)))
975 (dump-push (gethash enclosing table) file)
976 (unless (eq enclosing value)
977 (do ((current enclosing (cdr current))
978 (i 0 (1+ i)))
979 ((eq current value)
980 (dump-fop 'lisp::fop-nthcdr file)
981 (dump-unsigned-32 i file))
982 (declare (type index i)))))
983
984 (ecase (circularity-type info)
985 (:rplaca (dump-fop 'lisp::fop-rplaca file))
986 (:rplacd (dump-fop 'lisp::fop-rplacd file))
987 (:svset (dump-fop 'lisp::fop-svset file))
988 (:struct-set (dump-fop 'lisp::fop-structset file)))
989 (dump-unsigned-32 (gethash (circularity-object info) table) file)
990 (dump-unsigned-32 (circularity-index info) file))))
991
992
993 ;;; Dump-Object -- Interface
994 ;;;
995 ;;; Set up stuff for circularity detection, then dump an object. All shared
996 ;;; and circular structure will be exactly preserved within a single call to
997 ;;; Dump-Object. Sharing between objects dumped by separate calls is only
998 ;;; preserved when convenient.
999 ;;;
1000 ;;; We peek at the objec type so that we only pay the circular detection
1001 ;;; overhead on types of objects that might be circular.
1002 ;;;
1003 (defun dump-object (x file)
1004 (if (or (array-header-p x) (simple-vector-p x) (consp x) (%instancep x))
1005 (let ((*circularities-detected* ())
1006 (circ (fasl-file-circularity-table file)))
1007 (clrhash circ)
1008 (sub-dump-object x file)
1009 (when *circularities-detected*
1010 (dump-circularities *circularities-detected* file)
1011 (clrhash circ)))
1012 (sub-dump-object x file)))
1013
1014
1015 ;;;; Load-time-value and make-load-form support.
1016
1017 ;;; FASL-DUMP-LOAD-TIME-VALUE-LAMBDA -- interface.
1018 ;;;
1019 ;;; Emit a funcall of the function and return the handle for the result.
1020 ;;;
1021 (defun fasl-dump-load-time-value-lambda (fun file)
1022 (declare (type clambda fun) (type fasl-file file))
1023 (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file))))
1024 (assert handle)
1025 (dump-push handle file)
1026 (dump-fop 'lisp::fop-funcall file)
1027 (dump-byte 0 file))
1028 (dump-pop file))
1029
1030 ;;; FASL-CONSTANT-ALREADY-DUMPED -- interface.
1031 ;;;
1032 ;;; Return T iff CONSTANT has not already been dumped. It's been dumped
1033 ;;; if it's in the EQ table.
1034 ;;;
1035 (defun fasl-constant-already-dumped (constant file)
1036 (if (or (gethash constant (fasl-file-eq-table file))
1037 (gethash constant (fasl-file-valid-structures file)))
1038 t
1039 nil))
1040
1041 ;;; FASL-NOTE-HANDLE-FOR-CONSTANT -- interface.
1042 ;;;
1043 ;;; Use HANDLE whenever we try to dump CONSTANT. HANDLE should have been
1044 ;;; returned earlier by FASL-DUMP-LOAD-TIME-VALUE-LAMBDA.
1045 ;;;
1046 (defun fasl-note-handle-for-constant (constant handle file)
1047 (let ((table (fasl-file-eq-table file)))
1048 (when (gethash constant table)
1049 (error (intl:gettext "~S already dumped?") constant))
1050 (setf (gethash constant table) handle))
1051 (undefined-value))
1052
1053 ;;; FASL-VALIDATE-STRUCTURE -- interface.
1054 ;;;
1055 ;;; Note that the specified structure can just be dumped by enumerating the
1056 ;;; slots.
1057 ;;;
1058 (defun fasl-validate-structure (structure file)
1059 (setf (gethash structure (fasl-file-valid-structures file)) t)
1060 (undefined-value))
1061
1062
1063
1064 ;;;; Number Dumping:
1065
1066 ;;; Dump a ratio
1067
1068 (defun dump-ratio (x file)
1069 (sub-dump-object (numerator x) file)
1070 (sub-dump-object (denominator x) file)
1071 (dump-fop 'lisp::fop-ratio file))
1072
1073 ;;; Dump a long-float in the current *backend* format which may
1074 ;;; require conversion from the native backend format.
1075 ;;;
1076 #+(and long-float x86)
1077 (defun dump-long-float (float file)
1078 (declare (long-float float))
1079 (let ((exp-bits (long-float-exp-bits float))
1080 (high-bits (long-float-high-bits float))
1081 (low-bits (long-float-low-bits float)))
1082 (cond ((backend-featurep :x86) ; Native dump.
1083 (dump-unsigned-32 low-bits file)
1084 (dump-unsigned-32 high-bits file)
1085 (dump-var-signed exp-bits 2 file))
1086 ((backend-featurep :sparc)
1087 ;; Some format converstion will be needed, just dump 0l0
1088 ;; for now.
1089 (unless (zerop float)
1090 (format t (intl:gettext "Warning: dumping ~s as 0l0~%") float))
1091 (dump-unsigned-32 0 file)
1092 (dump-unsigned-32 0 file)
1093 (dump-unsigned-32 0 file)
1094 (dump-var-signed 0 4 file))
1095 (t
1096 (error (intl:gettext "Unable to dump long-float"))))))
1097
1098 #+(and long-float sparc)
1099 (defun dump-long-float (float file)
1100 (declare (long-float float))
1101 (let ((exp-bits (long-float-exp-bits float))
1102 (high-bits (long-float-high-bits float))
1103 (mid-bits (long-float-mid-bits float))
1104 (low-bits (long-float-low-bits float)))
1105 (cond ((backend-featurep :sparc) ; Native dump
1106 (dump-unsigned-32 low-bits file)
1107 (dump-unsigned-32 mid-bits file)
1108 (dump-unsigned-32 high-bits file)
1109 (dump-var-signed exp-bits 4 file))
1110 (t
1111 (error (intl:gettext "Unable to dump long-float"))))))
1112
1113 #+double-double
1114 (defun dump-double-double-float (float file)
1115 ;; Dump out 2 double-floats
1116 (flet ((dump-double (x)
1117 (declare (double-float x))
1118 (dump-unsigned-32 (double-float-low-bits x) file)
1119 (dump-var-signed (double-float-high-bits x) 4 file)))
1120 (dump-double (kernel:double-double-hi float))
1121 (dump-double (kernel:double-double-lo float))))
1122
1123 #+double-double
1124 (defun dump-complex-double-double-float (z file)
1125 ;; Dump out 2 double-double-floats
1126 (dump-double-double-float (realpart z) file)
1127 (dump-double-double-float (imagpart z) file))
1128
1129 ;;; Or a complex...
1130
1131 (defun dump-complex (x file)
1132 (typecase x
1133 ((complex single-float)
1134 (dump-fop 'lisp::fop-complex-single-float file)
1135 (dump-var-signed (single-float-bits (realpart x)) 4 file)
1136 (dump-var-signed (single-float-bits (imagpart x)) 4 file))
1137 ((complex double-float)
1138 (dump-fop 'lisp::fop-complex-double-float file)
1139 (let ((re (realpart x)))
1140 (declare (double-float re))
1141 (dump-unsigned-32 (double-float-low-bits re) file)
1142 (dump-var-signed (double-float-high-bits re) 4 file))
1143 (let ((im (imagpart x)))
1144 (declare (double-float im))
1145 (dump-unsigned-32 (double-float-low-bits im) file)
1146 (dump-var-signed (double-float-high-bits im) 4 file)))
1147 #+long-float
1148 ((complex long-float)
1149 (dump-fop 'lisp::fop-complex-long-float file)
1150 (dump-long-float (realpart x) file)
1151 (dump-long-float (imagpart x) file))
1152 #+double-double
1153 ((complex double-double-float)
1154 (dump-fop 'lisp::fop-complex-double-double-float file)
1155 (dump-complex-double-double-float x file))
1156 (t
1157 (sub-dump-object (realpart x) file)
1158 (sub-dump-object (imagpart x) file)
1159 (dump-fop 'lisp::fop-complex file))))
1160
1161 ;;; Dump an integer.
1162
1163 (defun dump-integer (n file)
1164 (typecase n
1165 ((signed-byte 8)
1166 (dump-fop 'lisp::fop-byte-integer file)
1167 (dump-byte (logand #xFF n) file))
1168 ((unsigned-byte 31)
1169 (dump-fop 'lisp::fop-word-integer file)
1170 (dump-unsigned-32 n file))
1171 ((signed-byte 32)
1172 (dump-fop 'lisp::fop-word-integer file)
1173 (dump-var-signed n 4 file))
1174 (t
1175 (let ((bytes (ceiling (1+ (integer-length n)) 8)))
1176 (dump-fop* bytes lisp::fop-small-integer lisp::fop-integer file)
1177 (dump-var-signed n bytes file)))))
1178
1179 (defun dump-float (x file)
1180 (etypecase x
1181 (single-float
1182 (dump-fop 'lisp::fop-single-float file)
1183 (dump-var-signed (single-float-bits x) 4 file))
1184 (double-float
1185 (dump-fop 'lisp::fop-double-float file)
1186 (let ((x x))
1187 (declare (double-float x))
1188 (dump-unsigned-32 (double-float-low-bits x) file)
1189 (dump-var-signed (double-float-high-bits x) 4 file)))
1190 #+long-float
1191 (long-float
1192 (dump-fop 'lisp::fop-long-float file)
1193 (dump-long-float x file))
1194 #+double-double
1195 (double-double-float
1196 (dump-fop 'lisp::fop-double-double-float file)
1197 (dump-double-double-float x file))))
1198
1199
1200 ;;;; Symbol Dumping:
1201
1202 ;;; Dump-Package -- Internal
1203 ;;;
1204 ;;; Return the table index of Pkg, adding the package to the table if
1205 ;;; necessary. During cold load, we read the string as a normal string so that
1206 ;;; we can do the package lookup at cold load time.
1207 ;;;
1208 (defun dump-package (pkg file)
1209 (declare (type package pkg) (type fasl-file file) (values index)
1210 (inline assoc))
1211 (cond ((cdr (assoc pkg (fasl-file-packages file) :test #'eq)))
1212 (t
1213 (unless *cold-load-dump*
1214 (dump-fop 'lisp::fop-normal-load file))
1215 (dump-simple-string (package-name pkg) file)
1216 (dump-fop 'lisp::fop-package file)
1217 (unless *cold-load-dump*
1218 (dump-fop 'lisp::fop-maybe-cold-load file))
1219 (let ((entry (dump-pop file)))
1220 (push (cons pkg entry) (fasl-file-packages file))
1221 entry))))
1222
1223
1224 ;;; Dump-Symbol -- Internal
1225 ;;;
1226 ;;; If we get here, it is assumed that the symbol isn't in the table, but we
1227 ;;; are responsible for putting it there when appropriate. To avoid too much
1228 ;;; special-casing, we always push the symbol in the table, but don't record
1229 ;;; that we have done so if *Cold-Load-Dump* is true.
1230 ;;;
1231 (defun dump-symbol (s file)
1232 (let* ((pname (symbol-name s))
1233 (pname-length (length pname))
1234 (pkg (symbol-package s)))
1235
1236 (cond ((null pkg)
1237 (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
1238 lisp::fop-uninterned-symbol-save file))
1239 ;; Why do we do this? It causes weird things to happen if
1240 ;; you're in, say, the KERNEL package when you compile-file
1241 ;; something and load the fasl back in when you're in a
1242 ;; different package.
1243 #-(and)
1244 ((eq pkg *package*)
1245 (dump-fop* pname-length lisp::fop-small-symbol-save
1246 lisp::fop-symbol-save file))
1247 ((eq pkg ext:*lisp-package*)
1248 (dump-fop* pname-length lisp::fop-lisp-small-symbol-save
1249 lisp::fop-lisp-symbol-save file))
1250 ((eq pkg ext:*keyword-package*)
1251 (dump-fop* pname-length lisp::fop-keyword-small-symbol-save
1252 lisp::fop-keyword-symbol-save file))
1253 ((< pname-length 256)
1254 (dump-fop* (dump-package pkg file)
1255 lisp::fop-small-symbol-in-byte-package-save
1256 lisp::fop-small-symbol-in-package-save file)
1257 (dump-byte pname-length file))
1258 (t
1259 (dump-fop* (dump-package pkg file)
1260 lisp::fop-symbol-in-byte-package-save
1261 lisp::fop-symbol-in-package-save file)
1262 (dump-unsigned-32 pname-length file)))
1263
1264 #-unicode
1265 (dump-bytes pname (length pname) file)
1266 #+unicode
1267 (dump-data-maybe-byte-swapping pname (* vm:char-bytes (length pname)) vm:char-bits file)
1268
1269 (unless *cold-load-dump*
1270 (setf (gethash s (fasl-file-eq-table file)) (fasl-file-table-free file)))
1271
1272 (incf (fasl-file-table-free file)))
1273
1274 (undefined-value))
1275
1276
1277 ;;; Dumper for lists.
1278
1279 ;;; Dump-List -- Internal
1280 ;;;
1281 ;;; Dump a list, setting up patching information when there are
1282 ;;; circularities. We scan down the list, checking for CDR and CAR
1283 ;;; circularities.
1284 ;;;
1285 ;;; If there is a CDR circularity, we terminate the list with NIL and make a
1286 ;;; Circularity notation for the CDR of the previous cons.
1287 ;;;
1288 ;;; If there is no CDR circularity, then we mark the current cons and check for
1289 ;;; a CAR circularity. When there is a CAR circularity, we make the CAR NIL
1290 ;;; initially, arranging for the current cons to be patched later.
1291 ;;;
1292 ;;; Otherwise, we recursively call the dumper to dump the current element.
1293 ;;;
1294 ;;; Marking of the conses is inhibited when *cold-load-dump* is true. This
1295 ;;; inhibits all circularity detection.
1296 ;;;
1297 (defun dump-list (list file)
1298 (assert (and list
1299 (not (gethash list (fasl-file-circularity-table file)))))
1300 (do* ((l list (cdr l))
1301 (n 0 (1+ n))
1302 (circ (fasl-file-circularity-table file)))
1303 ((atom l)
1304 (cond ((null l)
1305 (terminate-undotted-list n file))
1306 (t
1307 (sub-dump-object l file)
1308 (terminate-dotted-list n file))))
1309 (declare (type index n))
1310 (let ((ref (gethash l circ)))
1311 (when ref
1312 (push (make-circularity :type :rplacd :object list :index (1- n)
1313 :value l :enclosing-object ref)
1314 *circularities-detected*)
1315 (terminate-undotted-list n file)
1316 (return)))
1317
1318 (unless *cold-load-dump*
1319 (setf (gethash l circ) list))
1320
1321 (let* ((obj (car l))
1322 (ref (gethash obj circ)))
1323 (cond (ref
1324 (push (make-circularity :type :rplaca :object list :index n
1325 :value obj :enclosing-object ref)
1326 *circularities-detected*)
1327 (sub-dump-object nil file))
1328 (t
1329 (sub-dump-object obj file))))))
1330
1331
1332 (defun terminate-dotted-list (n file)
1333 (declare (type index n) (type fasl-file file))
1334 (case n
1335 (1 (dump-fop 'lisp::fop-list*-1 file))
1336 (2 (dump-fop 'lisp::fop-list*-2 file))
1337 (3 (dump-fop 'lisp::fop-list*-3 file))
1338 (4 (dump-fop 'lisp::fop-list*-4 file))
1339 (5 (dump-fop 'lisp::fop-list*-5 file))
1340 (6 (dump-fop 'lisp::fop-list*-6 file))
1341 (7 (dump-fop 'lisp::fop-list*-7 file))
1342 (8 (dump-fop 'lisp::fop-list*-8 file))
1343 (T (do ((nn n (- nn 255)))
1344 ((< nn 256)
1345 (dump-fop 'lisp::fop-list* file)
1346 (dump-byte nn file))
1347 (declare (type index nn))
1348 (dump-fop 'lisp::fop-list* file)
1349 (dump-byte 255 file)))))
1350
1351 ;;; If N > 255, must build list with one list operator, then list* operators.
1352
1353 (defun terminate-undotted-list (n file)
1354 (declare (type index n) (type fasl-file file))
1355 (case n
1356 (1 (dump-fop 'lisp::fop-list-1 file))
1357 (2 (dump-fop 'lisp::fop-list-2 file))
1358 (3 (dump-fop 'lisp::fop-list-3 file))
1359 (4 (dump-fop 'lisp::fop-list-4 file))
1360 (5 (dump-fop 'lisp::fop-list-5 file))
1361 (6 (dump-fop 'lisp::fop-list-6 file))
1362 (7 (dump-fop 'lisp::fop-list-7 file))
1363 (8 (dump-fop 'lisp::fop-list-8 file))
1364 (T (cond ((< n 256)
1365 (dump-fop 'lisp::fop-list file)
1366 (dump-byte n file))
1367 (t (dump-fop 'lisp::fop-list file)
1368 (dump-byte 255 file)
1369 (do ((nn (- n 255) (- nn 255)))
1370 ((< nn 256)
1371 (dump-fop 'lisp::fop-list* file)
1372 (dump-byte nn file))
1373 (declare (type index nn))
1374 (dump-fop 'lisp::fop-list* file)
1375 (dump-byte 255 file)))))))
1376
1377
1378 ;;;; Array dumping:
1379
1380 ;;; DUMP-ARRAY -- Internal.
1381 ;;;
1382 ;;; Dump the array thing.
1383 ;;;
1384 (defun dump-array (x file)
1385 (if (vectorp x)
1386 (dump-vector x file)
1387 (dump-multi-dim-array x file)))
1388
1389 ;;; DUMP-VECTOR -- Internal.
1390 ;;;
1391 ;;; Dump the vector object. If it's not simple, then actually dump a simple
1392 ;;; version of it. But we enter the original in the EQ or EQUAL tables.
1393 ;;;
1394 (defun dump-vector (x file)
1395 (let ((simple-version (if (array-header-p x)
1396 (coerce x
1397 `(simple-array ,(array-element-type x) (*)))
1398 x)))
1399 (typecase simple-version
1400 (simple-base-string
1401 (if *coalesce-constants*
1402 (unless (equal-check-table x file)
1403 (dump-simple-string simple-version file)
1404 (equal-save-object x file))
1405 (dump-simple-string simple-version file)))
1406 (simple-vector
1407 (dump-simple-vector simple-version file)
1408 (eq-save-object x file))
1409 ((simple-array single-float (*))
1410 (dump-single-float-vector simple-version file)
1411 (eq-save-object x file))
1412 ((simple-array double-float (*))
1413 (dump-double-float-vector simple-version file)
1414 (eq-save-object x file))
1415 #+long-float
1416 ((simple-array long-float (*))
1417 (dump-long-float-vector simple-version file)
1418 (eq-save-object x file))
1419 #+double-double
1420 ((simple-array double-double-float (*))
1421 (dump-double-double-float-vector simple-version file)
1422 (eq-save-object x file))
1423 ((simple-array (complex single-float) (*))
1424 (dump-complex-single-float-vector simple-version file)
1425 (eq-save-object x file))
1426 ((simple-array (complex double-float) (*))
1427 (dump-complex-double-float-vector simple-version file)
1428 (eq-save-object x file))
1429 #+long-float
1430 ((simple-array (complex long-float) (*))
1431 (dump-complex-long-float-vector simple-version file)
1432 (eq-save-object x file))
1433 #+double-double
1434 ((simple-array (complex double-double-float) (*))
1435 (dump-complex-double-double-float-vector simple-version file)
1436 (eq-save-object x file))
1437 (t
1438 (dump-i-vector simple-version file)
1439 (eq-save-object x file)))))
1440
1441 ;;; DUMP-SIMPLE-VECTOR -- Internal
1442 ;;;
1443 ;;; Dump a SIMPLE-VECTOR, handling any circularities.
1444 ;;;
1445 (defun dump-simple-vector (v file)
1446 (declare (type simple-vector v) (type fasl-file file))
1447 (note-potential-circularity v file)
1448 (do ((index 0 (1+ index))
1449 (length (length v))
1450 (circ (fasl-file-circularity-table file)))
1451 ((= index length)
1452 (dump-fop* length lisp::fop-small-vector lisp::fop-vector file))
1453 (let* ((obj (aref v index))
1454 (ref (gethash obj circ)))
1455 (cond (ref
1456 (push (make-circularity :type :svset :object v :index index
1457 :value obj :enclosing-object ref)
1458 *circularities-detected*)
1459 (sub-dump-object nil file))
1460 (t
1461 (sub-dump-object obj file))))))
1462
1463 ;;; DUMP-SIMPLE-STRING -- Internal
1464 ;;;
1465 ;;; Dump a SIMPLE-BASE-STRING.
1466 ;;;
1467 (defun dump-simple-string (s file)
1468 (declare (type simple-base-string s))
1469 (let ((length (length s)))
1470 (dump-fop* length lisp::fop-small-string lisp::fop-string file)
1471 #-unicode
1472 (dump-bytes s length file)
1473 #+unicode
1474 (dump-data-maybe-byte-swapping s (* vm:char-bytes length) vm:char-bits file))
1475 (undefined-value))
1476
1477 ;;; DUMP-I-VECTOR -- Internal
1478 ;;;
1479 ;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size
1480 ;;; must be a directly supported I-vector element size, with no extra bits.
1481 ;;;
1482 ;;; If a byte vector, or if the native and target byte orderings are the same,
1483 ;;; then just write the bits. Otherwise, dispatch off of the target byte order
1484 ;;; and write the vector one element at a time.
1485 ;;;
1486 (defun dump-i-vector (vec file &optional data-only)
1487 (declare (type (simple-array * (*)) vec))
1488 (let ((len (length vec)))
1489 (labels ((dump-unsigned (size bytes)
1490 (unless data-only
1491 (dump-fop 'lisp::fop-int-vector file)
1492 (dump-unsigned-32 len file)
1493 (dump-byte size file))
1494 (dump-data-maybe-byte-swapping vec bytes size file))
1495 (dump-signed (size dump-size bytes)
1496 (unless data-only
1497 (dump-fop 'lisp::fop-signed-int-vector file)
1498 (dump-unsigned-32 len file)
1499 (dump-byte size file))
1500 (dump-data-maybe-byte-swapping vec bytes dump-size file)))
1501 (etypecase vec
1502 (simple-bit-vector
1503 (dump-unsigned 1 (ash (+ (the index len) 7) -3)))
1504 ((simple-array (unsigned-byte 2) (*))
1505 (dump-unsigned 2 (ash (+ (the index (ash len 1)) 7) -3)))
1506 ((simple-array (unsigned-byte 4) (*))
1507 (dump-unsigned 4 (ash (+ (the index (ash len 2)) 7) -3)))
1508 ((simple-array (unsigned-byte 8) (*))
1509 (dump-unsigned 8 len))
1510 ((simple-array (unsigned-byte 16) (*))
1511 (dump-unsigned 16 (* 2 len)))
1512 ((simple-array (unsigned-byte 32) (*))
1513 (dump-unsigned 32 (* 4 len)))
1514 ((simple-array (signed-byte 8) (*))
1515 (dump-signed 8 8 len))
1516 ((simple-array (signed-byte 16) (*))
1517 (dump-signed 16 16 (* 2 len)))
1518 ((simple-array (signed-byte 30) (*))
1519 (dump-signed 30 32 (* 4 len)))
1520 ((simple-array (signed-byte 32) (*))
1521 (dump-signed 32 32 (* 4 len)))))))
1522
1523 ;;; DUMP-SINGLE-FLOAT-VECTOR -- internal.
1524 ;;;
1525 (defun dump-single-float-vector (vec file)
1526 (let ((length (length vec)))
1527 (dump-fop 'lisp::fop-single-float-vector file)
1528 (dump-unsigned-32 length file)
1529 (dump-data-maybe-byte-swapping vec (* length vm:word-bytes)
1530 vm:word-bytes file)))
1531
1532 ;;; DUMP-DOUBLE-FLOAT-VECTOR -- internal.
1533 ;;;
1534 (defun dump-double-float-vector (vec file)
1535 (let ((length (length vec)))
1536 (dump-fop 'lisp::fop-double-float-vector file)
1537 (dump-unsigned-32 length file)
1538 (dump-data-maybe-byte-swapping vec (* length vm:word-bytes 2)
1539 (* vm:word-bytes 2) file)))
1540
1541 ;;; DUMP-LONG-FLOAT-VECTOR -- internal.
1542 ;;;
1543 #+long-float
1544 (defun dump-long-float-vector (vec file)
1545 (let ((length (length vec)))
1546 (dump-fop 'lisp::fop-long-float-vector file)
1547 (dump-unsigned-32 length file)
1548 (dump-data-maybe-byte-swapping
1549 vec (* length vm:word-bytes #+x86 3 #+sparc 4)
1550 (* vm:word-bytes #+x86 3 #+sparc 4) file)))
1551
1552 #+double-double
1553 (defun dump-double-double-float-vector (vec file)
1554 (let* ((length (length vec))
1555 (element-size (* 4 vm:word-bytes))
1556 (bytes (* length element-size)))
1557 (dump-fop 'lisp::fop-double-double-float-vector file)
1558 (dump-unsigned-32 length file)
1559 (dump-data-maybe-byte-swapping vec bytes element-size file)))
1560
1561 ;;; DUMP-COMPLEX-SINGLE-FLOAT-VECTOR -- internal.
1562 ;;;
1563 (defun dump-complex-single-float-vector (vec file)
1564 (let ((length (length vec)))
1565 (dump-fop 'lisp::fop-complex-single-float-vector file)
1566 (dump-unsigned-32 length file)
1567 (dump-data-maybe-byte-swapping vec (* length vm:word-bytes 2)
1568 vm:word-bytes file)))
1569
1570 ;;; DUMP-COMPLEX-DOUBLE-FLOAT-VECTOR -- internal.
1571 ;;;
1572 (defun dump-complex-double-float-vector (vec file)
1573 (let ((length (length vec)))
1574 (dump-fop 'lisp::fop-complex-double-float-vector file)
1575 (dump-unsigned-32 length file)
1576 (dump-data-maybe-byte-swapping vec (* length vm:word-bytes 2 2)
1577 (* vm:word-bytes 2) file)))
1578
1579 #+double-double
1580 (defun dump-complex-double-double-float-vector (vec file)
1581 (let* ((length (length vec))
1582 (element-size (* 8 vm:word-bytes))
1583 (bytes (* length element-size)))
1584 (dump-fop 'lisp::fop-complex-double-double-float-vector file)
1585 (dump-unsigned-32 length file)
1586 (dump-data-maybe-byte-swapping vec bytes element-size file)))
1587
1588 ;;; DUMP-COMPLEX-LONG-FLOAT-VECTOR -- internal.
1589 ;;;
1590 #+long-float
1591 (defun dump-complex-long-float-vector (vec file)
1592 (let ((length (length vec)))
1593 (dump-fop 'lisp::fop-complex-long-float-vector file)
1594 (dump-unsigned-32 length file)
1595 (dump-data-maybe-byte-swapping
1596 vec (* length vm:word-bytes #+x86 3 #+sparc 4 2)
1597 (* vm:word-bytes #+x86 3 #+sparc 4) file)))
1598
1599 ;;; DUMP-DATA-BITS-MAYBE-BYTE-SWAPPING -- internal.
1600 ;;;
1601 ;;; Dump BYTES of data from DATA-VECTOR (which must be some unboxed vector)
1602 ;;; byte-swapping if necessary.
1603 ;;;
1604 (defun dump-data-maybe-byte-swapping (data-vector bytes element-size file)
1605 (declare (type (simple-array * (*)) data-vector)
1606 (type unsigned-byte bytes)
1607 (type (integer 1) element-size))
1608 (cond ((or (eq (backend-byte-order *backend*)
1609 (backend-byte-order *native-backend*))
1610 (= element-size vm:byte-bits))
1611 (dump-bytes data-vector bytes file))
1612 ((>= element-size vm:word-bits)
1613 (let* ((words-per-element (/ element-size vm:word-bits))
1614 (bytes-per-element (* words-per-element vm:word-bytes))
1615 (elements (/ bytes bytes-per-element))
1616 (result (make-array bytes :element-type '(unsigned-byte 8))))
1617 (declare (type (integer 1 #.most-positive-fixnum)
1618 words-per-element bytes-per-element elements))
1619 (dotimes (index elements)
1620 (dotimes (offset words-per-element)
1621 (let ((word (%raw-bits data-vector
1622 (+ (* index words-per-element)
1623 vm:vector-data-offset
1624 (1- words-per-element)
1625 (- offset)))))
1626 (setf (%raw-bits result (+ (* index words-per-element)
1627 vm:vector-data-offset
1628 offset))
1629 (logior (ash (ldb (byte 8 0) word) 24)
1630 (ash (ldb (byte 8 8) word) 16)
1631 (ash (ldb (byte 8 16) word) 8)
1632 (ldb (byte 8 24) word))))))
1633 (dump-bytes result bytes file)))
1634 ((> element-size vm:byte-bits)
1635 (let* ((bytes-per-element (/ element-size vm:byte-bits))
1636 (elements (/ bytes bytes-per-element))
1637 (result (make-array elements
1638 :element-type
1639 `(unsigned-byte ,element-size))))
1640 (declare (type (integer 1 #.most-positive-fixnum)
1641 bytes-per-element)
1642 (type unsigned-byte elements))
1643 (if (stringp data-vector)
1644 (dotimes (index elements)
1645 (let ((c (char-code (aref data-vector index))))
1646 (setf (aref result index) (logior (ash (ldb (byte 8 0) c) 8)
1647 (ldb (byte 8 8) c)))))
1648 (dotimes (index elements)
1649 (let ((element (aref data-vector index))
1650 (new-element 0))
1651 (dotimes (i bytes-per-element)
1652 (setf new-element
1653 (logior (ash new-element vm:byte-bits)
1654 (ldb (byte vm:byte-bits 0) element)))
1655 (setf element (ash element (- vm:byte-bits))))
1656 (setf (aref result index) new-element))))
1657 (dump-bytes result bytes file)))
1658 (t
1659 (let* ((elements-per-byte (/ vm:byte-bits element-size))
1660 (elements (* bytes elements-per-byte))
1661 (len (length data-vector))
1662 (result (make-array elements
1663 :element-type
1664 `(unsigned-byte ,element-size))))
1665 (dotimes (index elements)
1666 (multiple-value-bind (byte-index additional)
1667 (truncate index elements-per-byte)
1668 (let ((src-idx (- (* (1+ byte-index) elements-per-byte)
1669 (1+ additional))))
1670 (setf (aref result index)
1671 (if (>= src-idx len)
1672 0
1673 (aref data-vector src-idx))))))
1674 (dump-bytes result bytes file)))))
1675
1676 ;;; Dump-Multi-Dim-Array -- Internal
1677 ;;;
1678 ;;; Dump a multi-dimensional array. Note: any displacements are folded out.
1679 ;;;
1680 (defun dump-multi-dim-array (array file)
1681 (let ((rank (array-rank array)))
1682 (dotimes (i rank)
1683 (dump-integer (array-dimension array i) file))
1684 (lisp::with-array-data ((vector array) (start) (end))
1685 (if (and (= start 0) (= end (length vector)))
1686 (sub-dump-object vector file)
1687 (sub-dump-object (subseq vector start end) file)))
1688 (dump-fop 'lisp::fop-array file)
1689 (dump-unsigned-32 rank file)
1690 (eq-save-object array file)))
1691
1692
1693 ;;; Dump a character.
1694
1695 #-unicode
1696 (defun dump-character (ch file)
1697 (dump-fop 'lisp::fop-short-character file)
1698 (dump-byte (char-code ch) file))
1699
1700 #+unicode
1701 (defun dump-character (ch file)
1702 (dump-fop 'lisp::fop-short-character file)
1703 ;; Characters are always little-endian
1704 (let ((code (char-code ch)))
1705 (dump-byte (ldb (byte 8 0) code) file)
1706 (dump-byte (ldb (byte 8 8) code) file)))
1707
1708
1709 ;;; Dump a structure.
1710
1711 (defun dump-structure (struct file)
1712 (when *dump-only-valid-structures*
1713 (unless (gethash struct (fasl-file-valid-structures file))
1714 (error (intl:gettext "Attempt to dump invalid structure:~% ~S~%How did this happen?")
1715 struct)))
1716 (note-potential-circularity struct file)
1717 (do ((index 0 (1+ index))
1718 (length (%instance-length struct))
1719 (circ (fasl-file-circularity-table file)))
1720 ((= index length)
1721 (dump-fop* length lisp::fop-small-struct lisp::fop-struct file))
1722 (let* ((obj #+ns-boot
1723 (if (zerop index)
1724 (%instance-layout struct)
1725 (%instance-ref struct index))
1726 #-ns-boot
1727 (%instance-ref struct index))
1728 (ref (gethash obj circ)))
1729 (cond (ref
1730 (push (make-circularity :type :struct-set
1731 :object struct
1732 :index index
1733 :value obj
1734 :enclosing-object ref)
1735 *circularities-detected*)
1736 (sub-dump-object nil file))
1737 (t
1738 (sub-dump-object obj file))))))
1739
1740 (defun dump-layout (obj file)
1741 (unless (member (layout-invalid obj) '(nil :compiler))
1742 (compiler-error _N"Dumping reference to obsolete class: ~S"
1743 (layout-class obj)))
1744 (let ((name (%class-name (layout-class obj))))
1745 (assert name)
1746 (dump-fop 'lisp::fop-normal-load file)
1747 (let ((*cold-load-dump* t))
1748 (dump-object name file))
1749 (dump-fop 'lisp::fop-maybe-cold-load file))
1750 (sub-dump-object (layout-inherits obj) file)
1751 (sub-dump-object (layout-inheritance-depth obj) file)
1752 (sub-dump-object (layout-length obj) file)
1753 (dump-fop 'lisp::fop-layout file))

  ViewVC Help
Powered by ViewVC 1.1.5