Avoid premature float conversions.

Found using random testing.

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

@@ -50,12 +50,39 @@
       "The optimizer could optimize it better if it had type Float-Complex.")
     this-syntax))
 
+;; keep track of operands that were reals (and thus had exact 0 as imaginary part)
 (define real-id-table (make-free-id-table))
 (define (was-real? stx)
   (free-id-table-ref real-id-table stx #f))
 (define (mark-as-real stx)
   (free-id-table-set! real-id-table stx #t)
   stx)
+;; keep track of operands that were not floats (i.e. rationals and single floats)
+;; to avoid prematurely converting to floats, which may change results
+(define non-float-table (make-hash))
+(define (as-non-float stx)
+  (hash-ref non-float-table stx #f))
+(define (mark-as-non-float stx orig)
+  (hash-set! non-float-table stx orig)
+  stx)
+
+(define (n-ary->binary/non-floats op unsafe this-syntax cs)
+  (let loop ([o (stx-car cs)] [cs (stx-cdr cs)])
+    ;; we're guaranteed to hit non-"non-float" operands before
+    ;; we hit the end of the list. otherwise we wouldn't be doing
+    ;; float-complex optimizations
+    (define c1 (stx-car cs))
+    (define o-nf (as-non-float o))
+    (define c1-nf (as-non-float c1))
+    (if (and o-nf c1-nf)
+        ;; can't convert those to floats just yet, or may change
+        ;; the result
+        (let ([new-o (quasisyntax/loc this-syntax
+                       (#,+ #,o-nf #,c1-nf))])
+          (loop (mark-as-non-float new-o new-o)
+                (stx-cdr cs)))
+        ;; we've hit floats, can start coercing
+        (n-ary->binary this-syntax unsafe (cons o cs)))))
 
 ;; a+bi / c+di, names for real and imag parts of result -> one let-values binding clause
 (define (unbox-one-complex-/ a b c d res-real res-imag)
@@ -158,7 +185,8 @@
     #:with (bindings ...)
       #`(cs.bindings ... ...
          #,@(let ()
-               (define (fl-sum cs) (n-ary->binary this-syntax #'unsafe-fl+ cs))
+              (define (fl-sum cs)
+                (n-ary->binary/non-floats #'+ #'unsafe-fl+ this-syntax cs))
                (list
                 #`((real-binding) #,(fl-sum #'(cs.real-binding ...)))
                 #`((imag-binding) #,(fl-sum #'(cs.imag-binding ...)))))))
@@ -174,7 +202,8 @@
     #:with (bindings ...)
       #`(cs.bindings ... ...
          #,@(let ()
-              (define (fl-subtract cs) (n-ary->binary this-syntax #'unsafe-fl- cs))
+              (define (fl-subtract cs)
+                (n-ary->binary/non-floats #'- #'unsafe-fl- this-syntax cs))
               (list
                #`((real-binding) #,(fl-subtract #'(cs.real-binding ...)))
                #`((imag-binding) #,(fl-subtract #'(cs.imag-binding ...)))))))
@@ -353,7 +382,14 @@
 
   (pattern e:number-expr
     #:with e* (generate-temporary)
-    #:with (real-binding imag-binding*) (binding-names)
+    #:with (real-binding* imag-binding*) (binding-names)
+    #:with real-binding (if (and (subtypeof? #'e -Real)
+                                 (not (subtypeof? #'e -Flonum)))
+                            ;; values that were originally non-floats (e.g.
+                            ;; rationals or single floats) may need to be
+                            ;; handled specially
+                            (mark-as-non-float #'real-binding* #'e*)
+                            #'real-binding*)
     #:with imag-binding (if (subtypeof? #'e -Real)
                             ;; values that were originally reals may need to be
                             ;; handled specially

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

@@ -82,7 +82,7 @@
     (bad-opt (* (expt 10 500) (expt 10 -500) 1.0+1.0i))
 
     ;; Addition of multiple args should keep exact semantics for exact args
-    (bad-opt (+ (expt 10 501) (expt -10 501) 1.0+1.0i))
+    (good-opt (+ (expt 10 501) (expt -10 501) 1.0+1.0i))
 
     ;; Magnitude should not overflow unless necessary
     (bad-opt (magnitude 3.0e300+4.0e300i))

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

@@ -1,6 +1,7 @@
 #;#;
 #<<END
 TR missed opt: float-complex-float.rkt 11:3 (make-polar 4.8063810141303426e-57 -1.9082319f0) -- non-complex value in complex arithmetic
+TR missed opt: float-complex-float.rkt 12:63 (make-rectangular 1.4291365847030308e-64 -0.76987815f0) -- generic comparison -- caused by: 12:104 -0.76987815f0
 TR opt: float-complex-float.rkt 10:0 (/ 2.3454025f0 (flmin (real->double-flonum 1.797693134862315e+308) (real->double-flonum -1.2848677f+32)) (make-rectangular +nan.0 0.0)) -- unboxed binary float complex
 TR opt: float-complex-float.rkt 10:105 (make-rectangular +nan.0 0.0) -- make-rectangular elimination
 TR opt: float-complex-float.rkt 10:15 (flmin (real->double-flonum 1.797693134862315e+308) (real->double-flonum -1.2848677f+32)) -- binary float
@@ -10,6 +11,10 @@ TR opt: float-complex-float.rkt 10:3 2.3454025f0 -- non float complex in complex
 TR opt: float-complex-float.rkt 11:0 (+ (make-polar 4.8063810141303426e-57 -1.9082319f0) -0.8414709848078965) -- unboxed binary float complex
 TR opt: float-complex-float.rkt 11:3 (make-polar 4.8063810141303426e-57 -1.9082319f0) -- non float complex in complex ops
 TR opt: float-complex-float.rkt 11:52 -0.8414709848078965 -- float in complex ops
+TR opt: float-complex-float.rkt 12:0 (+ 1.5245886f+12 (max (exact-round 2) (exact-round 5/4)) (tanh (make-rectangular 1.4291365847030308e-64 -0.76987815f0))) -- unboxed binary float complex
+TR opt: float-complex-float.rkt 12:17 (max (exact-round 2) (exact-round 5/4)) -- non float complex in complex ops
+TR opt: float-complex-float.rkt 12:3 1.5245886f+12 -- non float complex in complex ops
+TR opt: float-complex-float.rkt 12:57 (tanh (make-rectangular 1.4291365847030308e-64 -0.76987815f0)) -- unbox float-complex
 TR opt: float-complex-float.rkt 4:0 (+ 1.0+2.0i 2.0 3.0+6.0i) -- unboxed binary float complex
 TR opt: float-complex-float.rkt 4:12 2.0 -- float in complex ops
 TR opt: float-complex-float.rkt 4:16 3.0+6.0i -- unboxed literal
@@ -43,6 +48,7 @@ END
 -inf.0-1.0688403264087485i
 +nan.0+0.0i
 -0.8414709848078965-4.5353337789114595e-57i
+5.381428268223429e-17-0.9694319337396835i
 
 END
 #lang typed/scheme
@@ -59,3 +65,4 @@ END
 (* -0.9263371220283309 3/2 (make-rectangular +inf.f 0.7692234292042541))
 (/ 2.3454025f0 (flmin (real->double-flonum 1.797693134862315e+308) (real->double-flonum -1.2848677f+32)) (make-rectangular +nan.0 0.0))
 (+ (make-polar 4.8063810141303426e-57 -1.9082319f0) -0.8414709848078965)
+(+ 1.5245886f+12 (max (exact-round 2) (exact-round 5/4)) (tanh (make-rectangular 1.4291365847030308e-64 -0.76987815f0)))