X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=548c1c9f8b84e810c39a58251dd10c08851715bb;hb=ed891a4fd882d1b9fe066ab14bcf2107aea95baa;hp=3a495b496d727f43b57f84e461dfcfb7a6763220;hpb=acc37aadda6d607b7b84031ebc7bc58b07039120;p=sbcl.git

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 3a495b4..548c1c9 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -306,6 +306,9 @@
            (when value
              (derive-node-type node (lvar-derived-type value)))))
         (cset
+         ;; PROPAGATE-FROM-SETS can do a better job if NODE-REOPTIMIZE
+         ;; is accurate till the node actually has been reoptimized.
+         (setf (node-reoptimize node) t)
          (ir1-optimize-set node))
         (cast
          (ir1-optimize-cast node)))))
@@ -697,7 +700,7 @@
          (when (and fun
                     ;; If somebody is really sure that they want to modify
                     ;; constants, let them.
-                    (policy node (> safety 0)))
+                    (policy node (> check-constant-modification 0)))
            (let ((destroyed-constant-args (funcall fun args)))
              (when destroyed-constant-args
                (let ((*compiler-error-context* node))
@@ -1240,12 +1243,13 @@
       (let ((int (type-approx-intersection2 var-type type)))
         (when (type/= int var-type)
           (setf (leaf-type leaf) int)
-          (dolist (ref (leaf-refs leaf))
-            (derive-node-type ref (make-single-value-type int))
-            ;; KLUDGE: LET var substitution
-            (let* ((lvar (node-lvar ref)))
-              (when (and lvar (combination-p (lvar-dest lvar)))
-                (reoptimize-lvar lvar))))))
+          (let ((s-int (make-single-value-type int)))
+            (dolist (ref (leaf-refs leaf))
+              (derive-node-type ref s-int)
+              ;; KLUDGE: LET var substitution
+              (let* ((lvar (node-lvar ref)))
+                (when (and lvar (combination-p (lvar-dest lvar)))
+                  (reoptimize-lvar lvar)))))))
       (values))))
 
 ;;; Iteration variable: exactly one SETQ of the form:
@@ -1341,17 +1345,22 @@
 ;;; the union of the INITIAL-TYPE and the types of all the set
 ;;; values and to a PROPAGATE-TO-REFS with this type.
 (defun propagate-from-sets (var initial-type)
-  (collect ((res initial-type type-union))
-    (dolist (set (basic-var-sets var))
+  (let ((changes (not (csubtypep (lambda-var-last-initial-type var) initial-type)))
+        (types nil))
+    (dolist (set (lambda-var-sets var))
       (let ((type (lvar-type (set-value set))))
-        (res type)
+        (push type types)
         (when (node-reoptimize set)
-          (derive-node-type set (make-single-value-type type))
+          (let ((old-type (node-derived-type set)))
+            (unless (values-subtypep old-type type)
+              (derive-node-type set (make-single-value-type type))
+              (setf changes t)))
           (setf (node-reoptimize set) nil))))
-    (let ((res (res)))
-      (awhen (maybe-infer-iteration-var-type var initial-type)
-        (setq res it))
-      (propagate-to-refs var res)))
+    (when changes
+      (setf (lambda-var-last-initial-type var) initial-type)
+      (let ((res-type (or (maybe-infer-iteration-var-type var initial-type)
+                          (apply #'type-union initial-type types))))
+        (propagate-to-refs var res-type))))
   (values))
 
 ;;; If a LET variable, find the initial value's type and do
@@ -1367,9 +1376,9 @@
                  (initial-type (lvar-type initial-value)))
             (setf (lvar-reoptimize initial-value) nil)
             (propagate-from-sets var initial-type))))))
-
   (derive-node-type node (make-single-value-type
                           (lvar-type (set-value node))))
+  (setf (node-reoptimize node) nil)
   (values))
 
 ;;; Return true if the value of REF will always be the same (and is