(type string x))
(unless *cold-load-dump*
(let ((handle (cdr (assoc
- (array-element-type x)
+ #+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)
(type string x))
(unless *cold-load-dump*
(let ((handle (dump-pop fasl-output)))
- (push (cons (array-element-type x) handle)
+ (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)))
on ~A~% ~
using ~A version ~A~%"
where
- (format-universal-time nil (get-universal-time))
- (machine-instance)
+ #+sb-xc-host "cross-compile time"
+ #-sb-xc-host (format-universal-time nil (get-universal-time))
+ #+sb-xc-host "cross-compile host"
+ #-sb-xc-host (machine-instance)
(sb!xc:lisp-implementation-type)
(sb!xc:lisp-implementation-version))))
stream)
(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)
(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))))
\f
;;;; symbol dumping
(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
(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))
\f
projects / sbcl.git / blobdiff