From a406d16494b6f127c9ddc96ed279ba7c371f199d Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Tue, 28 Mar 2006 09:59:06 +0000 Subject: [PATCH] 0.9.11.4 * fixed constraint propagation of open/closed float boundaries --- src/compiler/constraint.lisp | 42 ++++++++++++++++-------------------------- tests/compiler.pure.lisp | 20 ++++++++++++++++++++ version.lisp-expr | 2 +- 3 files changed, 37 insertions(+), 27 deletions(-) diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index cec6770..3bc7362 100644 --- 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 --- 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 --- 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" -- 1.7.10.4