X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=f2152f0fd3408d4a810a8669b408cdf3581f5115;hb=2378406d6eda78090dfe05e372438495aeace5e0;hp=1ad330cb7fb41461c33908d40128c91293ea6f3e;hpb=c2431e2d0d0222a3cf20cfdfa48201bdcc65cd76;p=sbcl.git diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 1ad330c..f2152f0 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -91,10 +91,6 @@ ;;; dumping uses the table. (defvar *circularities-detected*) -;;; used to inhibit table access when dumping forms to be read by the -;;; cold loader -(defvar *cold-load-dump* nil) - ;;; used to turn off the structure validation during dumping of source ;;; info (defvar *dump-only-valid-structures* t) @@ -113,6 +109,14 @@ (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 @@ -186,156 +190,145 @@ (incf (fasl-output-table-free fasl-output)))) ;;; If X is in File's EQUAL-TABLE, then push the object and return T, -;;; otherwise NIL. If *COLD-LOAD-DUMP* is true, then do nothing and -;;; return NIL. +;;; otherwise NIL. (defun equal-check-table (x fasl-output) (declare (type fasl-output fasl-output)) - (unless *cold-load-dump* - (let ((handle (gethash x (fasl-output-equal-table fasl-output)))) - (cond - (handle (dump-push handle fasl-output) t) - (t nil))))) + (let ((handle (gethash x (fasl-output-equal-table fasl-output)))) + (cond + (handle (dump-push handle fasl-output) t) + (t nil)))) (defun string-check-table (x fasl-output) (declare (type fasl-output fasl-output) (type string x)) - (unless *cold-load-dump* - (let ((handle (cdr (assoc - (array-element-type x) - (gethash x (fasl-output-equal-table fasl-output)))))) - (cond - (handle (dump-push handle fasl-output) t) - (t nil))))) + (let ((handle (cdr (assoc + #+sb-xc-host 'base-char ; for repeatable xc fasls + #-sb-xc-host (array-element-type x) + (gethash x (fasl-output-equal-table fasl-output)))))) + (cond + (handle (dump-push handle fasl-output) t) + (t nil)))) ;;; These functions are called after dumping an object to save the ;;; object in the table. The object (also passed in as X) must already -;;; be on the top of the FOP stack. If *COLD-LOAD-DUMP* is true, then -;;; we don't do anything. +;;; be on the top of the FOP stack. (defun eq-save-object (x fasl-output) (declare (type fasl-output fasl-output)) - (unless *cold-load-dump* - (let ((handle (dump-pop fasl-output))) - (setf (gethash x (fasl-output-eq-table fasl-output)) handle) - (dump-push handle fasl-output))) + (let ((handle (dump-pop fasl-output))) + (setf (gethash x (fasl-output-eq-table fasl-output)) handle) + (dump-push handle fasl-output)) (values)) (defun equal-save-object (x fasl-output) (declare (type fasl-output fasl-output)) - (unless *cold-load-dump* - (let ((handle (dump-pop fasl-output))) - (setf (gethash x (fasl-output-equal-table fasl-output)) handle) - (setf (gethash x (fasl-output-eq-table fasl-output)) handle) - (dump-push handle fasl-output))) + (let ((handle (dump-pop fasl-output))) + (setf (gethash x (fasl-output-equal-table fasl-output)) handle) + (setf (gethash x (fasl-output-eq-table fasl-output)) handle) + (dump-push handle fasl-output)) (values)) (defun string-save-object (x fasl-output) (declare (type fasl-output fasl-output) (type string x)) - (unless *cold-load-dump* - (let ((handle (dump-pop fasl-output))) - (push (cons (array-element-type x) handle) - (gethash x (fasl-output-equal-table fasl-output))) - (setf (gethash x (fasl-output-eq-table fasl-output)) handle) - (dump-push handle fasl-output))) + (let ((handle (dump-pop fasl-output))) + (push (cons #+sb-xc-host 'base-char ; repeatable xc fasls + #-sb-xc-host (array-element-type x) + handle) + (gethash x (fasl-output-equal-table fasl-output))) + (setf (gethash x (fasl-output-eq-table fasl-output)) handle) + (dump-push handle fasl-output)) (values)) -;;; Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is -;;; true. This is called on objects that we are about to dump might -;;; have a circular path through them. +;;; Record X in File's CIRCULARITY-TABLE. This is called on objects +;;; that we are about to dump might have a circular path through them. ;;; ;;; The object must not currently be in this table, since the dumper ;;; should never be recursively called on a circular reference. ;;; Instead, the dumping function must detect the circularity and ;;; arrange for the dumped object to be patched. (defun note-potential-circularity (x fasl-output) - (unless *cold-load-dump* - (let ((circ (fasl-output-circularity-table fasl-output))) - (aver (not (gethash x circ))) - (setf (gethash x circ) x))) - (values)) - -;;; Dump FORM to a fasl file so that it evaluated at load time in normal -;;; load and at cold-load time in cold load. This is used to dump package -;;; frobbing forms. -(defun fasl-dump-cold-load-form (form fasl-output) - (declare (type fasl-output fasl-output)) - (dump-fop 'fop-normal-load fasl-output) - (let ((*cold-load-dump* t)) - (dump-object form fasl-output)) - (dump-fop 'fop-eval-for-effect fasl-output) - (dump-fop 'fop-maybe-cold-load fasl-output) + (let ((circ (fasl-output-circularity-table fasl-output))) + (aver (not (gethash x circ))) + (setf (gethash x circ) x)) (values)) ;;;; 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))) + ;; Before the actual FASL header, write a shebang line using the current + ;; runtime path, so our fasls can be executed directly from the shell. + (when *runtime-pathname* + (fasl-write-string + (format nil "#!~A --script~%" + (native-namestring *runtime-pathname* :as-file t)) + 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~% ~ + using ~A version ~A~%" + where + (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) @@ -353,7 +346,7 @@ ;;; When we go to dump the object, we enter it in the CIRCULARITY-TABLE. (defun dump-non-immediate-object (x file) (let ((index (gethash x (fasl-output-eq-table file)))) - (cond ((and index (not *cold-load-dump*)) + (cond (index (dump-push index file)) (t (typecase x @@ -371,7 +364,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)) @@ -396,6 +389,14 @@ (float (dump-float x file)) (integer (dump-integer x file))) (equal-save-object x file))) + #!+sb-simd-pack + (simd-pack + (unless (equal-check-table x file) + (dump-fop 'fop-simd-pack file) + (dump-integer-as-n-bytes (%simd-pack-tag x) 8 file) + (dump-integer-as-n-bytes (%simd-pack-low x) 8 file) + (dump-integer-as-n-bytes (%simd-pack-high x) 8 file)) + (equal-save-object x file)) (t ;; This probably never happens, since bad things tend to ;; be detected during IR1 conversion. @@ -485,13 +486,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. @@ -547,37 +550,55 @@ (dump-fop 'fop-long-float file) (dump-long-float x file)))) +(defun dump-complex-single-float (re im file) + (declare (single-float re im)) + (dump-fop 'fop-complex-single-float file) + (dump-integer-as-n-bytes (single-float-bits re) 4 file) + (dump-integer-as-n-bytes (single-float-bits im) 4 file)) + +(defun dump-complex-double-float (re im file) + (declare (double-float re im)) + (dump-fop 'fop-complex-double-float file) + (dump-integer-as-n-bytes (double-float-low-bits re) 4 file) + (dump-integer-as-n-bytes (double-float-high-bits re) 4 file) + (dump-integer-as-n-bytes (double-float-low-bits im) 4 file) + (dump-integer-as-n-bytes (double-float-high-bits im) 4 file)) + +(defun dump-complex-rational (re im file) + (sub-dump-object re file) + (sub-dump-object im file) + (dump-fop 'fop-complex file)) + +#+sb-xc-host +(defun dump-complex (x file) + (let ((re (realpart x)) + (im (imagpart x))) + (cond ((and (typep re 'single-float) + (typep im 'single-float)) + (dump-complex-single-float re im file)) + ((and (typep re 'double-float) + (typep im 'double-float)) + (dump-complex-double-float re im file)) + ((and (typep re 'rational) + (typep im 'rational)) + (dump-complex-rational re im file)) + (t + (bug "Complex number too complex: ~S" x))))) + +#-sb-xc-host (defun dump-complex (x file) (typecase x - #-sb-xc-host ((complex single-float) - (dump-fop 'fop-complex-single-float file) - (dump-integer-as-n-bytes (single-float-bits (realpart x)) 4 file) - (dump-integer-as-n-bytes (single-float-bits (imagpart x)) 4 file)) - #-sb-xc-host + (dump-complex-single-float (realpart x) (imagpart x) file)) ((complex double-float) - (dump-fop 'fop-complex-double-float file) - (let ((re (realpart x))) - (declare (double-float re)) - (dump-integer-as-n-bytes (double-float-low-bits re) 4 file) - (dump-integer-as-n-bytes (double-float-high-bits re) 4 file)) - (let ((im (imagpart x))) - (declare (double-float im)) - (dump-integer-as-n-bytes (double-float-low-bits im) 4 file) - (dump-integer-as-n-bytes (double-float-high-bits im) 4 file))) + (dump-complex-double-float (realpart x) (imagpart x) file)) #!+long-float ((complex long-float) - ;; (There's no easy way to mix #!+LONG-FLOAT and #-SB-XC-HOST - ;; conditionalization at read time, so we do this SB-XC-HOST - ;; conditional at runtime instead.) - #+sb-xc-host (error "can't dump COMPLEX-LONG-FLOAT in cross-compiler") (dump-fop 'fop-complex-long-float file) (dump-long-float (realpart x) file) (dump-long-float (imagpart x) file)) (t - (sub-dump-object (realpart x) file) - (sub-dump-object (imagpart x) file) - (dump-fop 'fop-complex file)))) + (dump-complex-rational (realpart x) (imagpart x) file)))) ;;;; symbol dumping @@ -594,21 +615,16 @@ (declare (inline assoc)) (cond ((cdr (assoc pkg (fasl-output-packages file) :test #'eq))) (t - (unless *cold-load-dump* - (dump-fop 'fop-normal-load file)) - #+sb-xc-host - (dump-simple-base-string - (coerce (package-name pkg) 'simple-base-string) - file) - #-sb-xc-host - (#!+sb-unicode dump-simple-character-string - #!-sb-unicode dump-simple-base-string - (coerce (package-name pkg) '(simple-array character (*))) - file) - (dump-fop 'fop-package file) - (unless *cold-load-dump* - (dump-fop 'fop-maybe-cold-load file)) - (let ((entry (dump-pop file))) + (let ((s (package-name pkg))) + (dump-fop* (length s) fop-small-named-package-save fop-named-package-save file) + #+sb-xc-host + (dump-base-chars-of-string (coerce s 'simple-base-string) file) + #-sb-xc-host + (#!+sb-unicode dump-characters-of-string + #!-sb-unicode dump-base-chars-of-string + (coerce s '(simple-array character (*))) file)) + (let ((entry (fasl-output-table-free file))) + (incf (fasl-output-table-free file)) (push (cons pkg entry) (fasl-output-packages file)) entry)))) @@ -628,9 +644,6 @@ ;;; ;;; Otherwise, we recursively call the dumper to dump the current ;;; element. -;;; -;;; Marking of the conses is inhibited when *COLD-LOAD-DUMP* is true. -;;; This inhibits all circularity detection. (defun dump-list (list file) (aver (and list (not (gethash list (fasl-output-circularity-table file))))) @@ -655,8 +668,7 @@ (terminate-undotted-list n file) (return))) - (unless *cold-load-dump* - (setf (gethash l circ) list)) + (setf (gethash l circ) list) (let* ((obj (car l)) (ref (gethash obj circ))) @@ -925,7 +937,7 @@ (let ((code (sb!xc:char-code char))) (cond ((< code 256) - (dump-fop 'fop-short-character file) + (dump-fop 'fop-short-character file) (dump-byte code file)) (t (dump-fop 'fop-character file) @@ -949,15 +961,21 @@ (values)) ;;; If we get here, it is assumed that the symbol isn't in the table, -;;; but we are responsible for putting it there when appropriate. To -;;; avoid too much special-casing, we always push the symbol in the -;;; table, but don't record that we have done so if *COLD-LOAD-DUMP* -;;; is true. +;;; but we are responsible for putting it there when appropriate. (defun dump-symbol (s file) (declare (type fasl-output file)) (let* ((pname (symbol-name s)) (pname-length (length pname)) (pkg (symbol-package s))) + ;; see comment in genesis: we need this here for repeatable fasls + #+sb-xc-host + (multiple-value-bind (cl-symbol cl-status) + (find-symbol (symbol-name s) sb!int:*cl-package*) + (when (and (eq s cl-symbol) + (eq cl-status :external)) + ;; special case, to work around possible xc host "design + ;; choice" weirdness in COMMON-LISP package + (setq pkg sb!int:*cl-package*))) (cond ((null pkg) (dump-fop* pname-length @@ -1000,9 +1018,8 @@ #!-sb-unicode dump-base-chars-of-string pname file) - (unless *cold-load-dump* - (setf (gethash s (fasl-output-eq-table file)) - (fasl-output-table-free file))) + (setf (gethash s (fasl-output-eq-table file)) + (fasl-output-table-free file)) (incf (fasl-output-table-free file))) @@ -1034,19 +1051,13 @@ (position (fixup-note-position note)) (name (fixup-name fixup)) (flavor (fixup-flavor fixup))) - (dump-fop 'fop-normal-load fasl-output) - (let ((*cold-load-dump* t)) - (dump-object kind fasl-output)) - (dump-fop 'fop-maybe-cold-load fasl-output) + (dump-object kind fasl-output) ;; Depending on the flavor, we may have various kinds of ;; noise before the position. (ecase flavor (:assembly-routine (aver (symbolp name)) - (dump-fop 'fop-normal-load fasl-output) - (let ((*cold-load-dump* t)) - (dump-object name fasl-output)) - (dump-fop 'fop-maybe-cold-load fasl-output) + (dump-object name fasl-output) (dump-fop 'fop-assembler-fixup fasl-output)) ((:foreign :foreign-dataref) (aver (stringp name)) @@ -1182,10 +1193,7 @@ (dump-word length file) (write-segment-contents code-segment (fasl-output-stream file)) (dolist (routine routines) - (dump-fop 'fop-normal-load file) - (let ((*cold-load-dump* t)) - (dump-object (car routine) file)) - (dump-fop 'fop-maybe-cold-load file) + (dump-object (car routine) file) (dump-fop 'fop-assembler-routine file) (dump-word (label-position (cdr routine)) file)) (dump-fixups fixups file) @@ -1203,6 +1211,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-info entry) file) (dump-fop 'fop-fun-entry file) (dump-word (label-position (sb!c::entry-info-offset entry)) file) (dump-pop file))) @@ -1228,7 +1237,6 @@ (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) @@ -1244,7 +1252,6 @@ 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))) @@ -1296,14 +1303,19 @@ (declare (type sb!c::source-info info)) (let ((res (sb!c::debug-source-for-info info)) (*dump-only-valid-structures* nil)) + #+sb-xc-host (setf (sb!c::debug-source-created res) 0 + (sb!c::debug-source-compiled res) 0) (dump-object res fasl-output) (let ((res-handle (dump-pop fasl-output))) (dolist (info-handle (fasl-output-debug-info fasl-output)) (dump-push res-handle fasl-output) (dump-fop 'fop-structset fasl-output) (dump-word info-handle fasl-output) - ;; FIXME: what is this bare `2'? --njf, 2004-08-16 - (dump-word 2 fasl-output)))) + (dump-word sb!c::+debug-info-source-index+ fasl-output)) + #+sb-xc-host + (progn + (dump-push res-handle fasl-output) + (dump-fop 'fop-note-debug-source fasl-output)))) (setf (fasl-output-debug-info fasl-output) nil) (values)) @@ -1346,10 +1358,7 @@ (let ((name (classoid-name (layout-classoid obj)))) (unless name (compiler-error "dumping anonymous layout: ~S" obj)) - (dump-fop 'fop-normal-load file) - (let ((*cold-load-dump* t)) - (dump-object name file)) - (dump-fop 'fop-maybe-cold-load file)) + (dump-object name file)) (sub-dump-object (layout-inherits obj) file) (sub-dump-object (layout-depthoid obj) file) (sub-dump-object (layout-length obj) file)