X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fconstraint.lisp;h=a3022458c77e374e4d329ea5bd364fffd62aeac9;hb=d40a76606c86722b0aef8179155f9f2840739b72;hp=a6462843dfae140aedf6129ee86029b979d97f3b;hpb=4a0ab5193096ca70dbbf43bb21418544f6d018b7;p=sbcl.git

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index a646284..a302245 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -126,7 +126,7 @@
      (add-complement-constraints if 'typep (ok-ref-lambda-var use)
 				 (specifier-type 'null) t))
     (combination
-     (let ((name (continuation-function-name
+     (let ((name (continuation-fun-name
 		  (basic-combination-fun use)))
 	   (args (basic-combination-args use)))
        (case name
@@ -187,7 +187,7 @@
 
 ;;; 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
+;;; -- 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))
@@ -217,7 +217,7 @@
 
       (setf (block-in block) nil)
       (setf (block-gen block) gen)
-      (setf (block-kill block) (kill))
+      (setf (block-kill-list block) (kill))
       (setf (block-out block) (copy-sset gen))
       (setf (block-type-asserted block) nil)
       (values))))
@@ -266,7 +266,8 @@
 ;;; 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))
-  (declare (ignorable x y)) ; for CROSS-FLOAT-INFINITY-KLUDGE
+  (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.)
@@ -355,7 +356,6 @@
 		      (let ((greater (if not-p (not greater) greater)))
 			(setq res
 			      (constrain-integer-type res y greater not-p)))))
-		   #!+sb-constrain-float-type
 		   ((and (float-type-p res) (float-type-p y))
 		    (let ((greater (eq kind '>)))
 		      (let ((greater (if not-p (not greater) greater)))
@@ -439,11 +439,11 @@
       (dolist (let (lambda-lets fun))
 	(frob let)))))
 
-;;; BLOCK-IN becomes the intersection of the OUT of the prececessors.
+;;; BLOCK-IN becomes the intersection of the OUT of the predecessors.
 ;;; Our OUT is:
 ;;;     out U (in - kill)
 ;;;
-;;; BLOCK-KILL 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
@@ -457,31 +457,38 @@
 			(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?")))
+		    (let ((*compiler-error-context* (block-last block)))
+		      (compiler-warn
+		       "unreachable code in constraint ~
+			propagation -- apparent compiler bug"))
 		    (make-sset))))
-	 (kill (block-kill block))
+	 (kill-list (block-kill-list block))
 	 (out (block-out block)))
 
     (setf (block-in block) in)
-    (cond ((null kill)
+    (cond ((null kill-list)
 	   (sset-union (block-out block) in))
-	  ((null (rest kill))
-	   (let ((con (lambda-var-constraints (first kill))))
+	  ((null (rest kill-list))
+	   (let ((con (lambda-var-constraints (first kill-list))))
 	     (if con
 		 (sset-union-of-difference out in con)
 		 (sset-union out in))))
 	  (t
 	   (let ((kill-set (make-sset)))
-	     (dolist (var kill)
+	     (dolist (var kill-list)
 	       (let ((con (lambda-var-constraints var)))
 		 (when con
 		   (sset-union kill-set con))))
 	     (sset-union-of-difference (block-out block) in kill-set))))))
 
+;;; How many blocks does COMPONENT have?
+(defun component-n-blocks (component)
+  (let ((result 0))
+    (declare (type index result))
+    (do-blocks (block component :both)
+      (incf result))
+    result))
+
 (defun constraint-propagate (component)
   (declare (type component component))
   (init-var-constraints component)
@@ -499,17 +506,20 @@
 
   (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)))
+  (let (;; If we have to propagate changes more than this many times,
+	;; something is wrong.
+	(max-n-changes-remaining (component-n-blocks component)))
+    (declare (type fixnum max-n-changes-remaining))
+    (loop (aver (plusp max-n-changes-remaining))
+	  (decf max-n-changes-remaining)
+	  (let ((did-something nil))
+	    (do-blocks (block component)
+	      (when (flow-propagate-constraints block)
+		(setq did-something t)))
+	    (unless did-something
+	      (return)))))
 
   (do-blocks (block component)
     (use-result-constraints block))
 
   (values))
-