X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=823a16324d2edcc3d22fe133b0a18d05cad21c4c;hb=cd2c70c8b5d4dcc62b968f5a9bedd3c9c8698e82;hp=c8b5715bb0c8ff7b12f0059d2906a0a338800810;hpb=0a82f2db352cc348d2107a882e50af222ff97ed3;p=sbcl.git

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index c8b5715..823a163 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -110,9 +110,14 @@
 
 ;;; 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)
-  (when x
+  (when (and x
+	     ;; 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.
+             (not (eq (if-consequent if)
+                      (if-alternative if))))
     (add-test-constraint (if-consequent if) fun x y not-p)
     (add-test-constraint (if-alternative if) fun x y (not not-p)))
   (values))
@@ -126,50 +131,52 @@
      (add-complement-constraints if 'typep (ok-ref-lambda-var use)
 				 (specifier-type 'null) t))
     (combination
-     (let ((name (continuation-fun-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))))))))
+     (unless (eq (combination-kind use)
+                 :error)
+       (let ((name (continuation-fun-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
@@ -443,7 +450,7 @@
 ;;; Our OUT is:
 ;;;     out U (in - kill)
 ;;;
-;;; BLOCK-KILL-LIST is just a list of the lambda-vars killed, so we must
+;;; BLOCK-KILL-LIST 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
@@ -458,7 +465,7 @@
 		      res))
 		   (t
 		    (let ((*compiler-error-context* (block-last block)))
-		      (compiler-warning
+		      (compiler-warn
 		       "unreachable code in constraint ~
 			propagation -- apparent compiler bug"))
 		    (make-sset))))