open intervals and type derivation

When dealing with open intervals, preserving the openness of a bound in
a result depends on the operation being strictly monotonic, rather than
merely monotonic.  However, many operations which at first sight seem
strictly monotonic are in fact not, including:
- squaring (expt least-positive-double-float 2) = (expt 0d0 2)
- coercion (coerce (1+ double-float-epsilon) 'single-float)
  = (coerce 1d0 'single-float)

Modify various coercion and interval functions to include conservatism
in these situations.  (Fixes lp#997528)

diff --git a/NEWS b/NEWS
index 2c3b5f6..51b81fa 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -61,6 +61,9 @@ changes relative to sbcl-1.0.56:
     allowing faster release of memory back to the OS. (lp#991293)
   * bug fix: WITH-DEADLINE (:SECONDS NIL :OVERRIDE T) now drops any
     existing deadline for the dynamic scope of its body.
+  * bug fix: compiler-internal interval arithmetic needed to be more
+    conservative about open intervals when operated on by monotonic but not
+    strictly-monotonic functions.  (lp#975528)
   * documentation:
     ** improved docstrings: REPLACE (lp#965592)
 

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index b5cd536..1877cef 100644 (file)
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -326,12 +326,14 @@
                                        (if (< x ,most-negative)
                                            ,most-negative
                                            (coerce x ',type)))
-                                     (numeric-type-low num)))
+                                     (numeric-type-low num)
+                                     nil))
                      (hi (bound-func (lambda (x)
                                        (if (< ,most-positive x )
                                            ,most-positive
                                            (coerce x ',type)))
-                                     (numeric-type-high num))))
+                                     (numeric-type-high num)
+                                     nil)))
                 (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
 
             (defoptimizer (,fun derive-type) ((num))
@@ -791,9 +793,9 @@
                  ;; Process the intersection.
                  (let* ((low (interval-low intersection))
                         (high (interval-high intersection))
-                        (res-lo (or (bound-func fun (if increasingp low high))
+                        (res-lo (or (bound-func fun (if increasingp low high) nil)
                                     default-low))
-                        (res-hi (or (bound-func fun (if increasingp high low))
+                        (res-hi (or (bound-func fun (if increasingp high low) nil)
                                     default-high))
                         (format (case (numeric-type-class arg)
                                   ((integer rational) 'single-float)
@@ -972,9 +974,9 @@
                    (int-hi (if hi
                                (ceiling (type-bound-number hi))
                                '*))
-                   (f-lo (or (bound-func #'float lo)
+                   (f-lo (or (bound-func #'float lo nil)
                              '*))
-                   (f-hi (or (bound-func #'float hi)
+                   (f-hi (or (bound-func #'float hi nil)
                              '*)))
               (specifier-type `(or (rational ,int-lo ,int-hi)
                                 (single-float ,f-lo, f-hi)))))
@@ -1004,9 +1006,9 @@
                    (int-hi (if hi
                                (ceiling (type-bound-number hi))
                                '*))
-                   (f-lo (or (bound-func #'float lo)
+                   (f-lo (or (bound-func #'float lo nil)
                              '*))
-                   (f-hi (or (bound-func #'float hi)
+                   (f-hi (or (bound-func #'float hi nil)
                              '*)))
               (specifier-type `(or (rational ,int-lo ,int-hi)
                                 (single-float ,f-lo, f-hi)))))
@@ -1449,8 +1451,8 @@
               ;; exactly the same way as the functions themselves do
               ;; it.
               (if (csubtypep arg domain)
-                  (let ((res-lo (bound-func fun (numeric-type-low arg)))
-                        (res-hi (bound-func fun (numeric-type-high arg))))
+                  (let ((res-lo (bound-func fun (numeric-type-low arg) nil))
+                        (res-hi (bound-func fun (numeric-type-high arg) nil)))
                     (unless increasingp
                       (rotatef res-lo res-hi))
                     (make-numeric-type

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index ad7abbc..c2f1aec 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -345,9 +345,10 @@
 (defun set-bound (x open-p)
   (if (and x open-p) (list x) x))
 
-;;; Apply the function F to a bound X. If X is an open bound, then
-;;; the result will be open. IF X is NIL, the result is NIL.
-(defun bound-func (f x)
+;;; Apply the function F to a bound X. If X is an open bound and the
+;;; function is declared strictly monotonic, then the result will be
+;;; open. IF X is NIL, the result is NIL.
+(defun bound-func (f x strict)
   (declare (type function f))
   (and x
        (handler-case
@@ -359,7 +360,7 @@
              (if (and (floatp y)
                       (float-infinity-p y))
                  nil
-                 (set-bound y (consp x)))))
+                 (set-bound y (and strict (consp x))))))
          ;; Some numerical operations will signal SIMPLE-TYPE-ERROR, e.g.
          ;; in the course of converting a bignum to a float.  Default to
          ;; NIL in that case.
@@ -464,9 +465,19 @@
                                   `(and (not (fp-zero-p ,xb))
                                         (not (fp-zero-p ,yb))))))))))))
 
+(defun coercion-loses-precision-p (val type)
+  (typecase val
+    (single-float)
+    (double-float (subtypep type 'single-float))
+    (rational (subtypep type 'float))
+    (t (bug "Unexpected arguments to bounds coercion: ~S ~S" val type))))
+
 (defun coerce-for-bound (val type)
   (if (consp val)
-      (list (coerce-for-bound (car val) type))
+      (let ((xbound (coerce-for-bound (car val) type)))
+        (if (coercion-loses-precision-p (car val) type)
+            xbound
+            (list xbound)))
       (cond
         ((subtypep type 'double-float)
          (if (<= most-negative-double-float val most-positive-double-float)
@@ -480,7 +491,10 @@
 (defun coerce-and-truncate-floats (val type)
   (when val
     (if (consp val)
-        (list (coerce-and-truncate-floats (car val) type))
+        (let ((xbound (coerce-for-bound (car val) type)))
+          (if (coercion-loses-precision-p (car val) type)
+              xbound
+              (list xbound)))
         (cond
           ((subtypep type 'double-float)
            (if (<= most-negative-double-float val most-positive-double-float)
@@ -781,8 +795,8 @@
 ;;; the negative of an interval
 (defun interval-neg (x)
   (declare (type interval x))
-  (make-interval :low (bound-func #'- (interval-high x))
-                 :high (bound-func #'- (interval-low x))))
+  (make-interval :low (bound-func #'- (interval-high x) t)
+                 :high (bound-func #'- (interval-low x) t)))
 
 ;;; Add two intervals.
 (defun interval-add (x y)
@@ -891,13 +905,17 @@
 
 ;;; Apply the function F to the interval X. If X = [a, b], then the
 ;;; result is [f(a), f(b)]. It is up to the user to make sure the
-;;; result makes sense. It will if F is monotonic increasing (or
-;;; non-decreasing).
-(defun interval-func (f x)
+;;; result makes sense. It will if F is monotonic increasing (or, if
+;;; the interval is closed, non-decreasing).
+;;;
+;;; (Actually most uses of INTERVAL-FUNC are coercions to float types,
+;;; which are not monotonic increasing, so default to calling
+;;; BOUND-FUNC with a non-strict argument).
+(defun interval-func (f x &optional increasing)
   (declare (type function f)
            (type interval x))
-  (let ((lo (bound-func f (interval-low x)))
-        (hi (bound-func f (interval-high x))))
+  (let ((lo (bound-func f (interval-low x) increasing))
+        (hi (bound-func f (interval-high x) increasing)))
     (make-interval :low lo :high hi)))
 
 ;;; Return T if X < Y. That is every number in the interval X is
@@ -969,8 +987,7 @@
 ;;; Compute the square of an interval.
 (defun interval-sqr (x)
   (declare (type interval x))
-  (interval-func (lambda (x) (* x x))
-                 (interval-abs x)))
+  (interval-func (lambda (x) (* x x)) (interval-abs x)))
 \f
 ;;;; numeric DERIVE-TYPE methods
 

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index b5d6512..4361794 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -2275,4 +2275,14 @@
             (assert (= 7 (funcall fun 15 3))))))
     (assert (string= "" trace-output))))
 
+(test-util:with-test (:name :bug-997528)
+  (let ((fun (compile nil '(lambda (x)
+                            (declare (optimize (speed 0) (space 0))
+                             (type (integer -228645653448155482 -228645653447928749) x))
+                            (floor 1.0 (the (integer -228645653448151677 -228645653448150900) x))))))
+    (multiple-value-bind (quo rem)
+        (funcall fun -228645653448151381)
+      (assert (= quo -1))
+      (assert (= rem (float -228645653448151381))))))
+
 ;;; success