From 748e9e47ad65c31d653907623b17689b47c76269 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 13 Jul 2010 17:06:07 -0400 Subject: [PATCH] The imaginary parts of inexact reals are ignored when doing complex addition or subtraction. --- .../generic/inexact-complex-float-div.rkt | 7 + .../generic/inexact-complex-float-mul.rkt | 7 + .../generic/inexact-complex-float-small.rkt | 7 + .../inexact-complex-float-div.rkt | 135 ++++++++++++++++++ .../inexact-complex-float-mul.rkt | 91 ++++++++++++ .../inexact-complex-float-small.rkt | 32 +++++ .../hand-optimized/inexact-complex-float.rkt | 71 +++++---- collects/typed-scheme/optimizer/float.rkt | 2 +- .../optimizer/inexact-complex.rkt | 122 ++++++++++------ 9 files changed, 392 insertions(+), 82 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-div.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-mul.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-small.rkt create mode 100644 collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-div.rkt create mode 100644 collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-mul.rkt create mode 100644 collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-small.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-div.rkt b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-div.rkt new file mode 100644 index 0000000000..f38dc8213e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-div.rkt @@ -0,0 +1,7 @@ +#lang typed/scheme #:optimize +(require racket/unsafe/ops) +(/ 1.0 2.0+4.0i) +(/ 1.0+2.0i 2.0) +(/ 1.0 2.0+4.0i 3.0+6.0i) +(/ 1.0+2.0i 2.0 3.0+6.0i) +(/ 1.0+2.0i 2.0+4.0i 3.0) diff --git a/collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-mul.rkt b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-mul.rkt new file mode 100644 index 0000000000..d445db270b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-mul.rkt @@ -0,0 +1,7 @@ +#lang typed/scheme #:optimize +(require racket/unsafe/ops) +(* 1.0 2.0+4.0i) +(* 1.0+2.0i 2.0) +(* 1.0 2.0+4.0i 3.0+6.0i) +(* 1.0+2.0i 2.0 3.0+6.0i) +(* 1.0+2.0i 2.0+4.0i 3.0) diff --git a/collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-small.rkt b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-small.rkt new file mode 100644 index 0000000000..919c985750 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-float-small.rkt @@ -0,0 +1,7 @@ +#lang typed/scheme #:optimize +(require racket/unsafe/ops) +(+ 1.0+2.0i 3.0) +(+ 1.0 2.0+4.0i) +(- 1.0+2.0i 3.0) +(- 1.0 2.0+4.0i) +(+ 1.0+2.0i (+ 1.0 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-div.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-div.rkt new file mode 100644 index 0000000000..3d01100706 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-div.rkt @@ -0,0 +1,135 @@ +#lang typed/scheme #:optimize +(require racket/unsafe/ops) +(let* ((unboxed-gensym-1 1.0) + (unboxed-gensym-2 2.0+4.0i) + (unboxed-gensym-3 (unsafe-flreal-part unboxed-gensym-2)) + (unboxed-gensym-4 (unsafe-flimag-part unboxed-gensym-2)) + (unboxed-gensym-7 (unsafe-fl+ (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-3) + (unsafe-fl* unboxed-gensym-4 + unboxed-gensym-4))) + (unboxed-gensym-5 (unsafe-fl/ (unsafe-fl+ (unsafe-fl* unboxed-gensym-1 + unboxed-gensym-3) + (unsafe-fl* 0.0 unboxed-gensym-4)) + unboxed-gensym-7)) + (unboxed-gensym-6 (unsafe-fl/ (unsafe-fl- (unsafe-fl* 0.0 unboxed-gensym-3) + (unsafe-fl* unboxed-gensym-1 + unboxed-gensym-4)) + unboxed-gensym-7))) + (unsafe-make-flrectangular unboxed-gensym-5 unboxed-gensym-6)) +(let* ((unboxed-gensym-1 1.0+2.0i) + (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) + (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) + (unboxed-gensym-4 2.0) + (unboxed-gensym-7 (unsafe-fl+ (unsafe-fl* unboxed-gensym-4 + unboxed-gensym-4) + (unsafe-fl* 0.0 0.0))) + (unboxed-gensym-5 (unsafe-fl/ (unsafe-fl+ (unsafe-fl* unboxed-gensym-2 + unboxed-gensym-4) + (unsafe-fl* unboxed-gensym-3 0.0)) + unboxed-gensym-7)) + (unboxed-gensym-6 (unsafe-fl/ (unsafe-fl- (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-4) + (unsafe-fl* unboxed-gensym-2 0.0)) + unboxed-gensym-7))) + (unsafe-make-flrectangular unboxed-gensym-5 unboxed-gensym-6)) +(let* ((unboxed-gensym-1 1.0) + (unboxed-gensym-2 2.0+4.0i) + (unboxed-gensym-3 (unsafe-flreal-part unboxed-gensym-2)) + (unboxed-gensym-4 (unsafe-flimag-part unboxed-gensym-2)) + (unboxed-gensym-5 3.0+6.0i) + (unboxed-gensym-6 (unsafe-flreal-part unboxed-gensym-5)) + (unboxed-gensym-7 (unsafe-flimag-part unboxed-gensym-5)) + (unboxed-gensym-10 (unsafe-fl+ (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-3) + (unsafe-fl* unboxed-gensym-4 + unboxed-gensym-4))) + (unboxed-gensym-11 (unsafe-fl+ (unsafe-fl* unboxed-gensym-6 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-7 + unboxed-gensym-7))) + (unboxed-gensym-12 (unsafe-fl/ (unsafe-fl+ (unsafe-fl* unboxed-gensym-1 + unboxed-gensym-3) + (unsafe-fl* 0.0 unboxed-gensym-4)) + unboxed-gensym-10)) + (unboxed-gensym-13 (unsafe-fl/ (unsafe-fl- (unsafe-fl* 0.0 unboxed-gensym-3) + (unsafe-fl* unboxed-gensym-1 + unboxed-gensym-4)) + unboxed-gensym-10)) + (unboxed-gensym-8 (unsafe-fl/ (unsafe-fl+ (unsafe-fl* unboxed-gensym-12 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-13 + unboxed-gensym-7)) + unboxed-gensym-11)) + (unboxed-gensym-9 (unsafe-fl/ (unsafe-fl- (unsafe-fl* unboxed-gensym-13 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-12 + unboxed-gensym-7)) + unboxed-gensym-11))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) +(let* ((unboxed-gensym-1 1.0+2.0i) + (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) + (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) + (unboxed-gensym-4 2.0) + (unboxed-gensym-5 3.0+6.0i) + (unboxed-gensym-6 (unsafe-flreal-part unboxed-gensym-5)) + (unboxed-gensym-7 (unsafe-flimag-part unboxed-gensym-5)) + (unboxed-gensym-10 (unsafe-fl+ (unsafe-fl* unboxed-gensym-4 + unboxed-gensym-4) + (unsafe-fl* 0.0 0.0))) + (unboxed-gensym-11 (unsafe-fl+ (unsafe-fl* unboxed-gensym-6 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-7 + unboxed-gensym-7))) + (unboxed-gensym-12 (unsafe-fl/ (unsafe-fl+ (unsafe-fl* unboxed-gensym-2 + unboxed-gensym-4) + (unsafe-fl* unboxed-gensym-3 0.0)) + unboxed-gensym-10)) + (unboxed-gensym-13 (unsafe-fl/ (unsafe-fl- (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-4) + (unsafe-fl* unboxed-gensym-2 0.0)) + unboxed-gensym-10)) + (unboxed-gensym-8 (unsafe-fl/ (unsafe-fl+ (unsafe-fl* unboxed-gensym-12 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-13 + unboxed-gensym-7)) + unboxed-gensym-11)) + (unboxed-gensym-9 (unsafe-fl/ (unsafe-fl- (unsafe-fl* unboxed-gensym-13 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-12 + unboxed-gensym-7)) + unboxed-gensym-11))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) +(let* ((unboxed-gensym-1 1.0+2.0i) + (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) + (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) + (unboxed-gensym-4 2.0+4.0i) + (unboxed-gensym-5 (unsafe-flreal-part unboxed-gensym-4)) + (unboxed-gensym-6 (unsafe-flimag-part unboxed-gensym-4)) + (unboxed-gensym-7 3.0) + (unboxed-gensym-10 (unsafe-fl+ (unsafe-fl* unboxed-gensym-5 + unboxed-gensym-5) + (unsafe-fl* unboxed-gensym-6 + unboxed-gensym-6))) + (unboxed-gensym-11 (unsafe-fl+ (unsafe-fl* unboxed-gensym-7 + unboxed-gensym-7) + (unsafe-fl* 0.0 0.0))) + (unboxed-gensym-12 (unsafe-fl/ (unsafe-fl+ (unsafe-fl* unboxed-gensym-2 + unboxed-gensym-5) + (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-6)) + unboxed-gensym-10)) + (unboxed-gensym-13 (unsafe-fl/ (unsafe-fl- (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-5) + (unsafe-fl* unboxed-gensym-2 + unboxed-gensym-6)) + unboxed-gensym-10)) + (unboxed-gensym-8 (unsafe-fl/ (unsafe-fl+ (unsafe-fl* unboxed-gensym-12 + unboxed-gensym-7) + (unsafe-fl* unboxed-gensym-13 0.0)) + unboxed-gensym-11)) + (unboxed-gensym-9 (unsafe-fl/ (unsafe-fl- (unsafe-fl* unboxed-gensym-13 + unboxed-gensym-7) + (unsafe-fl* unboxed-gensym-12 0.0)) + unboxed-gensym-11))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-mul.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-mul.rkt new file mode 100644 index 0000000000..d7b12bcdba --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-mul.rkt @@ -0,0 +1,91 @@ +#lang typed/scheme #:optimize +(require racket/unsafe/ops) +(let* ((unboxed-gensym-1 1.0) + (unboxed-gensym-2 2.0+4.0i) + (unboxed-gensym-3 (unsafe-flreal-part unboxed-gensym-2)) + (unboxed-gensym-4 (unsafe-flimag-part unboxed-gensym-2)) + (unboxed-gensym-5 (unsafe-fl- (unsafe-fl* unboxed-gensym-1 + unboxed-gensym-3) + (unsafe-fl* 0.0 unboxed-gensym-4))) + (unboxed-gensym-6 (unsafe-fl+ (unsafe-fl* 0.0 unboxed-gensym-3) + (unsafe-fl* unboxed-gensym-1 + unboxed-gensym-4)))) + (unsafe-make-flrectangular unboxed-gensym-5 unboxed-gensym-6)) +(let* ((unboxed-gensym-1 1.0+2.0i) + (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) + (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) + (unboxed-gensym-4 2.0) + (unboxed-gensym-5 (unsafe-fl- (unsafe-fl* unboxed-gensym-2 + unboxed-gensym-4) + (unsafe-fl* unboxed-gensym-3 0.0))) + (unboxed-gensym-6 (unsafe-fl+ (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-4) + (unsafe-fl* unboxed-gensym-2 + 0.0)))) + (unsafe-make-flrectangular unboxed-gensym-5 unboxed-gensym-6)) +(let* ((unboxed-gensym-1 1.0) + (unboxed-gensym-2 2.0+4.0i) + (unboxed-gensym-3 (unsafe-flreal-part unboxed-gensym-2)) + (unboxed-gensym-4 (unsafe-flimag-part unboxed-gensym-2)) + (unboxed-gensym-5 3.0+6.0i) + (unboxed-gensym-6 (unsafe-flreal-part unboxed-gensym-5)) + (unboxed-gensym-7 (unsafe-flimag-part unboxed-gensym-5)) + (unboxed-gensym-10 (unsafe-fl- (unsafe-fl* unboxed-gensym-1 + unboxed-gensym-3) + (unsafe-fl* 0.0 unboxed-gensym-4))) + (unboxed-gensym-11 (unsafe-fl+ (unsafe-fl* 0.0 unboxed-gensym-3) + (unsafe-fl* unboxed-gensym-1 + unboxed-gensym-4))) + (unboxed-gensym-8 (unsafe-fl- (unsafe-fl* unboxed-gensym-10 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-11 + unboxed-gensym-7))) + (unboxed-gensym-9 (unsafe-fl+ (unsafe-fl* unboxed-gensym-11 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-10 + unboxed-gensym-7)))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) +(let* ((unboxed-gensym-1 1.0+2.0i) + (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) + (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) + (unboxed-gensym-4 2.0) + (unboxed-gensym-5 3.0+6.0i) + (unboxed-gensym-6 (unsafe-flreal-part unboxed-gensym-5)) + (unboxed-gensym-7 (unsafe-flimag-part unboxed-gensym-5)) + (unboxed-gensym-10 (unsafe-fl- (unsafe-fl* unboxed-gensym-2 + unboxed-gensym-4) + (unsafe-fl* unboxed-gensym-3 0.0))) + (unboxed-gensym-11 (unsafe-fl+ (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-4) + (unsafe-fl* unboxed-gensym-2 0.0))) + (unboxed-gensym-8 (unsafe-fl- (unsafe-fl* unboxed-gensym-10 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-11 + unboxed-gensym-7))) + (unboxed-gensym-9 (unsafe-fl+ (unsafe-fl* unboxed-gensym-11 + unboxed-gensym-6) + (unsafe-fl* unboxed-gensym-10 + unboxed-gensym-7)))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) +(let* ((unboxed-gensym-1 1.0+2.0i) + (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) + (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) + (unboxed-gensym-4 2.0+4.0i) + (unboxed-gensym-5 (unsafe-flreal-part unboxed-gensym-4)) + (unboxed-gensym-6 (unsafe-flimag-part unboxed-gensym-4)) + (unboxed-gensym-7 3.0) + (unboxed-gensym-10 (unsafe-fl- (unsafe-fl* unboxed-gensym-2 + unboxed-gensym-5) + (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-6))) + (unboxed-gensym-11 (unsafe-fl+ (unsafe-fl* unboxed-gensym-3 + unboxed-gensym-5) + (unsafe-fl* unboxed-gensym-2 + unboxed-gensym-6))) + (unboxed-gensym-8 (unsafe-fl- (unsafe-fl* unboxed-gensym-10 + unboxed-gensym-7) + (unsafe-fl* unboxed-gensym-11 0.0))) + (unboxed-gensym-9 (unsafe-fl+ (unsafe-fl* unboxed-gensym-11 + unboxed-gensym-7) + (unsafe-fl* unboxed-gensym-10 0.0)))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-small.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-small.rkt new file mode 100644 index 0000000000..4c326336f4 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float-small.rkt @@ -0,0 +1,32 @@ +#lang typed/scheme #:optimize +(require racket/unsafe/ops) +(let* ((unboxed-gensym-1 1.0+2.0i) + (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) + (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) + (unboxed-gensym-4 3.0) + (unboxed-gensym-5 (unsafe-fl+ unboxed-gensym-2 unboxed-gensym-4)) + (unboxed-gensym-6 unboxed-gensym-3)) + (unsafe-make-flrectangular unboxed-gensym-5 unboxed-gensym-6)) +(let* ((unboxed-gensym-1 1.0) + (unboxed-gensym-2 2.0+4.0i) + (unboxed-gensym-3 (unsafe-flreal-part unboxed-gensym-2)) + (unboxed-gensym-4 (unsafe-flimag-part unboxed-gensym-2)) + (unboxed-gensym-5 (unsafe-fl+ unboxed-gensym-1 unboxed-gensym-3)) + (unboxed-gensym-6 unboxed-gensym-4)) + (unsafe-make-flrectangular unboxed-gensym-5 unboxed-gensym-6)) +(let* ((unboxed-gensym-1 1.0+2.0i) + (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) + (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) + (unboxed-gensym-4 3.0) + (unboxed-gensym-5 (unsafe-fl- unboxed-gensym-2 unboxed-gensym-4)) + (unboxed-gensym-6 unboxed-gensym-3)) + (unsafe-make-flrectangular unboxed-gensym-5 unboxed-gensym-6)) +(let* ((unboxed-gensym-1 1.0) + (unboxed-gensym-2 2.0+4.0i) + (unboxed-gensym-3 (unsafe-flreal-part unboxed-gensym-2)) + (unboxed-gensym-4 (unsafe-flimag-part unboxed-gensym-2)) + (unboxed-gensym-5 (unsafe-fl- unboxed-gensym-1 unboxed-gensym-3)) + (unboxed-gensym-6 (unsafe-fl- 0.0 unboxed-gensym-4))) + (unsafe-make-flrectangular unboxed-gensym-5 unboxed-gensym-6)) + +(+ 1.0+2.0i (+ 1.0 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float.rkt b/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float.rkt index 00f73a0a2f..9782532b59 100644 --- a/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float.rkt +++ b/collects/tests/typed-scheme/optimizer/hand-optimized/inexact-complex-float.rkt @@ -4,47 +4,42 @@ (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) (unboxed-gensym-4 2.0) - (unboxed-gensym-5 0.0) - (unboxed-gensym-6 3.0+6.0i) - (unboxed-gensym-7 (unsafe-flreal-part unboxed-gensym-6)) - (unboxed-gensym-8 (unsafe-flimag-part unboxed-gensym-6)) - (unboxed-gensym-9 (unsafe-fl+ (unsafe-fl+ unboxed-gensym-2 + (unboxed-gensym-5 3.0+6.0i) + (unboxed-gensym-6 (unsafe-flreal-part unboxed-gensym-5)) + (unboxed-gensym-7 (unsafe-flimag-part unboxed-gensym-5)) + (unboxed-gensym-8 (unsafe-fl+ (unsafe-fl+ unboxed-gensym-2 unboxed-gensym-4) - unboxed-gensym-7)) - (unboxed-gensym-10 (unsafe-fl+ (unsafe-fl+ unboxed-gensym-3 - unboxed-gensym-5) - unboxed-gensym-8))) - (unsafe-make-flrectangular unboxed-gensym-9 unboxed-gensym-10)) + unboxed-gensym-6)) + (unboxed-gensym-9 (unsafe-fl+ unboxed-gensym-3 + unboxed-gensym-7))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) (let* ((unboxed-gensym-1 1.0) - (unboxed-gensym-2 0.0) - (unboxed-gensym-3 2.0+4.0i) - (unboxed-gensym-4 (unsafe-flreal-part unboxed-gensym-3)) - (unboxed-gensym-5 (unsafe-flimag-part unboxed-gensym-3)) - (unboxed-gensym-6 3.0+6.0i) - (unboxed-gensym-7 (unsafe-flreal-part unboxed-gensym-6)) - (unboxed-gensym-8 (unsafe-flimag-part unboxed-gensym-6)) - (unboxed-gensym-9 (unsafe-fl- (unsafe-fl- unboxed-gensym-1 + (unboxed-gensym-2 2.0+4.0i) + (unboxed-gensym-3 (unsafe-flreal-part unboxed-gensym-2)) + (unboxed-gensym-4 (unsafe-flimag-part unboxed-gensym-2)) + (unboxed-gensym-5 3.0+6.0i) + (unboxed-gensym-6 (unsafe-flreal-part unboxed-gensym-5)) + (unboxed-gensym-7 (unsafe-flimag-part unboxed-gensym-5)) + (unboxed-gensym-8 (unsafe-fl- (unsafe-fl- unboxed-gensym-1 + unboxed-gensym-3) + unboxed-gensym-6)) + (unboxed-gensym-9 (unsafe-fl- (unsafe-fl- 0.0 unboxed-gensym-4) - unboxed-gensym-7)) - (unboxed-gensym-10 (unsafe-fl- (unsafe-fl- unboxed-gensym-2 - unboxed-gensym-5) - unboxed-gensym-8))) - (unsafe-make-flrectangular unboxed-gensym-9 unboxed-gensym-10)) + unboxed-gensym-7))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) (let* ((unboxed-gensym-1 1.0+2.0i) (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) (unboxed-gensym-4 2.0) - (unboxed-gensym-5 0.0) - (unboxed-gensym-6 3.0+6.0i) - (unboxed-gensym-7 (unsafe-flreal-part unboxed-gensym-6)) - (unboxed-gensym-8 (unsafe-flimag-part unboxed-gensym-6)) - (unboxed-gensym-9 (unsafe-fl- (unsafe-fl- unboxed-gensym-2 + (unboxed-gensym-5 3.0+6.0i) + (unboxed-gensym-6 (unsafe-flreal-part unboxed-gensym-5)) + (unboxed-gensym-7 (unsafe-flimag-part unboxed-gensym-5)) + (unboxed-gensym-8 (unsafe-fl- (unsafe-fl- unboxed-gensym-2 unboxed-gensym-4) - unboxed-gensym-7)) - (unboxed-gensym-10 (unsafe-fl- (unsafe-fl- unboxed-gensym-3 - unboxed-gensym-5) - unboxed-gensym-8))) - (unsafe-make-flrectangular unboxed-gensym-9 unboxed-gensym-10)) + unboxed-gensym-6)) + (unboxed-gensym-9 (unsafe-fl- unboxed-gensym-3 + unboxed-gensym-7))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) (let* ((unboxed-gensym-1 1.0+2.0i) (unboxed-gensym-2 (unsafe-flreal-part unboxed-gensym-1)) (unboxed-gensym-3 (unsafe-flimag-part unboxed-gensym-1)) @@ -52,11 +47,9 @@ (unboxed-gensym-5 (unsafe-flreal-part unboxed-gensym-4)) (unboxed-gensym-6 (unsafe-flimag-part unboxed-gensym-4)) (unboxed-gensym-7 3.0) - (unboxed-gensym-8 0.0) - (unboxed-gensym-9 (unsafe-fl- (unsafe-fl- unboxed-gensym-2 + (unboxed-gensym-8 (unsafe-fl- (unsafe-fl- unboxed-gensym-2 unboxed-gensym-5) unboxed-gensym-7)) - (unboxed-gensym-10 (unsafe-fl- (unsafe-fl- unboxed-gensym-3 - unboxed-gensym-6) - unboxed-gensym-8))) - (unsafe-make-flrectangular unboxed-gensym-9 unboxed-gensym-10)) + (unboxed-gensym-9 (unsafe-fl- unboxed-gensym-3 + unboxed-gensym-6))) + (unsafe-make-flrectangular unboxed-gensym-8 unboxed-gensym-9)) diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt index 15675b37ae..2c9f02cb5c 100644 --- a/collects/typed-scheme/optimizer/float.rkt +++ b/collects/typed-scheme/optimizer/float.rkt @@ -7,7 +7,7 @@ (types abbrev type-table utils subtype) (optimizer utils fixnum)) -(provide float-opt-expr float-op mk-float-tbl) +(provide float-opt-expr) (define (mk-float-tbl generic) diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt index 3d65c7d823..53f6848bc6 100644 --- a/collects/typed-scheme/optimizer/inexact-complex.rkt +++ b/collects/typed-scheme/optimizer/inexact-complex.rkt @@ -4,7 +4,7 @@ "../utils/utils.rkt" (for-template scheme/base scheme/math scheme/flonum scheme/unsafe/ops) (types abbrev type-table utils subtype) - (optimizer utils float)) + (optimizer utils)) (provide inexact-complex-opt-expr) @@ -14,7 +14,7 @@ ;; we keep the real and imaginary parts unboxed as long as we stay within ;; complex operations (define-syntax-class unboxed-inexact-complex-opt-expr - (pattern (#%plain-app (~and (~var op (float-op binary-inexact-complex-ops)) (~or (~literal +) (~literal -))) + (pattern (#%plain-app (~and op (~literal +)) c1:unboxed-inexact-complex-opt-expr c2:unboxed-inexact-complex-opt-expr cs:unboxed-inexact-complex-opt-expr ...) @@ -25,10 +25,43 @@ #`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...)) (list #`(real-part #,(for/fold ((o #'c1.real-part)) ((e (syntax->list #'(c2.real-part cs.real-part ...)))) - #`(op.unsafe #,o #,e))) - #`(imag-part #,(for/fold ((o #'c1.imag-part)) - ((e (syntax->list #'(c2.imag-part cs.imag-part ...)))) - #`(op.unsafe #,o #,e)))))))) + #`(unsafe-fl+ #,o #,e))) + ;; we can skip the imaginary parts of reals (#f) + #`(imag-part + #,(let ((l (filter syntax->datum + (syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...))))) + (case (length l) + ((0) #'0.0) + ((1) (car l)) + (else + (for/fold ((o (car l))) + ((e (cdr l))) + #`(unsafe-fl+ #,o #,e))))))))))) + (pattern (#%plain-app (~and op (~literal -)) + c1:unboxed-inexact-complex-opt-expr + c2:unboxed-inexact-complex-opt-expr + cs:unboxed-inexact-complex-opt-expr ...) + #:with real-part (unboxed-gensym) + #:with imag-part (unboxed-gensym) + #:with (bindings ...) + (begin (log-optimization "unboxed binary inexact complex" #'op) + #`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...)) + (list #`(real-part #,(for/fold ((o #'c1.real-part)) + ((e (syntax->list #'(c2.real-part cs.real-part ...)))) + #`(unsafe-fl- #,o #,e))) + ;; unlike addition, we simply can't skip imaginary parts of reals + #`(imag-part + #,(let* ((l1 (map (lambda (x) (if (syntax->datum x) x #'0.0)) + (syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...)))) + ;; but we can skip all but the first 0 + (l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0))) + (cdr l1)))) + (case (length l2) + ((0) (car l1)) + (else + (for/fold ((o (car l1))) + ((e l2)) + #`(unsafe-fl- #,o #,e))))))))))) (pattern (#%plain-app (~and op (~literal *)) c1:unboxed-inexact-complex-opt-expr c2:unboxed-inexact-complex-opt-expr @@ -40,48 +73,55 @@ #`(c1.bindings ... c2.bindings ... cs.bindings ... ... ;; we want to bind the intermediate results to reuse them ;; the final results are bound to real-part and imag-part - #,@(let loop ([o1 #'c1.real-part] - [o2 #'c1.imag-part] - [e1 (syntax->list #'(c2.real-part cs.real-part ...))] - [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))] - [rs (append (map (lambda (x) (unboxed-gensym)) - (syntax->list #'(cs.real-part ...))) - (list #'real-part))] - [is (append (map (lambda (x) (unboxed-gensym)) - (syntax->list #'(cs.imag-part ...))) - (list #'imag-part))] - [res '()]) - (if (null? e1) - (reverse res) - (loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is) - ;; complex multiplication, imag part, then real part (reverse) - (list* #`(#,(car is) - (unsafe-fl+ (unsafe-fl* #,o2 #,(car e1)) - (unsafe-fl* #,o1 #,(car e2)))) - #`(#,(car rs) - (unsafe-fl- (unsafe-fl* #,o1 #,(car e1)) - (unsafe-fl* #,o2 #,(car e2)))) - res))))))) + ;; we currently don't skip imaginary parts of reals + #,@(let ((l (map (lambda (x) (if (syntax->datum x) x #'0.0)) + (syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...))))) + (let loop ([o1 #'c1.real-part] + [o2 (car l)] + [e1 (syntax->list #'(c2.real-part cs.real-part ...))] + [e2 (cdr l)] + [rs (append (map (lambda (x) (unboxed-gensym)) + (syntax->list #'(cs.real-part ...))) + (list #'real-part))] + [is (append (map (lambda (x) (unboxed-gensym)) + (syntax->list #'(cs.imag-part ...))) + (list #'imag-part))] + [res '()]) + (if (null? e1) + (reverse res) + (loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is) + ;; complex multiplication, imag part, then real part (reverse) + (list* #`(#,(car is) + (unsafe-fl+ (unsafe-fl* #,o2 #,(car e1)) + (unsafe-fl* #,o1 #,(car e2)))) + #`(#,(car rs) + (unsafe-fl- (unsafe-fl* #,o1 #,(car e1)) + (unsafe-fl* #,o2 #,(car e2)))) + res)))))))) (pattern (#%plain-app (~and op (~literal /)) c1:unboxed-inexact-complex-opt-expr c2:unboxed-inexact-complex-opt-expr cs:unboxed-inexact-complex-opt-expr ...) #:with real-part (unboxed-gensym) #:with imag-part (unboxed-gensym) + #:with reals (syntax->list #'(c1.real-part c2.real-part cs.real-part ...)) + ;; we currently don't skip imaginary parts of reals + #:with imags (map (lambda (x) (if (syntax->datum x) x #'0.0)) + (syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...))) #:with (denominators ...) (for/list - ([e1 (syntax->list #'(c2.real-part cs.real-part ...))] - [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]) + ([e1 (cdr (syntax->list #'reals))] + [e2 (cdr (syntax->list #'imags))]) #`(#,(unboxed-gensym) (unsafe-fl+ (unsafe-fl* #,e1 #,e1) (unsafe-fl* #,e2 #,e2)))) #:with (bindings ...) (begin (log-optimization "unboxed binary inexact complex" #'op) #`(c1.bindings ... c2.bindings ... cs.bindings ... ... denominators ... ;; we want to bind the intermediate results to reuse them ;; the final results are bound to real-part and imag-part - #,@(let loop ([o1 #'c1.real-part] - [o2 #'c1.imag-part] - [e1 (syntax->list #'(c2.real-part cs.real-part ...))] - [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))] + #,@(let loop ([o1 (car (syntax->list #'reals))] + [o2 (car (syntax->list #'imags))] + [e1 (cdr (syntax->list #'reals))] + [e2 (cdr (syntax->list #'imags))] [d (map (lambda (x) (car (syntax-e x))) (syntax->list #'(denominators ...)))] [rs (append (map (lambda (x) (unboxed-gensym)) @@ -115,10 +155,9 @@ ;; special handling of inexact reals #:when (subtypeof? #'e -Flonum) #:with real-part (unboxed-gensym) - #:with imag-part (unboxed-gensym) + #:with imag-part #f #:with (bindings ...) - #`((real-part #,((optimize) #'e)) - (imag-part 0.0))) + #`((real-part #,((optimize) #'e)))) (pattern e:expr ;; can't work on inexact reals, which are a subtype of inexact ;; complexes, so this has to be equality @@ -134,8 +173,9 @@ (define-syntax-class inexact-complex-unary-op (pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part) (pattern (~or (~literal imag-part) (~literal flimag-part)) #:with unsafe #'unsafe-flimag-part)) -(define binary-inexact-complex-ops - (mk-float-tbl (list #'+ #'- #'* #'/))) + +(define-syntax-class inexact-complex-binary-op + (pattern (~or (~literal +) (~literal -) (~literal *) (~literal /) (~literal conjugate)))) (define-syntax-class inexact-complex-expr (pattern e:expr @@ -147,9 +187,7 @@ #:with opt (begin (log-optimization "unary inexact complex" #'op) #'(op.unsafe n.opt))) - (pattern (~and exp (#%plain-app (~or (~var op (float-op binary-inexact-complex-ops)) - (~and op (~literal conjugate))) - e:inexact-complex-expr ...)) + (pattern (~and exp (#%plain-app op:inexact-complex-binary-op e:inexact-complex-expr ...)) #:when (isoftype? #'exp -InexactComplex) #:with exp*:unboxed-inexact-complex-opt-expr #'exp #:with opt