;; 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.
;;; 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
;; 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.
\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))
projects / sbcl.git / blobdiff