(dotimes (i sb!vm:n-word-bytes)
(write-byte (ldb (byte 8 (* 8 i)) num) stream))))
+;; Dump a 32-bit integer.
+(defun dump-unsigned-byte-32 (num fasl-output)
+ (declare (type sb!vm:word num))
+ (declare (type fasl-output fasl-output))
+ (let ((stream (fasl-output-stream fasl-output)))
+ (dotimes (i 4)
+ (write-byte (ldb (byte 8 (* 8 i)) num) stream))))
+
;;; Dump NUM to the fasl stream, represented by N bytes. This works
;;; for either signed or unsigned integers. There's no range checking
;;; -- if you don't specify enough bytes for the number to fit, this
\f
;;;; opening and closing fasl files
-;;; A utility function to write strings to (unsigned-byte 8) streams.
-;;; We restrict this to ASCII (with the averrance) because of
-;;; ambiguity of higher bytes: Unicode, some ISO-8859-x, or what? This
-;;; could be revisited in the event of doing funky things with stream
-;;; encodings -- CSR, 2002-04-25
-(defun fasl-write-string (string stream)
- (loop for char across string
- do (let ((code (char-code char)))
- (aver (<= 0 code 127))
- (write-byte code stream))))
-
;;; Open a fasl file, write its header, and return a FASL-OUTPUT
;;; object for dumping to it. Some human-readable information about
;;; the source code is given by the string WHERE.
(defun open-fasl-output (name where)
(declare (type pathname name))
- (let* ((stream (open name
- :direction :output
- :if-exists :supersede
- :element-type 'sb!assem:assembly-unit))
- (res (make-fasl-output :stream stream)))
-
- ;; Begin the header with the constant machine-readable (and
- ;; semi-human-readable) string which is used to identify fasl files.
- (fasl-write-string *fasl-header-string-start-string* stream)
-
- ;; The constant string which begins the header is followed by
- ;; arbitrary human-readable text, terminated by a special
- ;; character code.
- (fasl-write-string
- (with-standard-io-syntax
- (let ((*print-readably* nil)
- (*print-pretty* nil))
- (format nil
- "~% ~
- compiled from ~S~% ~
- at ~A~% ~
- on ~A~% ~
- using ~A version ~A~%"
- where
- (format-universal-time nil (get-universal-time))
- (machine-instance)
- (sb!xc:lisp-implementation-type)
- (sb!xc:lisp-implementation-version))))
- stream)
- (dump-byte +fasl-header-string-stop-char-code+ res)
-
- ;; Finish the header by outputting fasl file implementation,
- ;; version, and key *FEATURES*.
- (flet ((dump-counted-string (string)
- (dump-word (length string) res)
- (dotimes (i (length string))
- (dump-byte (char-code (aref string i)) res))))
- (dump-counted-string (symbol-name +backend-fasl-file-implementation+))
- (dump-word +fasl-file-version+ res)
- (dump-counted-string *features-affecting-fasl-format*))
-
- res))
+ (flet ((fasl-write-string (string stream)
+ ;; SB-EXT:STRING-TO-OCTETS is not available while cross-compiling
+ #+sb-xc-host
+ (loop for char across string
+ do (let ((code (char-code char)))
+ (unless (<= 0 code 127)
+ (setf char #\?))
+ (write-byte code stream)))
+ ;; UTF-8 is safe to use, because +FASL-HEADER-STRING-STOP-CHAR-CODE+
+ ;; may not appear in UTF-8 encoded bytes
+ #-sb-xc-host
+ (write-sequence (string-to-octets string :external-format :utf-8)
+ stream)))
+ (let* ((stream (open name
+ :direction :output
+ :if-exists :supersede
+ :element-type 'sb!assem:assembly-unit))
+ (res (make-fasl-output :stream stream)))
+ ;; Begin the header with the constant machine-readable (and
+ ;; semi-human-readable) string which is used to identify fasl files.
+ (fasl-write-string *fasl-header-string-start-string* stream)
+ ;; The constant string which begins the header is followed by
+ ;; arbitrary human-readable text, terminated by
+ ;; +FASL-HEADER-STRING-STOP-CHAR-CODE+.
+ (fasl-write-string
+ (with-standard-io-syntax
+ (let ((*print-readably* nil)
+ (*print-pretty* nil))
+ (format nil
+ "~% ~
+ compiled from ~S~% ~
+ at ~A~% ~
+ on ~A~% ~
+ using ~A version ~A~%"
+ where
+ (format-universal-time nil (get-universal-time))
+ (machine-instance)
+ (sb!xc:lisp-implementation-type)
+ (sb!xc:lisp-implementation-version))))
+ stream)
+ (dump-byte +fasl-header-string-stop-char-code+ res)
+ ;; Finish the header by outputting fasl file implementation,
+ ;; version, and key *FEATURES*.
+ (flet ((dump-counted-string (string)
+ ;; The count is dumped as a 32-bit unsigned-byte even on 64-bit
+ ;; platforms. This ensures that a x86-64 SBCL can gracefully
+ ;; detect an error when trying to read a x86 fasl, instead
+ ;; of choking on a ridiculously long counted string.
+ ;; -- JES, 2005-12-30
+ (dump-unsigned-byte-32 (length string) res)
+ (dotimes (i (length string))
+ (dump-byte (char-code (aref string i)) res))))
+ (dump-counted-string (symbol-name +backend-fasl-file-implementation+))
+ (dump-word +fasl-file-version+ res)
+ (dump-counted-string (sb!xc:lisp-implementation-version))
+ (dump-counted-string *features-affecting-fasl-format*))
+ res)))
;;; Close the specified FASL-OUTPUT, aborting the write if ABORT-P.
(defun close-fasl-output (fasl-output abort-p)
;; take a little more care while dumping these.
;; So if better list coalescing is needed, start here.
;; -- WHN 2000-11-07
- (if (cyclic-list-p x)
+ (if (maybe-cyclic-p x)
(progn
(dump-list x file)
(eq-save-object x file))
(dump-byte 0 file))
(dump-pop file))
-;;; Return T iff CONSTANT has not already been dumped. It's been
-;;; dumped if it's in the EQ table.
+;;; Return T iff CONSTANT has already been dumped. It's been dumped if
+;;; it's in the EQ table.
+;;;
+;;; Note: historically (1) the above comment was "T iff ... has not been dumped",
+;;; (2) the test was was also true if the constant had been validated / was in
+;;; the valid objects table. This led to substructures occasionally skipping the
+;;; validation, and hence failing the "must have been validated" test.
(defun fasl-constant-already-dumped-p (constant file)
- (if (or (gethash constant (fasl-output-eq-table file))
- (gethash constant (fasl-output-valid-structures file)))
- t
- nil))
+ (and (gethash constant (fasl-output-eq-table file)) t))
;;; Use HANDLE whenever we try to dump CONSTANT. HANDLE should have been
;;; returned earlier by FASL-DUMP-LOAD-TIME-VALUE-LAMBDA.
(dump-object name file)
(dump-object (sb!c::entry-info-arguments entry) file)
(dump-object (sb!c::entry-info-type entry) file)
+ (dump-object (sb!c::entry-info-xref entry) file)
(dump-fop 'fop-fun-entry file)
(dump-word (label-position (sb!c::entry-info-offset entry)) file)
(dump-pop file)))
(declare (type component component) (list trace-table))
(declare (type fasl-output file))
- (dump-fop 'fop-verify-empty-stack file)
(dump-fop 'fop-verify-table-size file)
(dump-word (fasl-output-table-free file) file)
fixups
file))
(2comp (component-info component)))
- (dump-fop 'fop-verify-empty-stack file)
(dolist (entry (sb!c::ir2-component-entries 2comp))
(let ((entry-handle (dump-one-entry entry code-handle file)))
projects / sbcl.git / blobdiff