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

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 4e4e98a..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))))
@@ -245,23 +245,16 @@
 		 (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)))
+	   (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)))
+			    (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)
@@ -273,12 +266,13 @@
 ;;; 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)
@@ -293,8 +287,8 @@
 	   (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))))
+	     ;; Both X and Y are not null. Find the max.
+	     (let ((res (max (type-bound-number x) (type-bound-number 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
@@ -302,19 +296,13 @@
 	       (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))))
+	     ;; Both X and Y are not null. Find the min.
+	     (let ((res (min (type-bound-number x) (type-bound-number 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))))
+	       (set-bound res (or (consp x) (consp y))))))
     (let* ((x-bound (bound x))
 	   (y-bound (exclude (bound y)))
 	   (new-bound (cond ((not x-bound)
@@ -324,12 +312,10 @@
 			    (greater
 			     (max-lower-bound x-bound y-bound))
 			    (t
-			     (min-upper-bound x-bound y-bound))))
-	   (res (copy-numeric-type x)))
+			     (min-upper-bound 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)))))
 
 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 ;;; restrictions from flow analysis IN, set the type for REF
@@ -370,7 +356,6 @@
 		      (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)))
@@ -384,7 +369,7 @@
 		    (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)))
+	       (change-ref-leaf ref (find-constant t)))
 	      (t
 	       (derive-node-type ref (or (type-difference res not-res)
 					 res)))))))
@@ -454,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
@@ -472,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)
@@ -514,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))
-