X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=9f1e1f030690bf91300ddfba95388275b56679ac;hb=3c9981c71f4d0d2c5b5830486c4b9a35ab50a240;hp=47a96c1a87ad3a4b446a06549708e8117f628a4f;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 47a96c1..9f1e1f0 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -11,72 +11,105 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
+;;; TODO:
+;;;
+;;; -- documentation
+;;;
+;;; -- MV-BIND, :ASSIGNMENT
+
+;;; Problems:
+;;;
+;;; -- Constraint propagation badly interacts with bottom-up type
+;;; inference. Consider
+;;;
+;;; (defun foo (n &aux (i 42))
+;;;   (declare (optimize speed))
+;;;   (declare (fixnum n)
+;;;            #+nil (type (integer 0) i))
+;;;   (tagbody
+;;;      (setq i 0)
+;;;    :loop
+;;;      (when (>= i n) (go :exit))
+;;;      (setq i (1+ i))
+;;;      (go :loop)
+;;;    :exit))
+;;;
+;;; In this case CP cannot even infer that I is of class INTEGER.
+;;;
+;;; -- In the above example if we place the check after SETQ, CP will
+;;; fail to infer (< I FIXNUM): it does not understand that this
+;;; constraint follows from (TYPEP I (INTEGER 0 0)).
+
 (in-package "SB!C")
 
-(file-comment
-  "$Header$")
+(deftype constraint-y () '(or ctype lvar lambda-var constant))
 
 (defstruct (constraint
-	    (:include sset-element)
-	    (:constructor make-constraint (number kind x y not-p)))
-  ;; The kind of constraint we have:
+            (:include sset-element)
+            (:constructor make-constraint (number kind x y not-p))
+            (:copier nil))
+  ;; the kind of constraint we have:
   ;;
   ;; TYPEP
-  ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is 
+  ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
   ;;     constrained to be of type Y.
   ;;
-  ;; >, <
-  ;;     X is a lambda-var and Y is a CTYPE. The relation holds 
+  ;; > or <
+  ;;     X is a lambda-var and Y is a CTYPE. The relation holds
   ;;     between X and some object of type Y.
   ;;
   ;; EQL
-  ;;     X is a LAMBDA-VAR Y is a LAMBDA-VAR or a CONSTANT. The
-  ;;     relation is asserted to hold.
+  ;;     X is a LAMBDA-VAR and Y is a LVAR, a LAMBDA-VAR or a CONSTANT.
+  ;;     The relation is asserted to hold.
   (kind nil :type (member typep < > eql))
   ;; The operands to the relation.
   (x nil :type lambda-var)
-  (y nil :type (or ctype lambda-var constant))
-  ;; If true, negates the sense of the constraint, so the relation 
+  (y nil :type constraint-y)
+  ;; If true, negates the sense of the constraint, so the relation
   ;; does *not* hold.
   (not-p nil :type boolean))
 
 (defvar *constraint-number*)
+(declaim (type (integer 0) *constraint-number*))
+
+(defun find-constraint (kind x y not-p)
+  (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
+  (etypecase y
+    (ctype
+     (do-sset-elements (con (lambda-var-constraints x) nil)
+       (when (and (eq (constraint-kind con) kind)
+                  (eq (constraint-not-p con) not-p)
+                  (type= (constraint-y con) y))
+         (return con))))
+    ((or lvar constant)
+     (do-sset-elements (con (lambda-var-constraints x) nil)
+       (when (and (eq (constraint-kind con) kind)
+                  (eq (constraint-not-p con) not-p)
+                  (eq (constraint-y con) y))
+         (return con))))
+    (lambda-var
+     (do-sset-elements (con (lambda-var-constraints x) nil)
+       (when (and (eq (constraint-kind con) kind)
+                  (eq (constraint-not-p con) not-p)
+                  (let ((cx (constraint-x con)))
+                    (eq (if (eq cx x)
+                            (constraint-y con)
+                            cx)
+                        y)))
+         (return con))))))
 
 ;;; Return a constraint for the specified arguments. We only create a
 ;;; new constraint if there isn't already an equivalent old one,
 ;;; guaranteeing that all equivalent constraints are EQ. This
 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
-(defun find-constraint (kind x y not-p)
-  (declare (type lambda-var x) (type (or constant lambda-var ctype) y)
-	   (type boolean not-p))
-  (or (etypecase y
-	(ctype
-	 (do-sset-elements (con (lambda-var-constraints x) nil)
-	   (when (and (eq (constraint-kind con) kind)
-		      (eq (constraint-not-p con) not-p)
-		      (type= (constraint-y con) y))
-	     (return con))))
-	(constant
-	 (do-sset-elements (con (lambda-var-constraints x) nil)
-	   (when (and (eq (constraint-kind con) kind)
-		      (eq (constraint-not-p con) not-p)
-		      (eq (constraint-y con) y))
-	     (return con))))
-	(lambda-var
-	 (do-sset-elements (con (lambda-var-constraints x) nil)
-	   (when (and (eq (constraint-kind con) kind)
-		      (eq (constraint-not-p con) not-p)
-		      (let ((cx (constraint-x con)))
-			(eq (if (eq cx x)
-				(constraint-y con)
-				cx)
-			    y)))
-	     (return con)))))
+(defun find-or-create-constraint (kind x y not-p)
+  (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
+  (or (find-constraint kind x y not-p)
       (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
-	(sset-adjoin new (lambda-var-constraints x))
-	(when (lambda-var-p y)
-	  (sset-adjoin new (lambda-var-constraints y)))
-	new)))
+        (sset-adjoin new (lambda-var-constraints x))
+        (when (lambda-var-p y)
+          (sset-adjoin new (lambda-var-constraints y)))
+        new)))
 
 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
@@ -85,144 +118,149 @@
   (declare (type ref ref))
   (let ((leaf (ref-leaf ref)))
     (when (and (lambda-var-p leaf)
-	       (lambda-var-constraints leaf))
+               (lambda-var-constraints leaf))
       leaf)))
 
