;;; 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. If BYTE-P is true,
-;;; this file will contain no native code, and is thus largely
-;;; implementation independent.
+;;; the source code is given by the string WHERE.
(defun open-fasl-output (name where)
(declare (type pathname name))
(let* ((stream (open name
\f
;;;; number dumping
-;;; Dump a ratio.
(defun dump-ratio (x file)
(sub-dump-object (numerator x) file)
(sub-dump-object (denominator x) file)
(dump-fop 'fop-ratio file))
-;;; Dump an integer.
(defun dump-integer (n file)
(typecase n
((signed-byte 8)
(t
(unless *cold-load-dump*
(dump-fop 'fop-normal-load file))
- (dump-simple-string (package-name pkg) 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))
(6 (dump-fop 'fop-list*-6 file))
(7 (dump-fop 'fop-list*-7 file))
(8 (dump-fop 'fop-list*-8 file))
- (T (do ((nn n (- nn 255)))
+ (t (do ((nn n (- nn 255)))
((< nn 256)
(dump-fop 'fop-list* file)
(dump-byte nn file))
(6 (dump-fop 'fop-list-6 file))
(7 (dump-fop 'fop-list-7 file))
(8 (dump-fop 'fop-list-8 file))
- (T (cond ((< n 256)
+ (t (cond ((< n 256)
(dump-fop 'fop-list file)
(dump-byte n file))
(t (dump-fop 'fop-list file)
(*)))
x)))
(typecase simple-version
+ #+sb-xc-host
+ (simple-string
+ (unless (string-check-table x file)
+ (dump-simple-base-string simple-version file)
+ (string-save-object x file)))
+ #-sb-xc-host
(simple-base-string
- (unless (equal-check-table x file)
- (dump-simple-string simple-version file)
- (equal-save-object x file)))
+ (unless (string-check-table x file)
+ (dump-simple-base-string simple-version file)
+ (string-save-object x file)))
+ #-sb-xc-host
+ ((simple-array character (*))
+ #!+sb-unicode
+ (unless (string-check-table x file)
+ (dump-simple-character-string simple-version file)
+ (string-save-object x file))
+ #!-sb-unicode
+ (bug "how did we get here?"))
(simple-vector
(dump-simple-vector simple-version file)
(eq-save-object x file))
(dump-unsigned-vector 32 (* 4 len)))
#-sb-xc-host
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
- ((simple-array (unsigned-byte-63) (*))
+ ((simple-array (unsigned-byte 63) (*))
(dump-unsigned-vector 63 (* 8 len)))
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
- ((simple-array (unsigned-byte-64) (*))
+ ((simple-array (unsigned-byte 64) (*))
(dump-unsigned-vector 64 (* 8 len)))
((simple-array (signed-byte 8) (*))
(dump-signed-vector 8 len))
\f
;;; Dump characters and string-ish things.
-(defun dump-character (ch file)
+(defun dump-character (char file)
+ (let ((code (sb!xc:char-code char)))
+ (cond
+ ((< code 256)
(dump-fop 'fop-short-character file)
- (dump-byte (char-code ch) file))
+ (dump-byte code file))
+ (t
+ (dump-fop 'fop-character file)
+ (dump-word code file)))))
-;;; a helper function shared by DUMP-SIMPLE-STRING and DUMP-SYMBOL
-(defun dump-characters-of-string (s fasl-output)
- (declare (type string s) (type fasl-output fasl-output))
+(defun dump-base-chars-of-string (s fasl-output)
+ (declare #+sb-xc-host (type simple-string s)
+ #-sb-xc-host (type simple-base-string s)
+ (type fasl-output fasl-output))
(dovector (c s)
- (dump-byte (char-code c) fasl-output))
+ (dump-byte (sb!xc:char-code c) fasl-output))
(values))
+
;;; Dump a SIMPLE-BASE-STRING.
-;;; FIXME: should be called DUMP-SIMPLE-BASE-STRING then
-(defun dump-simple-string (s file)
- (declare (type simple-base-string s))
- (dump-fop* (length s) fop-small-string fop-string file)
- (dump-characters-of-string s file)
+(defun dump-simple-base-string (s file)
+ #+sb-xc-host (declare (type simple-string s))
+ #-sb-xc-host (declare (type simple-base-string s))
+ (dump-fop* (length s) fop-small-base-string fop-base-string file)
+ (dump-base-chars-of-string s file)
(values))
;;; If we get here, it is assumed that the symbol isn't in the table,
file)
(dump-word pname-length file)))
- (dump-characters-of-string pname file)
+ #+sb-xc-host (dump-base-chars-of-string pname file)
+ #-sb-xc-host (#!+sb-unicode dump-characters-of-string
+ #!-sb-unicode dump-base-chars-of-string
+ pname file)
(unless *cold-load-dump*
(setf (gethash s (fasl-output-eq-table file))
(error "attempt to dump invalid structure:~% ~S~%How did this happen?"
struct)))
(note-potential-circularity struct file)
- (do ((index 0 (1+ index))
- (length (%instance-length struct))
- (circ (fasl-output-circularity-table file)))
- ((= index length)
+ (aver (%instance-ref struct 0))
+ (do* ((length (%instance-length struct))
+ (ntagged (- length (layout-n-untagged-slots (%instance-ref struct 0))))
+ (circ (fasl-output-circularity-table file))
+ ;; last slot first on the stack, so that the layout is on top:
+ (index (1- length) (1- index)))
+ ((minusp index)
(dump-fop* length fop-small-struct fop-struct file))
- (let* ((obj (%instance-ref struct index))
+ (let* ((obj (if (>= index ntagged)
+ (%raw-instance-ref/word struct (- length index 1))
+ (%instance-ref struct index)))
(ref (gethash obj circ)))
(cond (ref
+ (aver (not (zerop index)))
(push (make-circularity :type :struct-set
:object struct
:index index
(sub-dump-object (layout-inherits obj) file)
(sub-dump-object (layout-depthoid obj) file)
(sub-dump-object (layout-length obj) file)
+ (sub-dump-object (layout-n-untagged-slots obj) file)
(dump-fop 'fop-layout file))
projects / sbcl.git / blobdiff