X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=f98462107ddd01d20e806a8d96ad77d63edeef93;hb=a189a69454ef7635149319ae213b337f17c50d20;hp=838f284d004b50659b4a9bf8ac5bc5d537a80b91;hpb=c1ec38c7fe7279b68dcce74ec4bf408defefe522;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 838f284..f984621 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -289,16 +289,20 @@
 ;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the
 ;;; intersection is different from the old type, then we do a
 ;;; REOPTIMIZE-LVAR on the NODE-LVAR.
-(defun derive-node-type (node rtype)
+(defun derive-node-type (node rtype &key from-scratch)
   (declare (type valued-node node) (type ctype rtype))
-  (let ((node-type (node-derived-type node)))
-    (unless (eq node-type rtype)
+  (let* ((initial-type (node-derived-type node))
+         (node-type (if from-scratch
+                        *wild-type*
+                        initial-type)))
+    (unless (eq initial-type rtype)
       (let ((int (values-type-intersection node-type rtype))
             (lvar (node-lvar node)))
-        (when (type/= node-type int)
+        (when (type/= initial-type int)
           (when (and *check-consistency*
                      (eq int *empty-type*)
                      (not (eq rtype *empty-type*)))
+            (aver (not from-scratch))
             (let ((*compiler-error-context* node))
               (compiler-warn
                "New inferred type ~S conflicts with old type:~
@@ -518,17 +522,19 @@
 ;;; Delete any nodes in BLOCK whose value is unused and which have no
 ;;; side effects. We can delete sets of lexical variables when the set
 ;;; variable has no references.
-(defun flush-dead-code (block)
+(defun flush-dead-code (block &aux victim)
   (declare (type cblock block))
   (setf (block-flush-p block) nil)
   (do-nodes-backwards (node lvar block :restart-p t)
     (unless lvar
       (typecase node
         (ref
+         (setf victim node)
          (delete-ref node)
          (unlink-node node))
         (combination
          (when (flushable-combination-p node)
+           (setf victim node)
            (flush-combination node)))
         (mv-combination
          (when (eq (basic-combination-kind node) :local)
@@ -537,27 +543,31 @@
                      (when (or (leaf-refs var)
                                (lambda-var-sets var))
                        (return nil)))
+               (setf victim node)
                (flush-dest (first (basic-combination-args node)))
                (delete-let fun)))))
         (exit
          (let ((value (exit-value node)))
            (when value
+             (setf victim node)
              (flush-dest value)
              (setf (exit-value node) nil))))
         (cset
          (let ((var (set-var node)))
            (when (and (lambda-var-p var)
                       (null (leaf-refs var)))
+             (setf victim node)
              (flush-dest (set-value node))
              (setf (basic-var-sets var)
                    (delq node (basic-var-sets var)))
              (unlink-node node))))
         (cast
          (unless (cast-type-check node)
+           (setf victim node)
            (flush-dest (cast-value node))
            (unlink-node node))))))
 
-  (values))
+  victim)
 
 ;;;; local call return type propagation