0.9.11.4

  * fixed constraint propagation of open/closed float boundaries

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index cec6770..3bc7362 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -310,49 +310,39 @@
 
   (aver (eql (numeric-type-class x) 'float))
   (aver (eql (numeric-type-class y) 'float))
-  #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+  #+sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
   x
-  #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+  #-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 (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
-               ;; 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 (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))))))
+           (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))
+                            ((tighter-p y-bound x-bound)
+                             y-bound)
                             (t
-                             (min-upper-bound x-bound y-bound)))))
+                             x-bound))))
       (if greater
           (modified-numeric-type x :low new-bound)
           (modified-numeric-type x :high new-bound)))))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index bd1ed47..b2ed282 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -2012,3 +2012,23 @@
                              (declare (optimize (speed 3)))
                            (1+ x)))))
      (compiler-note () (error "The code is not optimized.")))))
+
+(with-test (:name (:compiler :constraint-propagation :float-bounds-1))
+  (handler-case
+      (compile nil '(lambda (x)
+                      (declare (type (single-float * (3.0)) x))
+                      (when (<= x 2.0)
+                        (when (<= 2.0 x)
+                          x))))
+    (compiler-note () (error "Deleted reachable code."))))
+
+(with-test (:name (:compiler :constraint-propagation :float-bounds-2))
+  (catch :note
+    (handler-case
+        (compile nil '(lambda (x)
+                        (declare (type single-float x))
+                        (when (< 1.0 x)
+                          (when (<= x 1.0)
+                            (error "This is unreachable.")))))
+      (compiler-note () (throw :note nil)))
+    (error "Unreachable code undetected.")))

diff --git a/version.lisp-expr b/version.lisp-expr
index 18b84a1..974877b 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.11.3"
+"0.9.11.4"