-;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
-;;; otherwise NIL.
-#!-sb-fluid (declaim (inline ok-cont-lambda-var))
-(defun ok-cont-lambda-var (cont)
-  (declare (type continuation cont))
-  (let ((use (continuation-use cont)))
-    (when (ref-p use)
-      (ok-ref-lambda-var use))))
-
-;;; Add the indicated test constraint to BLOCK, marking the block as
-;;; having a new assertion when the constriant was not already
-;;; present. We don't add the constraint if the block has multiple
-;;; predecessors, since it only holds on this particular path.
-(defun add-test-constraint (block fun x y not-p)
-  (unless (rest (block-pred block))
-    (let ((con (find-constraint fun x y not-p))
-	  (old (or (block-test-constraint block)
-		   (setf (block-test-constraint block) (make-sset)))))
-      (when (sset-adjoin con old)
-	(setf (block-type-asserted block) t))))
+;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
+;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
+(defun ok-lvar-lambda-var (lvar constraints)
+  (declare (type lvar lvar))
+  (let ((use (lvar-uses lvar)))
+    (cond ((ref-p use)
+           (let ((lambda-var (ok-ref-lambda-var use)))
+             (when lambda-var
+               (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
+                 (when (and constraint (sset-member constraint constraints))
+                   lambda-var)))))
+          ((cast-p use)
+           (ok-lvar-lambda-var (cast-value use) constraints)))))
+
+(defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
+  (once-only ((var var))
+    `(let ((,symbol ,var))
+       (flet ((body-fun ()
+                ,@body))
+         (body-fun)
+         (do-sset-elements (con ,constraints ,result)
+           (let ((other (and (eq (constraint-kind con) 'eql)
+                             (eq (constraint-not-p con) nil)
+                             (cond ((eq ,var (constraint-x con))
+                                    (constraint-y con))
+                                   ((eq ,var (constraint-y con))
+                                    (constraint-x con))
+                                   (t
+                                    nil)))))
+             (when other
+               (setq ,symbol other)
+               (when (lambda-var-p ,symbol)
+                 (body-fun)))))))))
+
+;;;; Searching constraints
+
+;;; Add the indicated test constraint to BLOCK. We don't add the
+;;; constraint if the block has multiple predecessors, since it only
+;;; holds on this particular path.
+(defun add-test-constraint (fun x y not-p constraints target)
+  (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
+         (add-eql-var-var-constraint x y constraints target))
+        (t
+         (do-eql-vars (x (x constraints))
+           (let ((con (find-or-create-constraint fun x y not-p)))
+             (sset-adjoin con target)))))
   (values))
 
 ;;; Add complementary constraints to the consequent and alternative
 ;;; blocks of IF. We do nothing if X is NIL.
-#!-sb-fluid (declaim (inline add-complement-constraints))
-(defun add-complement-constraints (if fun x y not-p)
+(defun add-complement-constraints (fun x y not-p constraints
+                                   consequent-constraints
+                                   alternative-constraints)
   (when x
-    (add-test-constraint (if-consequent if) fun x y not-p)
-    (add-test-constraint (if-alternative if) fun x y (not not-p)))
+    (add-test-constraint fun x y not-p constraints
+                         consequent-constraints)
+    (add-test-constraint fun x y (not not-p) constraints
+                         alternative-constraints))
   (values))
 
 ;;; Add test constraints to the consequent and alternative blocks of
 ;;; the test represented by USE.
-(defun add-test-constraints (use if)
+(defun add-test-constraints (use if constraints)
   (declare (type node use) (type cif if))
-  (typecase use
-    (ref
-     (add-complement-constraints if 'typep (ok-ref-lambda-var use)
-				 (specifier-type 'null) t))
-    (combination
-     (let ((name (continuation-function-name
-		  (basic-combination-fun use)))
-	   (args (basic-combination-args use)))
-       (case name
-	 ((%typep %instance-typep)
-	  (let ((type (second args)))
-	    (when (constant-continuation-p type)
-	      (let ((val (continuation-value type)))
-	      (add-complement-constraints if 'typep
-					  (ok-cont-lambda-var (first args))
-					  (if (ctype-p val)
-					      val
-					      (specifier-type val))
-					  nil)))))
-	 ((eq eql)
-	  (let* ((var1 (ok-cont-lambda-var (first args)))
-		 (arg2 (second args))
-		 (var2 (ok-cont-lambda-var arg2)))
-	    (cond ((not var1))
-		  (var2
-		   (add-complement-constraints if 'eql var1 var2 nil))
-		  ((constant-continuation-p arg2)
-		   (add-complement-constraints if 'eql var1
-					       (ref-leaf
-						(continuation-use arg2))
-					       nil)))))
-	 ((< >)
-	  (let* ((arg1 (first args))
-		 (var1 (ok-cont-lambda-var arg1))
-		 (arg2 (second args))
-		 (var2 (ok-cont-lambda-var arg2)))
-	    (when var1
-	      (add-complement-constraints if name var1 (continuation-type arg2)
-					  nil))
-	    (when var2
-	      (add-complement-constraints if (if (eq name '<) '> '<)
-					  var2 (continuation-type arg1)
-					  nil))))
-	 (t
-	  (let ((ptype (gethash name *backend-predicate-types*)))
-	    (when ptype
-	      (add-complement-constraints if 'typep
-					  (ok-cont-lambda-var (first args))
-					  ptype nil))))))))
-  (values))
-
-;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to
-;;; the condition it tests.
-(defun find-test-constraints (block)
-  (declare (type cblock block))
-  (let ((last (block-last block)))
-    (when (if-p last)
-      (let ((use (continuation-use (if-test last))))
-	(when use
-	  (add-test-constraints use last)))))
-
-  (setf (block-test-modified block) nil)
-  (values))
-
-;;; Compute the initial flow analysis sets for BLOCK:
-;;; -- For any lambda-var ref with a type check, add that constraint.
-;;; -- For any lambda-var set, delete all constraints on that var, and add
-;;;    those constraints to the set nuked by this block.
-(defun find-block-type-constraints (block)
-  (declare (type cblock block))
-  (let ((gen (make-sset)))
-    (collect ((kill nil adjoin))
-
-      (let ((test (block-test-constraint block)))
-	(when test
-	  (sset-union gen test)))
-
-      (do-nodes (node cont block)
-	(typecase node
-	  (ref
-	   (when (continuation-type-check cont)
-	     (let ((var (ok-ref-lambda-var node)))
-	       (when var
-		 (let* ((atype (continuation-derived-type cont))
-			(con (find-constraint 'typep var atype nil)))
-		   (sset-adjoin con gen))))))
-	  (cset
-	   (let ((var (set-var node)))
-	     (when (lambda-var-p var)
-	       (kill var)
-	       (let ((cons (lambda-var-constraints var)))
-		 (when cons
-		   (sset-difference gen cons))))))))
-
-      (setf (block-in block) nil)
-      (setf (block-gen block) gen)
-      (setf (block-kill block) (kill))
-      (setf (block-out block) (copy-sset gen))
-      (setf (block-type-asserted block) nil)
-      (values))))
+  ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
+  ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
+  ;; can't guarantee that the optimization will be done, so we still
+  ;; need to avoid barfing on this case.
+  (unless (eq (if-consequent if) (if-alternative if))
+    (let ((consequent-constraints (make-sset))
+          (alternative-constraints (make-sset)))
+      (macrolet ((add (fun x y not-p)
+                   `(add-complement-constraints ,fun ,x ,y ,not-p
+                     constraints
+                     consequent-constraints
+                     alternative-constraints)))
+        (typecase use
+          (ref
+           (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
+                (specifier-type 'null) t))
+          (combination
+           (unless (eq (combination-kind use)
+                       :error)
+             (let ((name (lvar-fun-name
+                          (basic-combination-fun use)))
+                   (args (basic-combination-args use)))
+               (case name
+                 ((%typep %instance-typep)
+                  (let ((type (second args)))
+                    (when (constant-lvar-p type)
+                      (let ((val (lvar-value type)))
+                        (add 'typep
+                             (ok-lvar-lambda-var (first args) constraints)
+                             (if (ctype-p val)
+                                 val
+                                 (specifier-type val))
+                             nil)))))
+                 ((eq eql)
+                  (let* ((arg1 (first args))
+                         (var1 (ok-lvar-lambda-var arg1 constraints))
+                         (arg2 (second args))
+                         (var2 (ok-lvar-lambda-var arg2 constraints)))
+                    ;; The code below assumes that the constant is the
+                    ;; second argument in case of variable to constant
+                    ;; comparision which is sometimes true (see source
+                    ;; transformations for EQ, EQL and CHAR=). Fixing
+                    ;; that would result in more constant substitutions
+                    ;; which is not a universally good thing, thus the
+                    ;; unnatural asymmetry of the tests.
+                    (cond ((not var1)
+                           (when var2
+                             (add-test-constraint 'typep var2 (lvar-type arg1)
+                                                  nil constraints
+                                                  consequent-constraints)))
+                          (var2
+                           (add 'eql var1 var2 nil))
+                          ((constant-lvar-p arg2)
+                           (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
+                                nil))
+                          (t
+                           (add-test-constraint 'typep var1 (lvar-type arg2)
+                                                nil constraints
+                                                consequent-constraints)))))
+                 ((< >)
+                  (let* ((arg1 (first args))
+                         (var1 (ok-lvar-lambda-var arg1 constraints))
+                         (arg2 (second args))
+                         (var2 (ok-lvar-lambda-var arg2 constraints)))
+                    (when var1
+                      (add name var1 (lvar-type arg2) nil))
+                    (when var2
+                      (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
+                 (t
+                  (let ((ptype (gethash name *backend-predicate-types*)))
+                    (when ptype
+                      (add 'typep (ok-lvar-lambda-var (first args) constraints)
+                           ptype nil))))))))))
+      (values consequent-constraints alternative-constraints))))
+
+;;;; Applying constraints
 
 ;;; Return true if X is an integer NUMERIC-TYPE.
 (defun integer-type-p (x)
@@ -242,28 +280,21 @@
 (defun constrain-integer-type (x y greater or-equal)
   (declare (type numeric-type x y))
   (flet ((exclude (x)
-	   (cond ((not x) nil)
-		 (or-equal x)
-		 (greater (1+ x))
-		 (t (1- x))))
-	 (bound (x)
-	   (if greater (numeric-type-low x) (numeric-type-high x)))
-	 (validate (x)
-	   (if (and (numeric-type-low x) (numeric-type-high x)
-		    (> (numeric-type-low x) (numeric-type-high x)))
-	       *empty-type*
-	       x)))
+           (cond ((not x) nil)
+                 (or-equal x)
+                 (greater (1+ x))
+                 (t (1- x))))
+         (bound (x)
+           (if greater (numeric-type-low x) (numeric-type-high x))))
     (let* ((x-bound (bound x))
-	   (y-bound (exclude (bound y)))
-	   (new-bound (cond ((not x-bound) y-bound)
-			    ((not y-bound) x-bound)
-			    (greater (max x-bound y-bound))
-			    (t (min x-bound y-bound))))
-	   (res (copy-numeric-type x)))
+           (y-bound (exclude (bound y)))
+           (new-bound (cond ((not x-bound) y-bound)
+                            ((not y-bound) x-bound)
+                            (greater (max x-bound y-bound))
+                            (t (min x-bound y-bound)))))
       (if greater
-	  (setf (numeric-type-low res) new-bound)
-	  (setf (numeric-type-high res) new-bound))
-      (validate res))))
+          (modified-numeric-type x :low new-bound)
+          (modified-numeric-type x :high new-bound)))))
 
 ;;; Return true if X is a float NUMERIC-TYPE.
 (defun float-type-p (x)
@@ -275,63 +306,46 @@
 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
 (defun constrain-float-type (x y greater or-equal)
   (declare (type numeric-type x y))
-  ;; Unless :PROPAGATE-FLOAT-TYPE is in target features, then
-  ;; SB!C::BOUND-VALUE (used in the code below) is not defined, so we
-  ;; just return X without trying to calculate additional constraints.
-  #!-propagate-float-type (declare (ignore y greater or-equal))
-  #!-propagate-float-type x
-  #!+propagate-float-type
+  (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
+
+  (aver (eql (numeric-type-class x) 'float))
+  (aver (eql (numeric-type-class y) 'float))
+  #+sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+  x
+  #-sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
   (labels ((exclude (x)
-	     (cond ((not x) nil)
-		   (or-equal x)
-		   (greater
-		    (if (consp x)
-			(car x)
-			x))
-		   (t
-		    (if (consp x)
-			x
-			(list x)))))
-	   (bound (x)
-	     (if greater (numeric-type-low x) (numeric-type-high x)))
-	   (max-lower-bound (x y)
-	     ;; Both x and y are not null. Find the max.
-	     (let ((res (max (bound-value x) (bound-value y))))
-	       ;; An open lower bound is greater than a close
-	       ;; lower bound because the open bound doesn't
-	       ;; contain the bound, so choose an open lower
-	       ;; bound.
-	       (set-bound res (or (consp x) (consp y)))))
-	   (min-upper-bound (x y)
-	     ;; Same as above, but for the min of upper bounds
-	     ;; Both x and y are not null. Find the min.
-	     (let ((res (min (bound-value x) (bound-value y))))
-	       ;; An open upper bound is less than a closed
-	       ;; upper bound because the open bound doesn't
-	       ;; contain the bound, so choose an open lower
-	       ;; bound.
-	       (set-bound res (or (consp x) (consp y)))))
-	   (validate (x)
-	     (let ((x-lo (numeric-type-low x))
-		   (x-hi (numeric-type-high x)))
-	       (if (and x-lo x-hi (> (bound-value x-lo) (bound-value x-hi)))
-		   *empty-type*
-		   x))))
+             (cond ((not x) nil)
+                   (or-equal x)
+                   (t
+                    (if (consp x)
+                        x
+                        (list x)))))
+           (bound (x)
+             (if greater (numeric-type-low x) (numeric-type-high x)))
+           (tighter-p (x ref)
+             (cond ((null x) nil)
+                   ((null ref) t)
+                   ((and or-equal
+                         (= (type-bound-number x) (type-bound-number ref)))
+                    ;; X is tighter if REF is not an open bound and X is
+                    (and (not (consp ref)) (consp x)))
+                   (greater
+                    (< (type-bound-number ref) (type-bound-number x)))
+                   (t
+                    (> (type-bound-number ref) (type-bound-number x))))))
     (let* ((x-bound (bound x))
-	   (y-bound (exclude (bound y)))
-	   (new-bound (cond ((not x-bound)
-			     y-bound)
-			    ((not y-bound)
-			     x-bound)
-			    (greater
-			     (max-lower-bound x-bound y-bound))
-			    (t
-			     (min-upper-bound x-bound y-bound))))
-	   (res (copy-numeric-type x)))
+           (y-bound (exclude (bound y)))
+           (new-bound (cond ((not x-bound)
+                             y-bound)
+                            ((not y-bound)
+                             x-bound)
+                            ((tighter-p y-bound x-bound)
+                             y-bound)
+                            (t
+                             x-bound))))
       (if greater
-	  (setf (numeric-type-low res) new-bound)
-	  (setf (numeric-type-high res) new-bound))
-      (validate res))))
+          (modified-numeric-type x :low new-bound)
+          (modified-numeric-type x :high new-bound)))))
 
 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 ;;; restrictions from flow analysis IN, set the type for REF
