From b101d396a34f4559b6bb175558221b4159bd4c53 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 6 Nov 2015 16:05:08 -0600 Subject: [PATCH] Avoid premature float conversions. Found using random testing. --- .../typed-racket/optimizer/float-complex.rkt | 42 +++++++++++++++++-- typed-racket-test/optimizer/known-bugs.rkt | 2 +- .../optimizer/tests/float-complex-float.rkt | 7 ++++ 3 files changed, 47 insertions(+), 4 deletions(-) diff --git a/typed-racket-lib/typed-racket/optimizer/float-complex.rkt b/typed-racket-lib/typed-racket/optimizer/float-complex.rkt index d958d3dc..e936784c 100644 --- a/typed-racket-lib/typed-racket/optimizer/float-complex.rkt +++ b/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 diff --git a/typed-racket-test/optimizer/known-bugs.rkt b/typed-racket-test/optimizer/known-bugs.rkt index 0eb75b1b..83794ed5 100644 --- a/typed-racket-test/optimizer/known-bugs.rkt +++ b/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)) diff --git a/typed-racket-test/optimizer/tests/float-complex-float.rkt b/typed-racket-test/optimizer/tests/float-complex-float.rkt index 7adb01d9..3a8cd525 100644 --- a/typed-racket-test/optimizer/tests/float-complex-float.rkt +++ b/typed-racket-test/optimizer/tests/float-complex-float.rkt @@ -1,6 +1,7 @@ #;#; #<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)))