Fix bugs in floating point optimizations.

typed-racket-lib/typed-racket/optimizer/float.rkt

@@ -112,31 +112,20 @@
        (not (subtypeof? stx -SingleFlonum))
        (not (subtypeof? stx -Int))))
 
-;; Check if an expression is a literal infinity
-(define (literal-infinity? a)
-  (syntax-parse a #:literal-sets (kernel-literals)
-    [(#%expression e) (literal-infinity? #'e)]
-    [(quote n) #:when (and (flonum? (syntax-e #'n))
-                           (not (rational? (syntax-e #'n))))
-     #t]
-    [_ #f]))
-
 ;; Check whether an expression can be safely converted to flonum without
 ;; changing the result (e.g., a large finite number becoming infinity).
-;; When there's an infinity operand, converting a huge exact number first
-;; can change semantics (e.g., huge - inf = -inf, but +inf - inf = nan).
-(define (safe-to-convert? a has-infinity-operand?)
+;; An infinity operand need not be a literal, so an unknown exact value
+;; cannot be converted early (e.g., huge - inf = -inf, but +inf - inf = nan).
+(define (safe-to-convert? a)
   (or (subtypeof? a -Fixnum)
       (syntax-parse a #:literal-sets (kernel-literals)
-        [(#%expression e) (safe-to-convert? #'e has-infinity-operand?)]
+        [(#%expression e) (safe-to-convert? #'e)]
         ;; Quoted flonum - already a float, safe
         [(quote n) #:when (flonum? (syntax-e #'n)) #t]
         ;; Quoted real number - check if it converts to a finite float
         [(quote n) #:when (real? (syntax-e #'n))
          (rational? (real->double-flonum (syntax-e #'n)))]
-        ;; Non-literal expressions: if there's an infinity operand, be conservative
-        ;; because we can't prove the value won't overflow
-        [_ (not has-infinity-operand?)])))
+        [_ #f])))
 
 (define-syntax-class float-opt-expr
   #:commit
@@ -154,11 +143,7 @@
                         ;; for now, accept anything that can be coerced to float
                         ;; finer-grained checking is done below
                         (~between fs:float-arg-expr 2 +inf.0) ...)
-           #:when (let* ([;; Check if any operand is a literal infinity
-                          has-infinity-operand?
-                          (for/or ([a (in-syntax #'(fs ...))])
-                            (literal-infinity? a))]
-                         [safe-to-opt?
+           #:when (let* ([safe-to-opt?
                           ;; For it to be safe, we need:
                           ;; - the result to be a float, in which case coercing args to floats
                           ;;   won't change the result type
@@ -170,16 +155,16 @@
                           ;;   operations into float operations by accident.
                           ;;   (Note: could allow for more args, if not next to each other, but
                           ;;    probably not worth the trouble (most ops have 2 args anyway))
-                          ;; - when there's an infinity operand, be more careful about
-                          ;;   converting exact numbers that might overflow
+                          ;; - converting an unknown exact value must not overflow when
+                          ;;   another operand evaluates to infinity
                           (and (subtypeof? this-syntax -Flonum)
                                (for/and ([a (in-syntax #'(fs ...))])
                                  ;; flonum or provably non-zero
                                  ;; also need to make sure that coercing to float won't change
                                  ;; a large finite number to infinity, altering the result
                                  (or (subtypeof? a -Flonum)
                                      (and (subtypeof? a (Un -PosReal -NegReal))
-                                          (safe-to-convert? a has-infinity-operand?))))
+                                          (safe-to-convert? a))))
                                (>= 1
                                    (for/sum ([a (in-syntax #'(fs ...))]
                                              #:when (not (subtypeof? a -Flonum)))

typed-racket-test/optimizer/known-bugs.rkt

@@ -109,6 +109,9 @@
 
     ;; Subtraction should not convert large numbers to infinity prematurely
     (good-opt (- (expt 10 309) +inf.0))
+    (good-opt (let ([n (expt 10 309)]
+                    [inf +inf.0])
+                (- n inf)))
 
     ;; make-polar with NaN should return complex NaN, not real NaN
     (good-opt (+ 1.0 (make-polar +nan.0 1.0)))
@@ -119,6 +122,10 @@
     (good-opt (exp (make-rectangular +inf.0 0.0)))
     (good-opt (exp (make-rectangular +nan.0 0.0)))))
 
+(module+ test
+  (require rackunit/text-ui)
+  (void (run-tests tests)))
+
 (module+ main
   (require rackunit/text-ui)
   (void (run-tests tests)))

typed-racket-test/optimizer/missed-optimizations/precision-loss.rkt

@@ -8,16 +8,16 @@ TR info: precision-loss.rkt 18:3 (* (r 3/4) 2/3) -- possible exact real arith
 TR info: precision-loss.rkt 19:14 (* 2.0 (* (r 3/4) 2/3)) -- possible exact real arith
 TR info: precision-loss.rkt 19:21 (* (r 3/4) 2/3) -- possible exact real arith
 TR info: precision-loss.rkt 6:3 (* 3/4 2/3) -- possible exact real arith
+TR missed opt: precision-loss.rkt 10:0 (+ (- 3/4) 2.0) -- all args float-arg-expr, result not Float -- caused by: 10:3 (- 3/4)
 TR missed opt: precision-loss.rkt 10:0 (+ (- 3/4) 2.0) -- exact ops inside float expr -- caused by: 10:3 (- 3/4)
+TR missed opt: precision-loss.rkt 12:0 (+ (vector-ref (quote #(2/3 1/2 3/4)) (assert (+ 1/4 3/4) exact-integer?)) 2.0) -- all args float-arg-expr, result not Float -- caused by: 12:3 (vector-ref (quote #(2/3 1/2 3/4)) (assert (+ 1/4 3/4) exact-integer?))
 TR missed opt: precision-loss.rkt 18:0 (* (* (r 3/4) 2/3) (car (list (* 2.0 (* (r 3/4) 2/3)))) 2.0) -- all args float-arg-expr, result not Float -- caused by: 18:3 (* (r 3/4) 2/3), 19:3 (car (list (* 2.0 (* (r 3/4) 2/3))))
 TR missed opt: precision-loss.rkt 18:3 (* (r 3/4) 2/3) -- all args float-arg-expr, result not Float -- caused by: 18:6 (r 3/4), 18:14 2/3
 TR missed opt: precision-loss.rkt 19:14 (* 2.0 (* (r 3/4) 2/3)) -- all args float-arg-expr, result not Float -- caused by: 19:21 (* (r 3/4) 2/3)
 TR missed opt: precision-loss.rkt 19:21 (* (r 3/4) 2/3) -- all args float-arg-expr, result not Float -- caused by: 19:24 (r 3/4), 19:32 2/3
+TR missed opt: precision-loss.rkt 6:0 (+ (* 3/4 2/3) 2.0) -- all args float-arg-expr, result not Float -- caused by: 6:3 (* 3/4 2/3)
 TR missed opt: precision-loss.rkt 6:0 (+ (* 3/4 2/3) 2.0) -- exact ops inside float expr -- caused by: 6:3 (* 3/4 2/3)
-TR opt: precision-loss.rkt 10:0 (+ (- 3/4) 2.0) -- binary float
-TR opt: precision-loss.rkt 12:0 (+ (vector-ref (quote #(2/3 1/2 3/4)) (assert (+ 1/4 3/4) exact-integer?)) 2.0) -- binary float
 TR opt: precision-loss.rkt 19:3 (car (list (* 2.0 (* (r 3/4) 2/3)))) -- pair
-TR opt: precision-loss.rkt 6:0 (+ (* 3/4 2/3) 2.0) -- binary float
 TR opt: precision-loss.rkt 8:0 (+ 3/4 2.0) -- binary float
 END
 #<<END

typed-racket-test/optimizer/tests/float-promotion.rkt

@@ -1,9 +1,9 @@
 #;#;
 #<<END
 TR info: float-promotion.rkt 2:3 (assert (modulo 1 2) exact-positive-integer?) -- vector of floats
+TR missed opt: float-promotion.rkt 3:0 (+ (expt 100 100) 2.0) -- all args float-arg-expr, result not Float -- caused by: 3:3 (expt 100 100)
 TR opt: float-promotion.rkt 2:0 (+ (assert (modulo 1 2) exact-positive-integer?) 2.0) -- binary float
 TR opt: float-promotion.rkt 2:11 (modulo 1 2) -- binary nonzero fixnum
-TR opt: float-promotion.rkt 3:0 (+ (expt 100 100) 2.0) -- binary float
 END
 #<<END
 3.0

typed-racket-test/optimizer/tests/float-real.rkt

@@ -4,11 +4,11 @@ TR info: float-real.rkt 3:15 (* (ann 2 Integer) 3.2) -- possible exact real arit
 TR info: float-real.rkt 3:7 (assert (* (ann 2 Integer) 3.2) positive?) -- vector of floats
 TR info: float-real.rkt 4:0 (* 2.3 (* (ann 2 Integer) 3.1)) -- possible exact real arith
 TR info: float-real.rkt 4:7 (* (ann 2 Integer) 3.1) -- possible exact real arith
+TR missed opt: float-real.rkt 3:0 (+ 2.3 (assert (* (ann 2 Integer) 3.2) positive?)) -- all args float-arg-expr, result not Float -- caused by: 3:0 (+ 2.3 (assert (* (ann 2 Integer) 3.2) positive?))
 TR missed opt: float-real.rkt 3:15 (* (ann 2 Integer) 3.2) -- all args float-arg-expr, result not Float -- caused by: 3:23 2
 TR missed opt: float-real.rkt 4:0 (* 2.3 (* (ann 2 Integer) 3.1)) -- all args float-arg-expr, result not Float -- caused by: 4:7 (* (ann 2 Integer) 3.1)
 TR missed opt: float-real.rkt 4:7 (* (ann 2 Integer) 3.1) -- all args float-arg-expr, result not Float -- caused by: 4:15 2
 TR opt: float-real.rkt 2:0 (+ 2.3 (ann 3 Positive-Real)) -- binary float
-TR opt: float-real.rkt 3:0 (+ 2.3 (assert (* (ann 2 Integer) 3.2) positive?)) -- binary float
 END
 #<<END
 5.3