;; can get them from the table rather than dumping them again. The
;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is
;; used for everything else. We use a separate EQ table to avoid
- ;; performance patholigies with objects for which EQUAL degnerates
+ ;; performance pathologies with objects for which EQUAL degenerates
;; to EQL. Everything entered in the EQUAL table is also entered in
;; the EQ table.
(equal-table (make-hash-table :test 'equal) :type hash-table)
(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)))))
+ (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)))))
;;; These functions are called after dumping an object to save the
;;; object in the table. The object (also passed in as X) must already
(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)))
+ (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.
;; character code.
(fasl-write-string
(with-standard-io-syntax
- (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)))
+ (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)
(dump-structure x file)
(eq-save-object x file))
(array
- ;; FIXME: The comment at the head of
- ;; DUMP-NON-IMMEDIATE-OBJECT says it's for objects which
- ;; we want to save, instead of repeatedly dumping them.
- ;; But then we dump arrays here without doing anything
- ;; like EQUAL-SAVE-OBJECT. What gives?
+ ;; DUMP-ARRAY (and its callees) are responsible for
+ ;; updating the EQ and EQUAL hash tables.
(dump-array x file))
(number
(unless (equal-check-table x file)
;;; Dump an object of any type by dispatching to the correct
;;; type-specific dumping function. We pick off immediate objects,
-;;; symbols and and magic lists here. Other objects are handled by
+;;; symbols and magic lists here. Other objects are handled by
;;; DUMP-NON-IMMEDIATE-OBJECT.
;;;
;;; This is the function used for recursive calls to the fasl dumper.
(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))
(*)))
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))
((simple-array nil (*))
(dump-unsigned-vector 0 0))
(simple-bit-vector
- (dump-unsigned-vector 1 (ceiling len 8)))
+ (dump-unsigned-vector 1 (ceiling len 8))) ; bits to bytes
;; KLUDGE: This isn't the best way of expressing that the host
;; may not have specializations for (unsigned-byte 2) and
;; (unsigned-byte 4), which means that these types are
;; CSR, 2002-05-07
#-sb-xc-host
((simple-array (unsigned-byte 2) (*))
- (dump-unsigned-vector 2 (ceiling len 8)))
+ (dump-unsigned-vector 2 (ceiling (ash len 1) 8))) ; bits to bytes
#-sb-xc-host
((simple-array (unsigned-byte 4) (*))
- (dump-unsigned-vector 4 (ceiling len 8)))
+ (dump-unsigned-vector 4 (ceiling (ash len 2) 8))) ; bits to bytes
#-sb-xc-host
((simple-array (unsigned-byte 7) (*))
(dump-unsigned-vector 7 len))
(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))
(dump-object name fasl-output))
(dump-fop 'fop-maybe-cold-load fasl-output)
(dump-fop 'fop-assembler-fixup fasl-output))
- (:foreign
+ ((:foreign :foreign-dataref)
(aver (stringp name))
- (dump-fop 'fop-foreign-fixup fasl-output)
+ (ecase flavor
+ (:foreign
+ (dump-fop 'fop-foreign-fixup fasl-output))
+ #!+linkage-table
+ (:foreign-dataref
+ (dump-fop 'fop-foreign-dataref-fixup fasl-output)))
(let ((len (length name)))
(aver (< len 256)) ; (limit imposed by fop definition)
(dump-byte len fasl-output)
(cond ((and (< num-consts #x100) (< total-length #x10000))
(dump-fop 'fop-small-code fasl-output)
(dump-byte num-consts fasl-output)
- (dump-integer-as-n-bytes total-length 2 fasl-output))
+ (dump-integer-as-n-bytes total-length (/ sb!vm:n-word-bytes 2) fasl-output))
(t
(dump-fop 'fop-code fasl-output)
(dump-word num-consts fasl-output)