From f610d5d0f80db2f4e55c8385fc3ca45d92ed04ec Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 27 Feb 2007 21:57:12 +0000 Subject: [PATCH] 1.0.3.1: fix behaviour of >= and <= with NaNs * Problem: (>= (/ 0.0 0.0) 1.0) evaluates to true. Move inversion from >= to < and from <= to > from the source transformations to new deftransforms, and make it conditional on the derived type, avoiding the inversion for potential floats. This fixes the NaN issues with >= and <=, but exposes gaps in our transformations for =, causing a constraint propagation test to fail... * Tweak the deftransform for = so that another transformation can co-exist with it. Write INTERVAL-= and INTERVAL-/=, and deftransforms for = and /= based on them. This fixes the constant propagation issue, except for the bug it exposes elsewhere... * INTERVAL-INTERSECTION/DIFFERENCE returns bogus intersections -- fix it. ...and all is well. * Tests. * NUMERIC-TYPE-OR-LOSE is unused, deleted. * Also fix tests/stream.impure.lisp for UTF-8 environments. --- NEWS | 3 + src/compiler/srctran.lisp | 154 +++++++++++++++++++++++++++++---------------- tests/float.pure.lisp | 19 ++++++ tests/stream.impure.lisp | 2 +- version.lisp-expr | 2 +- 5 files changed, 123 insertions(+), 57 deletions(-) diff --git a/NEWS b/NEWS index 35526eb..029754f 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,7 @@ ;;;; -*- coding: utf-8; -*- +changes in sbcl-1.0.4 relative to sbcl-1.0.3: + * bug fix: >= and <= gave wrong results when used with NaNs. + changes in sbcl-1.0.3 relative to sbcl-1.0.2: * new platform: NetBSD/PPC. (thanks to Aymeric Vincent) * optimization: calls of the form (AREF FOO (+ INDEX )) now diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 81c82d2..30c0c61 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -511,15 +511,13 @@ ;;; 1] and Y = [1, 2] to determine intersection. (defun interval-intersect-p (x y &optional closed-intervals-p) (declare (type interval x y)) - (multiple-value-bind (intersect diff) - (interval-intersection/difference (if closed-intervals-p - (interval-closure x) - x) - (if closed-intervals-p - (interval-closure y) - y)) - (declare (ignore diff)) - intersect)) + (and (interval-intersection/difference (if closed-intervals-p + (interval-closure x) + x) + (if closed-intervals-p + (interval-closure y) + y)) + t)) ;;; Are the two intervals adjacent? That is, is there a number ;;; between the two intervals that is not an element of either @@ -563,27 +561,44 @@ (if (listp p) (first p) (list p))) - (test-number (p int) + (test-number (p int bound) ;; Test whether P is in the interval. - (when (interval-contains-p (type-bound-number p) - (interval-closure int)) - (let ((lo (interval-low int)) - (hi (interval-high int))) + (let ((pn (type-bound-number p))) + (when (interval-contains-p pn (interval-closure int)) ;; Check for endpoints. - (cond ((and lo (= (type-bound-number p) (type-bound-number lo))) - (not (and (consp p) (numberp lo)))) - ((and hi (= (type-bound-number p) (type-bound-number hi))) - (not (and (numberp p) (consp hi)))) - (t t))))) + (let* ((lo (interval-low int)) + (hi (interval-high int)) + (lon (type-bound-number lo)) + (hin (type-bound-number hi))) + (cond + ;; Interval may be a point. + ((and lon hin (= lon hin pn)) + (and (numberp p) (numberp lo) (numberp hi))) + ;; Point matches the low end. + ;; [P] [P,?} => TRUE [P] (P,?} => FALSE + ;; (P [P,?} => TRUE P) [P,?} => FALSE + ;; (P (P,?} => TRUE P) (P,?} => FALSE + ((and lon (= pn lon)) + (or (and (numberp p) (numberp lo)) + (and (consp p) (eq :low bound)))) + ;; [P] {?,P] => TRUE [P] {?,P) => FALSE + ;; P) {?,P] => TRUE (P {?,P] => FALSE + ;; P) {?,P) => TRUE (P {?,P) => FALSE + ((and hin (= pn hin)) + (or (and (numberp p) (numberp hi)) + (and (consp p) (eq :high bound)))) + ;; Not an endpoint, all is well. + (t + t)))))) (test-lower-bound (p int) ;; P is a lower bound of an interval. (if p - (test-number p int) + (test-number p int :low) (not (interval-bounded-p int 'below)))) (test-upper-bound (p int) ;; P is an upper bound of an interval. (if p - (test-number p int) + (test-number p int :high) (not (interval-bounded-p int 'above))))) (let ((x-lo-in-y (test-lower-bound x-lo y)) (x-hi-in-y (test-upper-bound x-hi y)) @@ -816,6 +831,24 @@ (>= (type-bound-number (interval-low x)) (type-bound-number (interval-high y))))) +;;; Return T if X = Y. +(defun interval-= (x y) + (declare (type interval x y)) + (and (interval-bounded-p x 'both) + (interval-bounded-p y 'both) + (flet ((bound (v) + (if (numberp v) + v + ;; Open intervals cannot be = + (return-from interval-= nil)))) + ;; Both intervals refer to the same point + (= (bound (interval-high x)) (bound (interval-low x)) + (bound (interval-high y)) (bound (interval-low y)))))) + +;;; Return T if X /= Y +(defun interval-/= (x y) + (not (interval-intersect-p x y))) + ;;; Return an interval that is the absolute value of X. Thus, if ;;; X = [-1 10], the result is [0, 10]. (defun interval-abs (x) @@ -3353,41 +3386,44 @@ ;;; Convert to EQL if both args are rational and complexp is specified ;;; and the same for both. -(deftransform = ((x y) * *) +(deftransform = ((x y) (number number) *) "open code" (let ((x-type (lvar-type x)) (y-type (lvar-type y))) - (if (and (csubtypep x-type (specifier-type 'number)) - (csubtypep y-type (specifier-type 'number))) - (cond ((or (and (csubtypep x-type (specifier-type 'float)) - (csubtypep y-type (specifier-type 'float))) - (and (csubtypep x-type (specifier-type '(complex float))) - (csubtypep y-type (specifier-type '(complex float))))) - ;; They are both floats. Leave as = so that -0.0 is - ;; handled correctly. - (give-up-ir1-transform)) - ((or (and (csubtypep x-type (specifier-type 'rational)) - (csubtypep y-type (specifier-type 'rational))) - (and (csubtypep x-type - (specifier-type '(complex rational))) - (csubtypep y-type - (specifier-type '(complex rational))))) - ;; They are both rationals and complexp is the same. - ;; Convert to EQL. - '(eql x y)) - (t - (give-up-ir1-transform - "The operands might not be the same type."))) - (give-up-ir1-transform - "The operands might not be the same type.")))) - -;;; If LVAR's type is a numeric type, then return the type, otherwise -;;; GIVE-UP-IR1-TRANSFORM. -(defun numeric-type-or-lose (lvar) - (declare (type lvar lvar)) - (let ((res (lvar-type lvar))) - (unless (numeric-type-p res) (give-up-ir1-transform)) - res)) + (cond ((or (and (csubtypep x-type (specifier-type 'float)) + (csubtypep y-type (specifier-type 'float))) + (and (csubtypep x-type (specifier-type '(complex float))) + (csubtypep y-type (specifier-type '(complex float))))) + ;; They are both floats. Leave as = so that -0.0 is + ;; handled correctly. + (give-up-ir1-transform)) + ((or (and (csubtypep x-type (specifier-type 'rational)) + (csubtypep y-type (specifier-type 'rational))) + (and (csubtypep x-type + (specifier-type '(complex rational))) + (csubtypep y-type + (specifier-type '(complex rational))))) + ;; They are both rationals and complexp is the same. + ;; Convert to EQL. + '(eql x y)) + (t + (give-up-ir1-transform + "The operands might not be the same type."))))) + +(labels ((maybe-float-lvar-p (lvar) + (neq *empty-type* (type-intersection (specifier-type 'float) + (lvar-type lvar)))) + (maybe-invert (op inverted x y) + ;; Don't invert if either argument can be a float (NaNs) + (if (or (maybe-float-lvar-p x) (maybe-float-lvar-p y)) + `(or (,op x y) (= x y)) + `(if (,inverted x y) nil t)))) + (deftransform >= ((x y) (number number) *) + "invert or open code" + (maybe-invert '> '< x y)) + (deftransform <= ((x y) (number number) *) + "invert or open code" + (maybe-invert '< '> x y))) ;;; See whether we can statically determine (< X Y) using type ;;; information. If X's high bound is < Y's low, then X < Y. @@ -3395,6 +3431,7 @@ ;;; NIL). If not, at least make sure any constant arg is second. (macrolet ((def (name inverse reflexive-p surely-true surely-false) `(deftransform ,name ((x y)) + "optimize using intervals" (if (same-leaf-ref-p x y) ,reflexive-p (let ((ix (or (type-approximate-interval (lvar-type x)) @@ -3410,6 +3447,8 @@ `(,',inverse y x)) (t (give-up-ir1-transform)))))))) + (def = = t (interval-= ix iy) (interval-/= ix iy)) + (def /= /= nil (interval-/= ix iy) (interval-= ix iy)) (def < > nil (interval-< ix iy) (interval->= ix iy)) (def > < nil (interval-< iy ix) (interval->= iy ix)) (def <= >= t (interval->= iy ix) (interval-< iy ix)) @@ -3474,8 +3513,13 @@ (define-source-transform = (&rest args) (multi-compare '= args nil 'number)) (define-source-transform < (&rest args) (multi-compare '< args nil 'real)) (define-source-transform > (&rest args) (multi-compare '> args nil 'real)) -(define-source-transform <= (&rest args) (multi-compare '> args t 'real)) -(define-source-transform >= (&rest args) (multi-compare '< args t 'real)) +;;; We cannot do the inversion for >= and <= here, since both +;;; (< NaN X) and (> NaN X) +;;; are false, and we don't have type-inforation available yet. The +;;; deftransforms for two-argument versions of >= and <= takes care of +;;; the inversion to > and < when possible. +(define-source-transform <= (&rest args) (multi-compare '<= args nil 'real)) +(define-source-transform >= (&rest args) (multi-compare '>= args nil 'real)) (define-source-transform char= (&rest args) (multi-compare 'char= args nil 'character)) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index 275cb72..a907faf 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -156,3 +156,22 @@ (+ x0 x2 x4 x6) (+ x1 x3 x5 x7) (+ x0 x3 x4 x7) (+ x1 x2 x5 x6) (+ x0 x1 x6 x7) (+ x2 x3 x4 x5))))))) + +(with-test (:name :nan-comparisons) + (macrolet ((test (form) + (let ((nform (subst (/ 0.0 0.0) 'nan form))) + `(progn + (assert (not (eval ',nform))) + (assert (not (funcall (lambda () ,nform)))))))) + ;; Source transforms for >= and <= used to be too eager about + ;; inverting the test, causing NaN issues. + (test (>= nan 1.0)) + (test (>= 1.0 nan)) + (test (>= 1.0 nan 0.0)) + (test (>= 1.0 0.0 nan)) + (test (>= nan 1.0 0.0)) + (test (<= nan 1.0)) + (test (<= 1.0 nan)) + (test (<= 1.0 nan 2.0)) + (test (<= 1.0 2.0 nan)) + (test (<= nan 1.0 2.0)))) diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp index c0830a6..4a250ac 100644 --- a/tests/stream.impure.lisp +++ b/tests/stream.impure.lisp @@ -291,6 +291,7 @@ (let ((sequence (make-array 1 :element-type '(signed-byte 8)))) (with-open-file (stream pathname :direction :input + :external-format :latin1 :element-type :default) (handler-case (progn (read-sequence sequence stream) @@ -299,7 +300,6 @@ (assert (eql (type-error-datum condition) (code-char 255))) (assert (subtypep (type-error-expected-type condition) '(signed-byte 8)))))))) - ;;; Check WRITE-SEQUENCE signals a TYPE-ERROR when the stream can't ;;; write a sequence element. diff --git a/version.lisp-expr b/version.lisp-expr index 8cd2bad..2b8b70b 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".) -"1.0.3" +"1.0.3.1" -- 1.7.10.4