@@ -341,103 +355,231 @@
   (let ((var-cons (copy-sset constraints)))
     (sset-intersection var-cons in)
     (let ((res (single-value-type (node-derived-type ref)))
-	  (not-res *empty-type*)
-	  (leaf (ref-leaf ref)))
+          (not-res *empty-type*)
+          (leaf (ref-leaf ref)))
       (do-sset-elements (con var-cons)
-	(let* ((x (constraint-x con))
-	       (y (constraint-y con))
-	       (not-p (constraint-not-p con))
-	       (other (if (eq x leaf) y x))
-	       (kind (constraint-kind con)))
-	  (case kind
-	    (typep
-	     (if not-p
-		 (setq not-res (type-union not-res other))
-		 (setq res (type-intersection res other))))
-	    (eql
-	     (let ((other-type (leaf-type other)))
-	       (if not-p
-		   (when (and (constant-p other)
-			      (member-type-p other-type))
-		     (setq not-res (type-union not-res other-type)))
-		   (let ((leaf-type (leaf-type leaf)))
-		     (when (or (constant-p other)
-			       (and (csubtypep other-type leaf-type)
-				    (not (type= other-type leaf-type))))
-		       (change-ref-leaf ref other)
-		       (when (constant-p other) (return)))))))
-	    ((< >)
-	     (cond ((and (integer-type-p res) (integer-type-p y))
-		    (let ((greater (eq kind '>)))
-		      (let ((greater (if not-p (not greater) greater)))
-			(setq res
-			      (constrain-integer-type res y greater not-p)))))
-		   #!+constrain-float-type
-		   ((and (float-type-p res) (float-type-p y))
-		    (let ((greater (eq kind '>)))
-		      (let ((greater (if not-p (not greater) greater)))
-			(setq res
-			      (constrain-float-type res y greater not-p)))))
-		   )))))
-
-      (let* ((cont (node-cont ref))
-	     (dest (continuation-dest cont)))
-	(cond ((and (if-p dest)
-		    (csubtypep (specifier-type 'null) not-res)
-		    (eq (continuation-asserted-type cont) *wild-type*))
-	       (setf (node-derived-type ref) *wild-type*)
-	       (change-ref-leaf ref (find-constant 't)))
-	      (t
-	       (derive-node-type ref (or (type-difference res not-res)
-					 res)))))))
+        (let* ((x (constraint-x con))
+               (y (constraint-y con))
+               (not-p (constraint-not-p con))
+               (other (if (eq x leaf) y x))
+               (kind (constraint-kind con)))
+          (case kind
+            (typep
+             (if not-p
+                 (setq not-res (type-union not-res other))
+                 (setq res (type-approx-intersection2 res other))))
+            (eql
+             (unless (lvar-p other)
+               (let ((other-type (leaf-type other)))
+                 (if not-p
+                     (when (and (constant-p other)
+                                (member-type-p other-type))
+                       (setq not-res (type-union not-res other-type)))
+                     (let ((leaf-type (leaf-type leaf)))
+                       (cond
+                         ((or (constant-p other)
+                              (and (leaf-refs other) ; protect from
+                                        ; deleted vars
+                                   (csubtypep other-type leaf-type)
+                                   (not (type= other-type leaf-type))))
+                          (change-ref-leaf ref other)
+                          (when (constant-p other) (return)))
+                         (t
+                          (setq res (type-approx-intersection2
+                                     res other-type)))))))))
+            ((< >)
+             (cond
+               ((and (integer-type-p res) (integer-type-p y))
+                (let ((greater (eq kind '>)))
+                  (let ((greater (if not-p (not greater) greater)))
+                    (setq res
+                          (constrain-integer-type res y greater not-p)))))
+               ((and (float-type-p res) (float-type-p y))
+                (let ((greater (eq kind '>)))
+                  (let ((greater (if not-p (not greater) greater)))
+                    (setq res
+                          (constrain-float-type res y greater not-p))))))))))
+      (cond ((and (if-p (node-dest ref))
+                  (csubtypep (specifier-type 'null) not-res))
+             (setf (node-derived-type ref) *wild-type*)
+             (change-ref-leaf ref (find-constant t)))
+            (t
+             (derive-node-type ref
+                               (make-single-value-type
+                                (or (type-difference res not-res)
+                                    res)))
+             (maybe-terminate-block ref nil)))))
 
   (values))
 
+;;;; Flow analysis
+
+(defun maybe-add-eql-var-lvar-constraint (ref gen)
+  (let ((lvar (ref-lvar ref))
+        (leaf (ref-leaf ref)))
+    (when (and (lambda-var-p leaf) lvar)
+      (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
+                   gen))))
+
+;;; Copy all CONSTRAINTS involving FROM-VAR to VAR except the (EQL VAR
+;;; LVAR) ones.
+(defun inherit-constraints (var from-var constraints target)
+  (do-sset-elements (con constraints)
+    (let ((eq-x (eq from-var (constraint-x con)))
+          (eq-y (eq from-var (constraint-y con))))
+      ;; Constant substitution is controversial.
+      (unless (constant-p (constraint-y con))
+        (when (or (and eq-x (not (lvar-p (constraint-y con))))
+                  eq-y)
+          (sset-adjoin (find-or-create-constraint
+                        (constraint-kind con)
+                        (if eq-x var (constraint-x con))
+                        (if eq-y var (constraint-y con))
+                        (constraint-not-p con))
+                       target))))))
+
+;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
+;; inherit each other's constraints.
+(defun add-eql-var-var-constraint (var1 var2 constraints
+                                   &optional (target constraints))
+  (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
+    (when (sset-adjoin con target)
+      (do-eql-vars (var2 (var2 constraints))
+        (inherit-constraints var1 var2 constraints target))
+      (do-eql-vars (var1 (var1 constraints))
+        (inherit-constraints var2 var1 constraints target))
+      t)))
+
+;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
+;; LAMBDA-VAR if possible.
+(defun maybe-add-eql-var-var-constraint (var lvar constraints
+                                         &optional (target constraints))
+  (declare (type lambda-var var) (type lvar lvar))
+  (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
+    (when lambda-var
+      (add-eql-var-var-constraint var lambda-var constraints target))))
+
+;;; Local propagation
+;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
+;;;    constraint.]
+;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
+;;;    a type constraint based on the new value type.
+(declaim (ftype (function (cblock sset
+                           &key (:ref-preprocessor (or null function))
+                                (:set-preprocessor (or null function)))
+                          sset)
+                constraint-propagate-in-block))
+(defun constraint-propagate-in-block
+    (block gen &key ref-preprocessor set-preprocessor)
+
+  (do-nodes (node lvar block)
+    (typecase node
+      (bind
+       (let ((fun (bind-lambda node)))
+         (when (eq (functional-kind fun) :let)
+           (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
+                 for var in (lambda-vars fun)
+                 and val in (combination-args call)
+                 when (and val (lambda-var-constraints var))
+                 do (let* ((type (lvar-type val))
+                           (con (find-or-create-constraint 'typep var type
+                                                           nil)))
+                      (sset-adjoin con gen))
+                 (maybe-add-eql-var-var-constraint var val gen)))))
+      (ref
+       (when (ok-ref-lambda-var node)
+         (maybe-add-eql-var-lvar-constraint node gen)
+         (when ref-preprocessor
+           (funcall ref-preprocessor node gen))))
+      (cast
+       (let ((lvar (cast-value node)))
+         (let ((var (ok-lvar-lambda-var lvar gen)))
+           (when var
+             (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
+               (do-eql-vars (var (var gen))
+                 (let ((con (find-or-create-constraint 'typep var atype nil)))
+                   (sset-adjoin con gen))))))))
+      (cset
+       (binding* ((var (set-var node))
+                  (nil (lambda-var-p var) :exit-if-null)
+                  (cons (lambda-var-constraints var) :exit-if-null))
+         (when set-preprocessor
+           (funcall set-preprocessor var))
+         (sset-difference gen cons)
+         (let* ((type (single-value-type (node-derived-type node)))
+                (con (find-or-create-constraint 'typep var type nil)))
+           (sset-adjoin con gen))
+         (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
+
+  gen)
+
+(defun constraint-propagate-if (block gen)
+  (let ((node (block-last block)))
+    (when (if-p node)
+      (let ((use (lvar-uses (if-test node))))
+        (when (node-p use)
+          (add-test-constraints use node gen))))))
+
+(defun constrain-node (node cons)
+  (let* ((var (ref-leaf node))
+         (con (lambda-var-constraints var)))
+    (constrain-ref-type node con cons)))
+
+;;; Starting from IN compute OUT and (consequent/alternative
+;;; constraints if the block ends with and IF). Return the list of
+;;; successors that may need to be recomputed.
+(defun find-block-type-constraints (block &key final-pass-p)
+  (declare (type cblock block))
+  (let ((gen (constraint-propagate-in-block
+              block
+              (if final-pass-p
+                  (block-in block)
+                  (copy-sset (block-in block)))
+              :ref-preprocessor (if final-pass-p #'constrain-node nil))))
+    (setf (block-gen block) gen)
+    (multiple-value-bind (consequent-constraints alternative-constraints)
+        (constraint-propagate-if block gen)
+      (if consequent-constraints
+          (let* ((node (block-last block))
+                 (old-consequent-constraints (if-consequent-constraints node))
+                 (old-alternative-constraints (if-alternative-constraints node))
+                 (succ ()))
+            ;; Add the consequent and alternative constraints to GEN.
+            (cond ((sset-empty consequent-constraints)
+                   (setf (if-consequent-constraints node) gen)
+                   (setf (if-alternative-constraints node) gen))
+                  (t
+                   (setf (if-consequent-constraints node) (copy-sset gen))
+                   (sset-union (if-consequent-constraints node)
+                               consequent-constraints)
+                   (setf (if-alternative-constraints node) gen)
+                   (sset-union (if-alternative-constraints node)
+                               alternative-constraints)))
+            ;; Has the consequent been changed?
+            (unless (and old-consequent-constraints
+                         (sset= (if-consequent-constraints node)
+                                old-consequent-constraints))
+              (push (if-consequent node) succ))
+            ;; Has the alternative been changed?
+            (unless (and old-alternative-constraints
+                         (sset= (if-alternative-constraints node)
+                                old-alternative-constraints))
+              (push (if-alternative node) succ))
+            succ)
+          ;; There is no IF.
+          (unless (and (block-out block)
+                       (sset= gen (block-out block)))
+            (setf (block-out block) gen)
+            (block-succ block))))))
+
 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
 ;;; During this pass, we also do local constraint propagation by
-;;; adding in constraints as we seem them during the pass through the
+;;; adding in constraints as we see them during the pass through the
 ;;; block.
 (defun use-result-constraints (block)
   (declare (type cblock block))
-  (let ((in (block-in block)))
-
-    (let ((test (block-test-constraint block)))
-      (when test
-	(sset-union in test)))
-
-    (do-nodes (node cont block)
-      (typecase node
-	(ref
-	 (let ((var (ref-leaf node)))
-	   (when (lambda-var-p var)
-	     (let ((con (lambda-var-constraints var)))
-	       (when con
-		 (constrain-ref-type node con in)
-		 (when (continuation-type-check cont)
-		   (sset-adjoin
-		    (find-constraint 'typep var
-				     (continuation-asserted-type cont)
-				     nil)
-		    in)))))))
-	(cset
-	 (let ((var (set-var node)))
-	   (when (lambda-var-p var)
-	     (let ((cons (lambda-var-constraints var)))
-	       (when cons
-		 (sset-difference in cons))))))))))
-
-;;; Return true if VAR would have to be closed over if environment
-;;; analysis ran now (i.e. if there are any uses that have a different
-;;; home lambda than VAR's home.)
-(defun closure-var-p (var)
-  (declare (type lambda-var var))
-  (let ((home (lambda-home (lambda-var-home var))))
-    (flet ((frob (l)
-	     (dolist (node l nil)
-	       (unless (eq (node-home-lambda node) home)
-		 (return t)))))
-      (or (frob (leaf-refs var))
-	  (frob (basic-var-sets var))))))
+  (constraint-propagate-in-block block (block-in block)
+                                 :ref-preprocessor #'constrain-node))
 
 ;;; Give an empty constraints set to any var that doesn't have one and
 ;;; isn't a set closure var. Since a var that we previously rejected
@@ -447,86 +589,132 @@
   (declare (type component component))
   (dolist (fun (component-lambdas component))
     (flet ((frob (x)
-	     (dolist (var (lambda-vars x))
-	       (unless (lambda-var-constraints var)
-		 (when (or (null (lambda-var-sets var))
-			   (not (closure-var-p var)))
-		   (setf (lambda-var-constraints var) (make-sset)))))))
+             (dolist (var (lambda-vars x))
+               (unless (lambda-var-constraints var)
+                 (when (or (null (lambda-var-sets var))
+                           (not (closure-var-p var)))
+                   (setf (lambda-var-constraints var) (make-sset)))))))
       (frob fun)
       (dolist (let (lambda-lets fun))
-	(frob let)))))
-
-;;; BLOCK-IN becomes the intersection of the OUT of the prececessors.
-;;; Our OUT is:
-;;;     out U (in - kill)
+        (frob let)))))
+
+;;; Return the constraints that flow from PRED to SUCC. This is
+;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
+;;; added.
+(defun block-out-for-successor (pred succ)
+  (declare (type cblock pred succ))
+  (let ((last (block-last pred)))
+    (or (when (if-p last)
+          (cond ((eq succ (if-consequent last))
+                 (if-consequent-constraints last))
+                ((eq succ (if-alternative last))
+                 (if-alternative-constraints last))))
+        (block-out pred))))
+
+(defun compute-block-in (block)
+  (let ((in nil))
+    (dolist (pred (block-pred block))
+      ;; If OUT has not been calculated, assume it to be the universal
+      ;; set.
+      (let ((out (block-out-for-successor pred block)))
+        (when out
+          (if in
+              (sset-intersection in out)
+              (setq in (copy-sset out))))))
+    (or in (make-sset))))
+
+(defun update-block-in (block)
+  (let ((in (compute-block-in block)))
+    (cond ((and (block-in block) (sset= in (block-in block)))
+           nil)
+          (t
+           (setf (block-in block) in)))))
+
+;;; Return two lists: one of blocks that precede all loops and
+;;; therefore require only one constraint propagation pass and the
+;;; rest. This implementation does not find all such blocks.
+;;;
+;;; A more complete implementation would be:
+;;;
+;;;     (do-blocks (block component)
+;;;       (if (every #'(lambda (pred)
+;;;                      (or (member pred leading-blocks)
+;;;                          (eq pred head)))
+;;;                  (block-pred block))
+;;;           (push block leading-blocks)
+;;;           (push block rest-of-blocks)))
 ;;;
-;;; BLOCK-KILL is just a list of the lambda-vars killed, so we must
-;;; compute the kill set when there are any vars killed. We bum this a
-;;; bit by special-casing when only one var is killed, and just using
-;;; that var's constraints as the kill set. This set could possibly be
-;;; precomputed, but it would have to be invalidated whenever any
-;;; constraint is added, which would be a pain.
-(defun flow-propagate-constraints (block)
-  (let* ((pred (block-pred block))
-	 (in (cond (pred
-		    (let ((res (copy-sset (block-out (first pred)))))
-		      (dolist (b (rest pred))
-			(sset-intersection res (block-out b)))
-		      res))
-		   (t
-		    (when *check-consistency*
-		      (let ((*compiler-error-context* (block-last block)))
-			(compiler-warning
-			 "*** Unreachable code in constraint ~
-			  propagation... Bug?")))
-		    (make-sset))))
-	 (kill (block-kill block))
-	 (out (block-out block)))
-
-    (setf (block-in block) in)
-    (cond ((null kill)
-	   (sset-union (block-out block) in))
-	  ((null (rest kill))
-	   (let ((con (lambda-var-constraints (first kill))))
-	     (if con
-		 (sset-union-of-difference out in con)
-		 (sset-union out in))))
-	  (t
-	   (let ((kill-set (make-sset)))
-	     (dolist (var kill)
-	       (let ((con (lambda-var-constraints var)))
-		 (when con
-		   (sset-union kill-set con))))
-	     (sset-union-of-difference (block-out block) in kill-set))))))
+;;; Trailing blocks that succeed all loops could be found and handled
+;;; similarly. In practice though, these more complex solutions are
+;;; slightly worse performancewise.
+(defun leading-component-blocks (component)
+  (declare (type component component))
+  (flet ((loopy-p (block)
+           (let ((n (block-number block)))
+             (dolist (pred (block-pred block))
+               (unless (< n (block-number pred))
+                 (return t))))))
+    (let ((leading-blocks ())
+          (rest-of-blocks ())
+          (seen-loop-p ()))
+      (do-blocks (block component)
+        (when (and (not seen-loop-p) (loopy-p block))
+          (setq seen-loop-p t))
+        (if seen-loop-p
+            (push block rest-of-blocks)
+            (push block leading-blocks)))
+      (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
+
+;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
+;;; a member already.
+(defun nconc-new (obj list)
+  (do ((x list (cdr x))
+       (prev nil x))
+      ((endp x) (if prev
+                    (progn
+                      (setf (cdr prev) (list obj))
+                      list)
+                    (list obj)))
+    (when (eql (car x) obj)
+      (return-from nconc-new list))))
+
+(defun find-and-propagate-constraints (component)
+  (let ((blocks-to-process ()))
+    (flet ((enqueue (blocks)
+             (dolist (block blocks)
+               (setq blocks-to-process (nconc-new block blocks-to-process)))))
+      (multiple-value-bind (leading-blocks rest-of-blocks)
+          (leading-component-blocks component)
+        ;; Update every block once to account for changes in the
+        ;; IR1. The constraints of the lead blocks cannot be changed
+        ;; after the first pass so we might as well use them and skip
+        ;; USE-RESULT-CONSTRAINTS later.
+        (dolist (block leading-blocks)
+          (setf (block-in block) (compute-block-in block))
+          (find-block-type-constraints block :final-pass-p t))
+        (setq blocks-to-process (copy-list rest-of-blocks))
+        ;; The rest of the blocks.
+        (dolist (block rest-of-blocks)
+          (aver (eq block (pop blocks-to-process)))
+          (setf (block-in block) (compute-block-in block))
+          (enqueue (find-block-type-constraints block)))
+        ;; Propagate constraints
+        (loop for block = (pop blocks-to-process)
+              while block do
+              (unless (eq block (component-tail component))
+                (when (update-block-in block)
+                  (enqueue (find-block-type-constraints block)))))
+        rest-of-blocks))))
 
 (defun constraint-propagate (component)
   (declare (type component component))
   (init-var-constraints component)
 
-  (do-blocks (block component)
-    (when (block-test-modified block)
-      (find-test-constraints block)))
-
-  (do-blocks (block component)
-    (cond ((block-type-asserted block)
-	   (find-block-type-constraints block))
-	  (t
-	   (setf (block-in block) nil)
-	   (setf (block-out block) (copy-sset (block-gen block))))))
-
-  (setf (block-out (component-head component)) (make-sset))
+  (unless (block-out (component-head component))
+    (setf (block-out (component-head component)) (make-sset)))
 
-  (let ((did-something nil))
-    (loop
-      (do-blocks (block component)
-	(when (flow-propagate-constraints block)
-	  (setq did-something t)))
-
-      (unless did-something (return))
-      (setq did-something nil)))
-
-  (do-blocks (block component)
-    (use-result-constraints block))
+  (dolist (block (find-and-propagate-constraints component))
+    (unless (block-delete-p block)
+      (use-result-constraints block)))
 
   (values))
-