X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=02774c91d72f10819cfb6cb58ebe98aa10396acd;hb=05e28b18c3fc2d697f04fb0393f51ce00147825e;hp=0db369e894c430e9c8b6fb10dd0b2da599ead427;hpb=d55ad026a3d69bcbd595a7a09763327977e46e0b;p=sbcl.git diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 0db369e..02774c9 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -91,10 +91,6 @@ ;;; dumping uses the table. (defvar *circularities-detected*) -;;; used to inhibit table access when dumping forms to be read by the -;;; cold loader -(defvar *cold-load-dump* nil) - ;;; used to turn off the structure validation during dumping of source ;;; info (defvar *dump-only-valid-structures* t) @@ -194,71 +190,62 @@ (incf (fasl-output-table-free fasl-output)))) ;;; If X is in File's EQUAL-TABLE, then push the object and return T, -;;; otherwise NIL. If *COLD-LOAD-DUMP* is true, then do nothing and -;;; return NIL. +;;; otherwise NIL. (defun equal-check-table (x fasl-output) (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))))) + (let ((handle (gethash x (fasl-output-equal-table fasl-output)))) + (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 - #+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) - (t nil))))) + (let ((handle (cdr (assoc + #+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) + (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 -;;; be on the top of the FOP stack. If *COLD-LOAD-DUMP* is true, then -;;; we don't do anything. +;;; be on the top of the FOP stack. (defun eq-save-object (x fasl-output) (declare (type fasl-output fasl-output)) - (unless *cold-load-dump* - (let ((handle (dump-pop fasl-output))) - (setf (gethash x (fasl-output-eq-table fasl-output)) handle) - (dump-push handle fasl-output))) + (let ((handle (dump-pop fasl-output))) + (setf (gethash x (fasl-output-eq-table fasl-output)) handle) + (dump-push handle fasl-output)) (values)) (defun equal-save-object (x fasl-output) (declare (type fasl-output fasl-output)) - (unless *cold-load-dump* - (let ((handle (dump-pop fasl-output))) - (setf (gethash x (fasl-output-equal-table fasl-output)) handle) - (setf (gethash x (fasl-output-eq-table fasl-output)) handle) - (dump-push handle fasl-output))) + (let ((handle (dump-pop fasl-output))) + (setf (gethash x (fasl-output-equal-table fasl-output)) handle) + (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 #+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))) + (let ((handle (dump-pop fasl-output))) + (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)) (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. +;;; Record X in File's CIRCULARITY-TABLE. This is called on objects +;;; that we are about to dump might have a circular path through them. ;;; ;;; The object must not currently be in this table, since the dumper ;;; should never be recursively called on a circular reference. ;;; Instead, the dumping function must detect the circularity and ;;; arrange for the dumped object to be patched. (defun note-potential-circularity (x fasl-output) - (unless *cold-load-dump* - (let ((circ (fasl-output-circularity-table fasl-output))) - (aver (not (gethash x circ))) - (setf (gethash x circ) x))) + (let ((circ (fasl-output-circularity-table fasl-output))) + (aver (not (gethash x circ))) + (setf (gethash x circ) x)) (values)) ;;;; opening and closing fasl files @@ -359,7 +346,7 @@ ;;; When we go to dump the object, we enter it in the CIRCULARITY-TABLE. (defun dump-non-immediate-object (x file) (let ((index (gethash x (fasl-output-eq-table file)))) - (cond ((and index (not *cold-load-dump*)) + (cond (index (dump-push index file)) (t (typecase x @@ -402,6 +389,14 @@ (float (dump-float x file)) (integer (dump-integer x file))) (equal-save-object x file))) + #!+sb-simd-pack + (simd-pack + (unless (equal-check-table x file) + (dump-fop 'fop-simd-pack file) + (dump-integer-as-n-bytes (%simd-pack-tag x) 8 file) + (dump-integer-as-n-bytes (%simd-pack-low x) 8 file) + (dump-integer-as-n-bytes (%simd-pack-high x) 8 file)) + (equal-save-object x file)) (t ;; This probably never happens, since bad things tend to ;; be detected during IR1 conversion. @@ -649,9 +644,6 @@ ;;; ;;; Otherwise, we recursively call the dumper to dump the current ;;; element. -;;; -;;; Marking of the conses is inhibited when *COLD-LOAD-DUMP* is true. -;;; This inhibits all circularity detection. (defun dump-list (list file) (aver (and list (not (gethash list (fasl-output-circularity-table file))))) @@ -676,8 +668,7 @@ (terminate-undotted-list n file) (return))) - (unless *cold-load-dump* - (setf (gethash l circ) list)) + (setf (gethash l circ) list) (let* ((obj (car l)) (ref (gethash obj circ))) @@ -970,10 +961,7 @@ (values)) ;;; If we get here, it is assumed that the symbol isn't in the table, -;;; but we are responsible for putting it there when appropriate. To -;;; avoid too much special-casing, we always push the symbol in the -;;; table, but don't record that we have done so if *COLD-LOAD-DUMP* -;;; is true. +;;; but we are responsible for putting it there when appropriate. (defun dump-symbol (s file) (declare (type fasl-output file)) (let* ((pname (symbol-name s)) @@ -1030,9 +1018,8 @@ #!-sb-unicode dump-base-chars-of-string pname file) - (unless *cold-load-dump* - (setf (gethash s (fasl-output-eq-table file)) - (fasl-output-table-free file))) + (setf (gethash s (fasl-output-eq-table file)) + (fasl-output-table-free file)) (incf (fasl-output-table-free file))) @@ -1064,19 +1051,13 @@ (position (fixup-note-position note)) (name (fixup-name fixup)) (flavor (fixup-flavor fixup))) - (dump-fop 'fop-normal-load fasl-output) - (let ((*cold-load-dump* t)) - (dump-object kind fasl-output)) - (dump-fop 'fop-maybe-cold-load fasl-output) + (dump-object kind fasl-output) ;; Depending on the flavor, we may have various kinds of ;; noise before the position. (ecase flavor (:assembly-routine (aver (symbolp name)) - (dump-fop 'fop-normal-load fasl-output) - (let ((*cold-load-dump* t)) - (dump-object name fasl-output)) - (dump-fop 'fop-maybe-cold-load fasl-output) + (dump-object name fasl-output) (dump-fop 'fop-assembler-fixup fasl-output)) ((:foreign :foreign-dataref) (aver (stringp name)) @@ -1166,7 +1147,10 @@ (dump-push (cdr entry) fasl-output)) (:fdefinition (dump-object (cdr entry) fasl-output) - (dump-fop 'fop-fdefinition fasl-output)))) + (dump-fop 'fop-fdefinition fasl-output)) + (:known-fun + (dump-object (cdr entry) fasl-output) + (dump-fop 'fop-known-fun fasl-output)))) (null (dump-fop 'fop-misc-trap fasl-output))))) @@ -1212,10 +1196,7 @@ (dump-word length file) (write-segment-contents code-segment (fasl-output-stream file)) (dolist (routine routines) - (dump-fop 'fop-normal-load file) - (let ((*cold-load-dump* t)) - (dump-object (car routine) file)) - (dump-fop 'fop-maybe-cold-load file) + (dump-object (car routine) file) (dump-fop 'fop-assembler-routine file) (dump-word (label-position (cdr routine)) file)) (dump-fixups fixups file) @@ -1380,10 +1361,7 @@ (let ((name (classoid-name (layout-classoid obj)))) (unless name (compiler-error "dumping anonymous layout: ~S" obj)) - (dump-fop 'fop-normal-load file) - (let ((*cold-load-dump* t)) - (dump-object name file)) - (dump-fop 'fop-maybe-cold-load file)) + (dump-object name file)) (sub-dump-object (layout-inherits obj) file) (sub-dump-object (layout-depthoid obj) file) (sub-dump-object (layout-length obj) file)