X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=1b51237c6857b2a228685d96749106420fd24ad7;hb=e3113504fca73ebd1b992930315386d9d3ae5d18;hp=a5d750c10833f9b40f895f5ab3b5515985abc99b;hpb=3ca73f72116001579bde0f59e5aa1359cc41631e;p=sbcl.git diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index a5d750c..1b51237 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -272,83 +272,82 @@ ;;;; 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) - ;; 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 *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) (declare (type fasl-output fasl-output)) - ;; sanity checks - (aver (zerop (hash-table-count (fasl-output-patch-table fasl-output)))) - - ;; End the group. - (dump-fop 'fop-verify-empty-stack fasl-output) - (dump-fop 'fop-verify-table-size fasl-output) - (dump-word (fasl-output-table-free fasl-output) - fasl-output) - (dump-fop 'fop-end-group fasl-output) + (unless abort-p + ;; sanity checks + (aver (zerop (hash-table-count (fasl-output-patch-table fasl-output)))) + ;; End the group. + (dump-fop 'fop-verify-empty-stack fasl-output) + (dump-fop 'fop-verify-table-size fasl-output) + (dump-word (fasl-output-table-free fasl-output) + fasl-output) + (dump-fop 'fop-end-group fasl-output)) ;; That's all, folks. (close (fasl-output-stream fasl-output) :abort abort-p) @@ -384,7 +383,7 @@ ;; 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)) @@ -498,13 +497,15 @@ (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. @@ -1216,6 +1217,7 @@ (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)))