X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=6bfc35c6b9bbc9da3fd0bb93aa6ceaaf4096c351;hb=94ea2b2082deaa0331dfb66fa6af6ca12dd8dc83;hp=2609d2835c98c4d07e95ac1ad0628cfa8b2c04d5;hpb=d406d3a2345fe475fa7cb27b516d023cc2f7225e;p=sbcl.git diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 2609d28..6bfc35c 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -33,7 +33,7 @@ ;; 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) @@ -192,11 +192,19 @@ (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 @@ -217,7 +225,16 @@ (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. @@ -260,9 +277,7 @@ ;;; 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 @@ -280,17 +295,19 @@ ;; 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) @@ -368,11 +385,8 @@ (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) @@ -391,7 +405,7 @@ ;;; 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. @@ -496,13 +510,11 @@ ;;;; 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) @@ -584,7 +596,15 @@ (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)) @@ -662,7 +682,7 @@ (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)) @@ -684,7 +704,7 @@ (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) @@ -715,10 +735,24 @@ (*))) 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)) @@ -858,10 +892,10 @@ (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)) @@ -887,23 +921,31 @@ ;;; 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, @@ -953,7 +995,10 @@ 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)) @@ -1270,14 +1315,20 @@ (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 @@ -1302,4 +1353,5 @@ (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))