From 9fea49db55500f9baff0aaffdc155e7cdbf8425b Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 16 Jul 2010 19:46:33 -0400
Subject: [PATCH 01/20] Added optimization for zero?.

original commit: 47195410cbbe7d19ac6e33175fd57bfce6e6c4b3
---
 collects/tests/typed-scheme/optimizer/generic/zero.rkt | 4 ++++
 collects/typed-scheme/optimizer/fixnum.rkt             | 7 ++++++-
 collects/typed-scheme/optimizer/float.rkt              | 7 ++++++-
 3 files changed, 16 insertions(+), 2 deletions(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/zero.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/zero.rkt b/collects/tests/typed-scheme/optimizer/generic/zero.rkt
new file mode 100644
index 00000000..dc78943c
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/zero.rkt
@@ -0,0 +1,4 @@
+#lang typed/scheme #:optimize
+(require racket/unsafe/ops)
+(zero? 1)
+(zero? (sqrt 3.0))
diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt
index 8959261e..17044a15 100644
--- a/collects/typed-scheme/optimizer/fixnum.rkt
+++ b/collects/typed-scheme/optimizer/fixnum.rkt
@@ -74,4 +74,9 @@
   (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-expr)
            #:with opt
            (begin (log-optimization "fixnum to float" #'op)
-                  #'(unsafe-fx->fl n.opt))))
+                  #'(unsafe-fx->fl n.opt)))
+
+  (pattern (#%plain-app (~and op (~literal zero?)) n:fixnum-expr)
+           #:with opt
+           (begin (log-optimization "fixnum zero?" #'op)
+                  #'(unsafe-fx= n.opt 0))))
diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt
index 549cc493..9890d7b3 100644
--- a/collects/typed-scheme/optimizer/float.rkt
+++ b/collects/typed-scheme/optimizer/float.rkt
@@ -85,4 +85,9 @@
   (pattern (#%plain-app (~and op (~literal exact->inexact)) f:float-expr)
            #:with opt
            (begin (log-optimization "float to float" #'op)
-                  #'f.opt)))
+                  #'f.opt))
+
+  (pattern (#%plain-app (~and op (~literal zero?)) f:float-expr)
+           #:with opt
+           (begin (log-optimization "float zero?" #'op)
+                  #'(unsafe-fl= f.opt 0.0))))

From 545a02dfe6ba050b45d474e1a282e1794fa77bdb Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 16 Jul 2010 19:55:14 -0400
Subject: [PATCH 02/20] Changed the interface to typed racket's test harness.

original commit: b13075a1c0679ecf20cc6c84224131c45f455399
---
 collects/tests/typed-scheme/run.rkt | 23 ++++++++++++++++-------
 1 file changed, 16 insertions(+), 7 deletions(-)

diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-scheme/run.rkt
index 7f40679c..b848d7ae 100644
--- a/collects/tests/typed-scheme/run.rkt
+++ b/collects/tests/typed-scheme/run.rkt
@@ -4,30 +4,39 @@
 (require "main.ss")
 
 (define exec (make-parameter go/text))
-(define the-tests (make-parameter tests))
-(define skip-all? #f)
+(define the-tests (make-parameter #f))
 (define nightly? (make-parameter #f))
+(define unit? (make-parameter #f))
+(define int? (make-parameter #f))
 (define opt? (make-parameter #f))
 (define bench? (make-parameter #f))
 (current-namespace (make-base-namespace))
 (command-line
  #:once-each
- ["--unit" "run just the unit tests" (the-tests unit-tests)]
- ["--int" "run just the integration tests" (the-tests int-tests)]
- ["--nightly" "for the nightly builds" (nightly? #t)]
+ ["--unit" "run the unit tests" (unit? #t)]
+ ["--int" "run the integration tests" (int? #t)]
+ ["--nightly" "for the nightly builds" (begin (nightly? #t) (unit? #t) (int? #t))]
  ["--just" path "run only this test" (the-tests (just-one path))]
  ["--opt" "run the optimizer tests" (opt? #t)]
  ["--benchmarks" "compile the typed benchmarks" (bench? #t)]
+ ["--all" "run all tests" (begin (unit? #t) (int? #t) (opt? #t) (bench? #t))]
  ["--gui" "run using the gui" 
           (if (gui-available?)
               (begin (exec go))
               (error "GUI not available"))]
  )
 
+(the-tests
+ (cond [(and (unit?) (int?)) tests]
+       [(unit?)              unit-tests]
+       [(int?)               int-tests]
+       [else                 #f]))
+
 (cond [(and (nightly?) (eq? 'cgc (system-type 'gc)))
        (printf "Skipping Typed Racket tests.\n")]
-      [(unless (= 0 ((exec) (the-tests)))
-         (eprintf "Typed Racket Tests did not pass."))
+      [(when (the-tests)
+         (unless (= 0 ((exec) (the-tests)))
+           (eprintf "Typed Racket Tests did not pass.")))
        (when (opt?)
          (parameterize ([current-command-line-arguments #()])
            (dynamic-require '(file "optimizer/run.rkt") #f))

From 53f7550b51315dcad8dc29ca727355fa861fb01a Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 19 Jul 2010 11:50:39 -0400
Subject: [PATCH 03/20] Added type signatures for operations on inexact
 complexes and floats.

original commit: a31d7b60c8e6911f7b77c3a6f96af2c37da36b9e
---
 collects/typed-scheme/private/base-env-numeric.rkt | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt
index b709fbb7..af0a873f 100644
--- a/collects/typed-scheme/private/base-env-numeric.rkt
+++ b/collects/typed-scheme/private/base-env-numeric.rkt
@@ -240,6 +240,8 @@
                   (list (->* (list -Pos) -Flonum -Flonum))
                   (list (->* (list -Flonum) -Pos -Flonum))
                   (list (->* (list) -Real -Real))
+                  (list (->* (list -Flonum) -InexactComplex -InexactComplex))
+                  (list (->* (list -InexactComplex) -Flonum -InexactComplex))
                   (list (->* (list) -InexactComplex -InexactComplex))
                   (list (->* (list) N N))))]
 [+ (apply cl->*
@@ -253,8 +255,8 @@
                   (list (->* (list -Flonum) -Real -Flonum))
                   (list (->* (list -Real -Flonum) -Real -Flonum))
                   (list (->* (list) -Real -Real))
-                  (list (->* (list -Real) -InexactComplex -InexactComplex))
-                  (list (->* (list -InexactComplex) -Real -InexactComplex))
+                  (list (->* (list N) -InexactComplex -InexactComplex))
+                  (list (->* (list -InexactComplex) N -InexactComplex))
                   (list (->* (list) -InexactComplex -InexactComplex))
                   (list (->* (list) N N))))]
 
@@ -264,8 +266,8 @@
                   (list (->* (list -Flonum) -Real -Flonum))
                   (list (->* (list -Real -Flonum) -Real -Flonum))
                   (list (->* (list -Real) -Real -Real))
-                  (list (->* (list -Real) -InexactComplex -InexactComplex))
-                  (list (->* (list -InexactComplex) -Real -InexactComplex))
+                  (list (->* (list N) -InexactComplex -InexactComplex))
+                  (list (->* (list -InexactComplex) N -InexactComplex))
                   (list (->* (list -InexactComplex) -InexactComplex -InexactComplex))
                   (list (->* (list N) N N))))]
 [/ (apply cl->*
@@ -275,6 +277,8 @@
                   ;; only exact 0 as first argument can cause the result of a division involving inexacts to be exact
                   (list (->* (list -Flonum) -Real -Flonum))
                   (list (->* (list -Real) -Real -Real))
+                  (list (->* (list -Flonum) -InexactComplex -InexactComplex))
+                  (list (->* (list -InexactComplex) -Flonum -InexactComplex))
                   (list (->* (list -InexactComplex) -InexactComplex -InexactComplex))
                   (list (->* (list N) N N))))]
 

From 43683352c56a1d07e72cf74ae481a277fb392f50 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 19 Jul 2010 12:26:53 -0400
Subject: [PATCH 04/20] Improved behavior of coercions with n-ary arithmeric
 operations.

original commit: d078305a59368156e0c977798af4cb805bc3b679
---
 .../typed-scheme/private/base-env-numeric.rkt | 26 +++++++------------
 1 file changed, 10 insertions(+), 16 deletions(-)

diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt
index af0a873f..184e8a68 100644
--- a/collects/typed-scheme/private/base-env-numeric.rkt
+++ b/collects/typed-scheme/private/base-env-numeric.rkt
@@ -235,29 +235,24 @@
 
 [* (apply cl->*
           (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -NonnegativeFlonum -Flonum)]) (->* (list) t t))
-                  (list (->* (list -Pos) -NonnegativeFlonum -NonnegativeFlonum))
-                  (list (->* (list -NonnegativeFlonum) -Pos -NonnegativeFlonum))
-                  (list (->* (list -Pos) -Flonum -Flonum))
-                  (list (->* (list -Flonum) -Pos -Flonum))
+                  (list (->* (list) (Un -Pos -NonnegativeFlonum) -NonnegativeFlonum))
+                  (list (->* (list) (Un -Pos -Flonum) -Flonum))
                   (list (->* (list) -Real -Real))
-                  (list (->* (list -Flonum) -InexactComplex -InexactComplex))
-                  (list (->* (list -InexactComplex) -Flonum -InexactComplex))
-                  (list (->* (list) -InexactComplex -InexactComplex))
+                  (list (->* (list) (Un -InexactComplex -Flonum) -InexactComplex))
                   (list (->* (list) N N))))]
 [+ (apply cl->*
           (append (list (->* (list -Pos) -Nat -Pos))
-                  (list (->* (list -Nat) -Pos -Pos))
+                  (list (->* (list -Nat -Pos) -Nat -Pos))
                   (for/list ([t (list -Nat -Integer -ExactRational -NonnegativeFlonum -Flonum)]) (->* (list) t t))
-                  (list (->* (list -Nat) -NonnegativeFlonum -NonnegativeFlonum))
-                  (list (->* (list -NonnegativeFlonum) -Nat -NonnegativeFlonum))
                   ;; special cases for promotion to inexact, not exhaustive
                   ;; valid for + and -, but not for * and /, since (* <float> 0) is exact 0 (i.e. not a float)
+                  (list (->* (list) (Un -Nat -NonnegativeFlonum) -NonnegativeFlonum))
                   (list (->* (list -Flonum) -Real -Flonum))
                   (list (->* (list -Real -Flonum) -Real -Flonum))
                   (list (->* (list) -Real -Real))
-                  (list (->* (list N) -InexactComplex -InexactComplex))
+                  (list (->* (list) (Un -Real -InexactComplex) -InexactComplex))
                   (list (->* (list -InexactComplex) N -InexactComplex))
-                  (list (->* (list) -InexactComplex -InexactComplex))
+                  (list (->* (list N -InexactComplex) N -InexactComplex))
                   (list (->* (list) N N))))]
 
 [- (apply cl->*
@@ -266,9 +261,9 @@
                   (list (->* (list -Flonum) -Real -Flonum))
                   (list (->* (list -Real -Flonum) -Real -Flonum))
                   (list (->* (list -Real) -Real -Real))
-                  (list (->* (list N) -InexactComplex -InexactComplex))
+                  (list (->* (list) (Un -Real -InexactComplex) -InexactComplex))
                   (list (->* (list -InexactComplex) N -InexactComplex))
-                  (list (->* (list -InexactComplex) -InexactComplex -InexactComplex))
+                  (list (->* (list N -InexactComplex) N -InexactComplex))
                   (list (->* (list N) N N))))]
 [/ (apply cl->*
           (append (list (->* (list -Integer) -Integer -ExactRational))
@@ -277,8 +272,7 @@
                   ;; only exact 0 as first argument can cause the result of a division involving inexacts to be exact
                   (list (->* (list -Flonum) -Real -Flonum))
                   (list (->* (list -Real) -Real -Real))
-                  (list (->* (list -Flonum) -InexactComplex -InexactComplex))
-                  (list (->* (list -InexactComplex) -Flonum -InexactComplex))
+                  (list (->* (list (Un -Flonum -InexactComplex)) (Un -Real -InexactComplex) -InexactComplex))
                   (list (->* (list -InexactComplex) -InexactComplex -InexactComplex))
                   (list (->* (list N) N N))))]
 

From 3aae29501e23c0614fecf9b18066f12ed60ab36f Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 19 Jul 2010 15:32:12 -0400
Subject: [PATCH 05/20] Bytes are fixnums.

original commit: c4ae44123f74de07933d1c6edfb25be4609af6dd
---
 collects/typed-scheme/types/abbrev.rkt | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt
index a8203f4e..5ce0ce8a 100644
--- a/collects/typed-scheme/types/abbrev.rkt
+++ b/collects/typed-scheme/types/abbrev.rkt
@@ -176,7 +176,7 @@
 (define -ExactNonnegativeInteger (*Un -ExactPositiveInteger -Zero))
 (define -Nat -ExactNonnegativeInteger)
 
-(define -Byte -Integer)
+(define -Byte -NonnegativeFixnum)
 
 
 

From 245f1e311ca212e58447e2a1c1392cbc360debd6 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 19 Jul 2010 16:09:01 -0400
Subject: [PATCH 06/20] Improved closure properties of bitwise-and.

original commit: 234e8c363cfd90499566ae24b3cb548785a93ff8
---
 collects/typed-scheme/private/base-env-numeric.rkt | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt
index 184e8a68..7805bd08 100644
--- a/collects/typed-scheme/private/base-env-numeric.rkt
+++ b/collects/typed-scheme/private/base-env-numeric.rkt
@@ -338,7 +338,9 @@
                          (-Nat -Nat . -> . -Nat)
                          (-Integer -Integer . -> . -Integer))]
 [bitwise-and (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum)
+                    ((list -Integer) -NonnegativeFixnum . ->* . -NonnegativeFixnum)
                     (null -Fixnum . ->* . -Fixnum)
+                    ((list -Integer) -Fixnum . ->* . -Fixnum)
                     (null -Nat . ->* . -Nat)
                     (null -Integer . ->* . -Integer))]
 [bitwise-ior (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum)

From 19f4d785698949b6bf9e4505c83945f06005cafe Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 19 Jul 2010 16:52:30 -0400
Subject: [PATCH 07/20] Added box optimizations.

original commit: d6ce6e664f0bd361207725fb3ea9b2a265f39374
---
 .../typed-scheme/optimizer/generic/box.rkt    |  9 ++++++
 collects/typed-scheme/optimizer/box.rkt       | 29 +++++++++++++++++++
 collects/typed-scheme/optimizer/optimizer.rkt |  3 +-
 collects/typed-scheme/private/base-env.rkt    | 10 ++++++-
 4 files changed, 49 insertions(+), 2 deletions(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/box.rkt
 create mode 100644 collects/typed-scheme/optimizer/box.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/box.rkt b/collects/tests/typed-scheme/optimizer/generic/box.rkt
new file mode 100644
index 00000000..aa6695de
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/box.rkt
@@ -0,0 +1,9 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+(: x (Boxof Integer))
+(define x (box 1))
+(unbox x)
+(set-box! x 2)
+(unbox x)
diff --git a/collects/typed-scheme/optimizer/box.rkt b/collects/typed-scheme/optimizer/box.rkt
new file mode 100644
index 00000000..99efba91
--- /dev/null
+++ b/collects/typed-scheme/optimizer/box.rkt
@@ -0,0 +1,29 @@
+#lang scheme/base
+
+(require syntax/parse
+         unstable/match scheme/match
+         "../utils/utils.rkt"
+         (for-template scheme/base scheme/fixnum scheme/unsafe/ops)
+         (rep type-rep)
+         (types abbrev type-table utils subtype)
+         (optimizer utils))
+
+(provide box-opt-expr)
+
+(define-syntax-class box-expr
+  (pattern e:expr
+           #:when (match (type-of #'e)
+                    [(tc-result1: (Box: _)) #t]
+                    [_ #f])
+           #:with opt ((optimize) #'e)))
+
+(define-syntax-class box-op
+  ;; we need the * versions of these unsafe operations to be chaperone-safe
+  (pattern (~literal unbox)    #:with unsafe #'unsafe-unbox*)
+  (pattern (~literal set-box!) #:with unsafe #'unsafe-set-box*!))
+
+(define-syntax-class box-opt-expr
+  (pattern (#%plain-app op:box-op b:box-expr new:expr ...)
+           #:with opt
+           (begin (log-optimization "box" #'op)
+                  #`(op.unsafe b.opt #,@(map (optimize) (syntax->list #'(new ...)))))))
diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
index 730d6680..d9ad4ab6 100644
--- a/collects/typed-scheme/optimizer/optimizer.rkt
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -5,7 +5,7 @@
          (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for)
          "../utils/utils.rkt"
          (types abbrev type-table utils subtype)
-         (optimizer utils fixnum float inexact-complex vector pair sequence struct dead-code))
+         (optimizer utils fixnum float inexact-complex vector pair sequence box struct dead-code))
 
 (provide optimize-top)
 
@@ -24,6 +24,7 @@
   (pattern e:vector-opt-expr          #:with opt #'e.opt)
   (pattern e:pair-opt-expr            #:with opt #'e.opt)
   (pattern e:sequence-opt-expr        #:with opt #'e.opt)
+  (pattern e:box-opt-expr             #:with opt #'e.opt)
   (pattern e:struct-opt-expr          #:with opt #'e.opt)
   (pattern e:dead-code-opt-expr       #:with opt #'e.opt)
   
diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt
index 7f865c7a..0ce98a90 100644
--- a/collects/typed-scheme/private/base-env.rkt
+++ b/collects/typed-scheme/private/base-env.rkt
@@ -200,10 +200,18 @@
 [newline (->opt [-Output-Port] -Void)]
 [not (-> Univ B)]
 [box (-poly (a) (a . -> . (-box a)))]
-[unbox (-poly (a) (cl->*                   
+[unbox (-poly (a) (cl->*
                    ((-box a) . -> . a)
                    ((make-BoxTop) . -> . Univ)))]
 [set-box! (-poly (a) ((-box a) a . -> . -Void))]
+[unsafe-unbox (-poly (a) (cl->*
+                          ((-box a) . -> . a)
+                          ((make-BoxTop) . -> . Univ)))]
+[unsafe-set-box! (-poly (a) ((-box a) a . -> . -Void))]
+[unsafe-unbox* (-poly (a) (cl->*
+                           ((-box a) . -> . a)
+                           ((make-BoxTop) . -> . Univ)))]
+[unsafe-set-box*! (-poly (a) ((-box a) a . -> . -Void))]
 [box? (make-pred-ty (make-BoxTop))]
 [cons? (make-pred-ty (-pair Univ Univ))]
 [pair? (make-pred-ty (-pair Univ Univ))]

From 6c0c6b3f65c0e14102537d19218e32f952d41aae Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Mon, 19 Jul 2010 17:58:38 -0400
Subject: [PATCH 08/20] Added optimization for string-length and bytes-length.

original commit: 4e944f73abc138b7d283020bf5c577fe6ecf6e95
---
 .../optimizer/generic/string-length.rkt       |  6 ++++
 collects/typed-scheme/optimizer/optimizer.rkt |  8 ++++--
 collects/typed-scheme/optimizer/sequence.rkt  | 11 +-------
 collects/typed-scheme/optimizer/string.rkt    | 28 +++++++++++++++++++
 4 files changed, 41 insertions(+), 12 deletions(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/string-length.rkt
 create mode 100644 collects/typed-scheme/optimizer/string.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/string-length.rkt b/collects/tests/typed-scheme/optimizer/generic/string-length.rkt
new file mode 100644
index 00000000..30210100
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/string-length.rkt
@@ -0,0 +1,6 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+(string-length "eh")
+(bytes-length #"eh")
diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
index d9ad4ab6..eae6d01e 100644
--- a/collects/typed-scheme/optimizer/optimizer.rkt
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -2,10 +2,13 @@
 
 (require syntax/parse 
          syntax/id-table racket/dict
-         (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for)
+         (for-template scheme/base
+                       scheme/flonum scheme/fixnum scheme/unsafe/ops
+                       racket/private/for)
          "../utils/utils.rkt"
          (types abbrev type-table utils subtype)
-         (optimizer utils fixnum float inexact-complex vector pair sequence box struct dead-code))
+         (optimizer utils fixnum float inexact-complex vector string
+                    pair sequence box struct dead-code))
 
 (provide optimize-top)
 
@@ -22,6 +25,7 @@
   (pattern e:float-opt-expr           #:with opt #'e.opt)
   (pattern e:inexact-complex-opt-expr #:with opt #'e.opt)
   (pattern e:vector-opt-expr          #:with opt #'e.opt)
+  (pattern e:string-opt-expr          #:with opt #'e.opt)
   (pattern e:pair-opt-expr            #:with opt #'e.opt)
   (pattern e:sequence-opt-expr        #:with opt #'e.opt)
   (pattern e:box-opt-expr             #:with opt #'e.opt)
diff --git a/collects/typed-scheme/optimizer/sequence.rkt b/collects/typed-scheme/optimizer/sequence.rkt
index c1713099..3821e886 100644
--- a/collects/typed-scheme/optimizer/sequence.rkt
+++ b/collects/typed-scheme/optimizer/sequence.rkt
@@ -7,7 +7,7 @@
          "../utils/utils.rkt" "../utils/tc-utils.rkt"
          (rep type-rep)
          (types abbrev type-table utils subtype)
-         (optimizer utils))
+         (optimizer utils string))
 
 (provide sequence-opt-expr)
 
@@ -29,15 +29,6 @@
                     [_ #f])
            #:with opt ((optimize) #'e)))
 
-(define-syntax-class string-expr
-  (pattern e:expr
-           #:when (isoftype? #'e -String)
-           #:with opt ((optimize) #'e)))
-(define-syntax-class bytes-expr
-  (pattern e:expr
-           #:when (isoftype? #'e -Bytes)
-           #:with opt ((optimize) #'e)))
-
 (define-syntax-class sequence-opt-expr
   ;; if we're iterating (with the for macros) over something we know is a list,
   ;; we can generate code that would be similar to if in-list had been used
diff --git a/collects/typed-scheme/optimizer/string.rkt b/collects/typed-scheme/optimizer/string.rkt
new file mode 100644
index 00000000..8f9f019e
--- /dev/null
+++ b/collects/typed-scheme/optimizer/string.rkt
@@ -0,0 +1,28 @@
+#lang scheme/base
+
+(require syntax/parse
+         (for-template scheme/base scheme/flonum scheme/unsafe/ops)
+         "../utils/utils.rkt"
+         (types abbrev type-table utils subtype)
+         (optimizer utils))
+
+(provide string-opt-expr string-expr bytes-expr)
+
+(define-syntax-class string-expr
+  (pattern e:expr
+           #:when (isoftype? #'e -String)
+           #:with opt ((optimize) #'e)))
+(define-syntax-class bytes-expr
+  (pattern e:expr
+           #:when (isoftype? #'e -Bytes)
+           #:with opt ((optimize) #'e)))
+
+(define-syntax-class string-opt-expr
+  (pattern (#%plain-app (~literal string-length) s:string-expr)
+           #:with opt
+           (begin (log-optimization "string" #'op)
+                  #'(unsafe-string-length s.opt)))
+  (pattern (#%plain-app (~literal bytes-length) s:bytes-expr)
+           #:with opt
+           (begin (log-optimization "bytes" #'op)
+                  #'(unsafe-bytes-length s.opt))))

From 9bef09798750adff9f9a0eb77be471c53f3eb6fe Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Tue, 20 Jul 2010 18:28:54 -0400
Subject: [PATCH 09/20] Optimizations on one-argument cases of arithmetic
 operations.

original commit: 0ee0886cab6989843a9bef1eb3797657e0f1d0c2
---
 .../optimizer/generic/one-arg-arith.rkt       | 20 +++++++++++++++++++
 collects/typed-scheme/optimizer/fixnum.rkt    |  6 ++++++
 collects/typed-scheme/optimizer/float.rkt     | 17 ++++++++++++----
 collects/typed-scheme/optimizer/number.rkt    | 16 +++++++++++++++
 collects/typed-scheme/optimizer/optimizer.rkt |  3 ++-
 5 files changed, 57 insertions(+), 5 deletions(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/one-arg-arith.rkt
 create mode 100644 collects/typed-scheme/optimizer/number.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/one-arg-arith.rkt b/collects/tests/typed-scheme/optimizer/generic/one-arg-arith.rkt
new file mode 100644
index 00000000..990036e4
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/one-arg-arith.rkt
@@ -0,0 +1,20 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+(- 12)
+(- 12.0)
+(/ 4.2)
+
+(+ 1)
+(+ 1.0)
+(+ (expt 2 100))
+(* 1)
+(* 1.0)
+(* (expt 2 100))
+(min 1)
+(min 1.0)
+(min (expt 2 100))
+(max 1)
+(max 1.0)
+(max (expt 2 100))
diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt
index 17044a15..fbe684c1 100644
--- a/collects/typed-scheme/optimizer/fixnum.rkt
+++ b/collects/typed-scheme/optimizer/fixnum.rkt
@@ -71,6 +71,12 @@
            #:with opt
            (begin (log-optimization "binary nonzero fixnum" #'op)
                   #'(op.unsafe n1.opt n2.opt)))
+
+  (pattern (#%plain-app (~and op (~literal -)) f:fixnum-expr)
+           #:with opt
+           (begin (log-optimization "unary fixnum" #'op)
+                  #'(unsafe-fx- 0 f.opt)))
+
   (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-expr)
            #:with opt
            (begin (log-optimization "fixnum to float" #'op)
diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt
index 9890d7b3..b7970212 100644
--- a/collects/typed-scheme/optimizer/float.rkt
+++ b/collects/typed-scheme/optimizer/float.rkt
@@ -68,13 +68,22 @@
            #:with opt
            (begin (log-optimization "binary float" #'op)
                   (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))
-  (pattern (~and res (#%plain-app (~var op (float-op binary-float-comps))
-                                  f1:float-expr
-                                  f2:float-expr
-                                  fs:float-expr ...))
+  (pattern (#%plain-app (~var op (float-op binary-float-comps))
+                        f1:float-expr
+                        f2:float-expr
+                        fs:float-expr ...)
            #:with opt
            (begin (log-optimization "binary float comp" #'op)
                   (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...))))
+
+  (pattern (#%plain-app (~and op (~literal -)) f:float-expr)
+           #:with opt
+           (begin (log-optimization "unary float" #'op)
+                  #'(unsafe-fl- 0.0 f.opt)))
+  (pattern (#%plain-app (~and op (~literal /)) f:float-expr)
+           #:with opt
+           (begin (log-optimization "unary float" #'op)
+                  #'(unsafe-fl/ 1.0 f.opt)))
   
   ;; we can optimize exact->inexact if we know we're giving it an Integer
   (pattern (#%plain-app (~and op (~literal exact->inexact)) n:int-expr)
diff --git a/collects/typed-scheme/optimizer/number.rkt b/collects/typed-scheme/optimizer/number.rkt
new file mode 100644
index 00000000..81acd094
--- /dev/null
+++ b/collects/typed-scheme/optimizer/number.rkt
@@ -0,0 +1,16 @@
+#lang scheme/base
+
+(require syntax/parse
+         (for-template scheme/base scheme/flonum scheme/unsafe/ops)
+         "../utils/utils.rkt"
+         (optimizer utils))
+
+(provide number-opt-expr)
+
+(define-syntax-class number-opt-expr
+  ;; these cases are all identity
+  (pattern (#%plain-app (~and op (~or (~literal +) (~literal *) (~literal min) (~literal max)))
+                        f:expr)
+           #:with opt
+           (begin (log-optimization "unary number" #'op)
+                  ((optimize) #'f))))
diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
index eae6d01e..a3a93ea8 100644
--- a/collects/typed-scheme/optimizer/optimizer.rkt
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -7,7 +7,7 @@
                        racket/private/for)
          "../utils/utils.rkt"
          (types abbrev type-table utils subtype)
-         (optimizer utils fixnum float inexact-complex vector string
+         (optimizer utils number fixnum float inexact-complex vector string
                     pair sequence box struct dead-code))
 
 (provide optimize-top)
@@ -21,6 +21,7 @@
   #:literal-sets (kernel-literals)
 
   ;; interesting cases, where something is optimized
+  (pattern e:number-opt-expr          #:with opt #'e.opt)
   (pattern e:fixnum-opt-expr          #:with opt #'e.opt)
   (pattern e:float-opt-expr           #:with opt #'e.opt)
   (pattern e:inexact-complex-opt-expr #:with opt #'e.opt)

From 69476bba2451d6a18846c3e71eab241b8d95249c Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 23 Jul 2010 14:10:17 -0400
Subject: [PATCH 10/20] Optimize (apply + (map f l)) to avoid the intermediate
 list.

original commit: 5bb730f72c91f52166009d1e5fbe52a346c91edf
---
 .../optimizer/generic/apply-plus.rkt          |  4 +++
 collects/typed-scheme/optimizer/apply.rkt     | 32 +++++++++++++++++++
 collects/typed-scheme/optimizer/optimizer.rkt | 22 ++++++-------
 collects/typed-scheme/optimizer/utils.rkt     |  4 +--
 4 files changed, 48 insertions(+), 14 deletions(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/apply-plus.rkt
 create mode 100644 collects/typed-scheme/optimizer/apply.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/apply-plus.rkt b/collects/tests/typed-scheme/optimizer/generic/apply-plus.rkt
new file mode 100644
index 00000000..800f688e
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/apply-plus.rkt
@@ -0,0 +1,4 @@
+#lang typed/racket #:optimize
+(require racket/unsafe/ops)
+(apply + (map add1 (list 1 2 3)))
+(apply * (map add1 (list 1 2 3)))
diff --git a/collects/typed-scheme/optimizer/apply.rkt b/collects/typed-scheme/optimizer/apply.rkt
new file mode 100644
index 00000000..4fa67d97
--- /dev/null
+++ b/collects/typed-scheme/optimizer/apply.rkt
@@ -0,0 +1,32 @@
+#lang scheme/base
+(require syntax/parse
+         syntax/id-table racket/dict
+         unstable/match scheme/match
+         (for-template scheme/unsafe/ops racket/base (prefix-in k: '#%kernel))
+         (for-syntax racket/base)
+         "../utils/utils.rkt"
+         (rep type-rep)
+         (types abbrev type-table utils subtype)
+         (optimizer utils))
+
+(provide apply-opt-expr)
+
+(define-syntax-class apply-op
+  #:literals (+ *)
+  (pattern + #:with identity #'0)
+  (pattern * #:with identity #'1))
+
+(define-syntax-class apply-opt-expr
+		     #:literals (k:apply map #%plain-app #%app)
+  (pattern (#%plain-app k:apply op:apply-op (#%plain-app map f l))
+           #:with opt
+           (begin (reset-unboxed-gensym)
+           (with-syntax ([(f* lp v lst) (map unboxed-gensym '(f* loop v lst))]
+			 [l ((optimize) #'l)]
+			 [f ((optimize) #'f)])
+	     (log-optimization "apply-map" #'op)
+	     #'(let ([f* f])
+                 (let lp ([v op.identity] [lst l])
+                   (if (null? lst)
+                       v
+                       (lp (op v (f* (unsafe-car lst))) (unsafe-cdr lst)))))))))
diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
index a3a93ea8..c0f3c08b 100644
--- a/collects/typed-scheme/optimizer/optimizer.rkt
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -8,7 +8,7 @@
          "../utils/utils.rkt"
          (types abbrev type-table utils subtype)
          (optimizer utils number fixnum float inexact-complex vector string
-                    pair sequence box struct dead-code))
+                    pair sequence box struct dead-code apply))
 
 (provide optimize-top)
 
@@ -21,6 +21,7 @@
   #:literal-sets (kernel-literals)
 
   ;; interesting cases, where something is optimized
+  (pattern e:apply-opt-expr           #:with opt #'e.opt)
   (pattern e:number-opt-expr          #:with opt #'e.opt)
   (pattern e:fixnum-opt-expr          #:with opt #'e.opt)
   (pattern e:float-opt-expr           #:with opt #'e.opt)
@@ -47,9 +48,10 @@
   (pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs:opt-expr] ...) e-body:opt-expr ...)
            #:with opt #'(letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs.opt] ...) e-body.opt ...))
   (pattern (kw:identifier expr ...)
-           #:when (ormap (lambda (k) (free-identifier=? k #'kw))
-                         (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
-                               #'#%variable-reference #'with-continuation-mark))
+           #:when 
+	   (for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
+			     #'#%variable-reference #'with-continuation-mark)])
+	     (free-identifier=? k #'kw))
            ;; we don't want to optimize in the cases that don't match the #:when clause
            #:with (expr*:opt-expr ...) #'(expr ...)
            #:with opt #'(kw expr*.opt ...))
@@ -64,12 +66,8 @@
                   (current-output-port))))
     (begin0
       (parameterize ([current-output-port port]
-                     [optimize (lambda (stx)
-                                 (syntax-parse stx #:literal-sets (kernel-literals)
-                                               [e:opt-expr
-                                                (syntax/loc stx e.opt)]))])
+                     [optimize (syntax-parser [e:opt-expr #'e.opt])])
         ((optimize) stx))
-      (if (and *log-optimizations?*
-               *log-optimizatons-to-log-file?*)
-          (close-output-port port)
-          #t))))
+      (when (and *log-optimizations?*
+                 *log-optimizatons-to-log-file?*)
+        (close-output-port port)))))
diff --git a/collects/typed-scheme/optimizer/utils.rkt b/collects/typed-scheme/optimizer/utils.rkt
index 912b0184..088f0fd0 100644
--- a/collects/typed-scheme/optimizer/utils.rkt
+++ b/collects/typed-scheme/optimizer/utils.rkt
@@ -52,9 +52,9 @@
 ;; necessary to have predictable symbols to add in the hand-optimized versions
 ;; of the optimizer tests (which check for equality of expanded code)
 (define *unboxed-gensym-counter* 0)
-(define (unboxed-gensym)
+(define (unboxed-gensym [name 'unboxed-gensym-])
   (set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*))
-  (format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*))
+  (format-unique-id #'here "~a~a" name *unboxed-gensym-counter*))
 (define (reset-unboxed-gensym)
   (set! *unboxed-gensym-counter* 0))
 

From 2ef2641a4d741c856a4be885f42e83642eb0a3f7 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 22 Jul 2010 17:48:44 -0400
Subject: [PATCH 11/20] Refactoring of the optimizer.

original commit: 0493e6f7623361a289989654d25deac19e552de6
---
 collects/typed-scheme/optimizer/optimizer.rkt | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
index c0f3c08b..5f6f6c49 100644
--- a/collects/typed-scheme/optimizer/optimizer.rkt
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -35,10 +35,9 @@
   (pattern e:dead-code-opt-expr       #:with opt #'e.opt)
   
   ;; boring cases, just recur down
-  (pattern (#%plain-lambda formals e:opt-expr ...)
-           #:with opt #'(#%plain-lambda formals e.opt ...))
-  (pattern (define-values formals e:opt-expr ...)
-           #:with opt #'(define-values formals e.opt ...))
+  (pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
+            formals e:opt-expr ...)
+           #:with opt #'(op formals e.opt ...))
   (pattern (case-lambda [formals e:opt-expr ...] ...)
            #:with opt #'(case-lambda [formals e.opt ...] ...))
   (pattern (let-values ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)

From fe68e29caad4b868cf4ab244a48c9009c32e37d0 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 22 Jul 2010 19:23:03 -0400
Subject: [PATCH 12/20] Optimized extracting parts of inexact complexes.

original commit: 063b87697a333b2b8f53e6d2b8a43e8f500e2762
---
 .../optimizer/inexact-complex.rkt             | 137 +++++++++++++-----
 1 file changed, 98 insertions(+), 39 deletions(-)

diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt
index 99ec1c38..2de39867 100644
--- a/collects/typed-scheme/optimizer/inexact-complex.rkt
+++ b/collects/typed-scheme/optimizer/inexact-complex.rkt
@@ -14,6 +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 op (~literal +))
                         c1:unboxed-inexact-complex-opt-expr
                         c2:unboxed-inexact-complex-opt-expr
@@ -23,20 +24,21 @@
            #: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)))
-                                      ;; 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)))))))))))
+                                (let ()
+                                   ;; we can skip the real parts of imaginaries (#f) and vice versa
+                                   (define (skip-0s l)
+                                     (let ((l (filter syntax->datum (syntax->list l))))
+                                       (case (length l)
+                                         ((0) #'0.0)
+                                         ((1) (car l))
+                                         (else
+                                          (for/fold ((o (car l)))
+                                              ((e (cdr l)))
+                                            #`(unsafe-fl+ #,o #,e))))))
+                                   (list
+                                    #`(real-part #,(skip-0s #'(c1.real-part c2.real-part cs.real-part ...)))
+                                    #`(imag-part #,(skip-0s #'(c1.imag-part c2.imag-part cs.imag-part ...)))))))))
+  
   (pattern (#%plain-app (~and op (~literal -))
                         c1:unboxed-inexact-complex-opt-expr
                         c2:unboxed-inexact-complex-opt-expr
@@ -46,22 +48,24 @@
            #: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)))))))))))
+                                (let ()
+                                  ;; unlike addition, we simply can't skip real parts of imaginaries
+                                  (define (skip-0s l)
+                                    (let* ((l1 (map (lambda (x) (if (syntax->datum x) x #'0.0))
+                                                    (syntax->list l)))
+                                           ;; 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))))))
+                                  (list
+                                   #`(real-part #,(skip-0s #'(c1.real-part c2.real-part cs.real-part ...)))
+                                   #`(imag-part #,(skip-0s #'(c1.imag-part c2.imag-part cs.imag-part ...)))))))))
+  
   (pattern (#%plain-app (~and op (~literal *))
                         c1:unboxed-inexact-complex-opt-expr
                         c2:unboxed-inexact-complex-opt-expr
@@ -73,12 +77,14 @@
                   #`(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 ((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)]
+                     #,@(let ((lr (map (lambda (x) (if (syntax->datum x) x #'0.0))
+                                       (syntax->list #'(c1.real-part c2.real-part cs.real-part ...))))
+                              (li (map (lambda (x) (if (syntax->datum x) x #'0.0))
+                                       (syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...)))))
+                          (let loop ([o1 (car lr)]
+                                     [o2 (car li)]
+                                     [e1 (cdr lr)]
+                                     [e2 (cdr li)]
                                      [rs (append (map (lambda (x) (unboxed-gensym))
                                                       (syntax->list #'(cs.real-part ...)))
                                                  (list #'real-part))]
@@ -107,13 +113,15 @@
                                                            #`(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 ...))
+           #:with reals (map (lambda (x) (if (syntax->datum x) x #'0.0))
+                             (syntax->list #'(c1.real-part c2.real-part cs.real-part ...)))
            #:with imags (map (lambda (x) (if (syntax->datum x) x #'0.0))
                              (syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...)))
            #:with (bindings ...)
@@ -175,6 +183,7 @@
                                                  (unsafe-fl+ (unsafe-fl* #,(car e1) #,(car e1))
                                                              (unsafe-fl* #,(car e2) #,(car e2))))
                                               res)]))))))))
+
   (pattern (#%plain-app (~and op (~literal conjugate)) c:unboxed-inexact-complex-opt-expr)
            #:with real-part #'c.real-part
            #:with imag-part (unboxed-gensym)
@@ -182,6 +191,32 @@
            (begin (log-optimization "unboxed unary inexact complex" #'op)
                   #`(#,@(append (syntax->list #'(c.bindings ...))
                                 (list #'(imag-part (unsafe-fl- 0.0 c.imag-part)))))))
+
+  (pattern (#%plain-app (~and op (~or (~literal real-part) (~literal unsafe-flreal-part)))
+                        c:unboxed-inexact-complex-opt-expr)
+           #:with real-part #'c.real-part
+           #:with imag-part #f
+           #:with (bindings ...)
+           (begin (log-optimization "unboxed unary inexact complex" #'op)
+                  #'(c.bindings ...)))
+  (pattern (#%plain-app (~and op (~or (~literal imag-part) (~literal unsafe-flimag-part)))
+                        c:unboxed-inexact-complex-opt-expr)
+           #:with real-part #'c.imag-part
+           #:with imag-part #f
+           #:with (bindings ...)
+           (begin (log-optimization "unboxed unary inexact complex" #'op)
+                  #'(c.bindings ...)))
+
+  ;; if we see a variable that's already unboxed, use the unboxed bindings
+  (pattern v:id
+           #:with unboxed-real-part (syntax-property #'v 'unboxed-real-part)
+           #:with unboxed-imag-part (syntax-property #'v 'unboxed-imag-part)
+           #:when (and (syntax-e #'unboxed-real-part) (syntax-e #'unboxed-imag-part))
+           #:with real-part #'unboxed-real-part
+           #:with imag-part #'unboxed-imag-part
+           #:with (bindings ...) #'())
+  
+  ;; else, do the unboxing here  
   (pattern e:expr
            #:when (isoftype? #'e -InexactComplex)
            #:with e* (unboxed-gensym)
@@ -223,7 +258,7 @@
   (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-syntax-class inexact-complex-binary-op
+(define-syntax-class inexact-complex-op
   (pattern (~or (~literal +) (~literal -) (~literal *) (~literal /) (~literal conjugate))))
 
 (define-syntax-class inexact-complex-expr
@@ -232,13 +267,37 @@
            #:with opt ((optimize) #'e)))
 
 (define-syntax-class inexact-complex-opt-expr
+
+  ;; we can optimize taking the real of imag part of an unboxed complex
+  ;; hopefully, the compiler can eliminate unused bindings for the other part if it's not used
+  (pattern (#%plain-app (~and op (~or (~literal real-part) (~literal unsafe-flreal-part)
+                                      (~literal imag-part) (~literal unsafe-flimag-part)))
+                        c:inexact-complex-expr)
+           #:with c*:inexact-complex-arith-opt-expr #'c
+           #:with opt
+           (begin (log-optimization "unboxed inexact complex" #'op)
+                  (reset-unboxed-gensym)
+                  #`(let* (c*.bindings ...)
+                      #,(if (or (free-identifier=? #'op #'real-part)
+                                (free-identifier=? #'op #'unsafe-flreal-part))
+                            #'c*.real-part
+                            #'c*.imag-part))))
+  
   (pattern (#%plain-app op:inexact-complex-unary-op n:inexact-complex-expr)
            #:with opt
            (begin (log-optimization "unary inexact complex" #'op)
                   #'(op.unsafe n.opt)))
-  (pattern (~and exp (#%plain-app op:inexact-complex-binary-op e:expr ...))
+  (pattern e:inexact-complex-arith-opt-expr
+           #:with opt
+           #'e.opt))
+
+(define-syntax-class inexact-complex-arith-opt-expr
+  (pattern (~and exp (#%plain-app op:inexact-complex-op e:expr ...))
            #:when (isoftype? #'exp -InexactComplex)
            #:with exp*:unboxed-inexact-complex-opt-expr #'exp
+           #:with real-part #'exp*.real-part
+           #:with imag-part #'exp*.imag-part
+           #:with (bindings ...) #'(exp*.bindings ...)
            #:with opt
            (begin (log-optimization "unboxed inexact complex" #'exp)
                   (reset-unboxed-gensym)

From eb60ac080abc9c25126dcacb9ec087927f8ebc12 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 23 Jul 2010 16:35:25 -0400
Subject: [PATCH 13/20] let bindings of inexact-complex numbers can be replaced
 by bindings for each of their components.

This allows unboxing of intermediate results that are bound and only
ever used in positions where they would be unboxed.

original commit: 83987fffac7719ab0c35d3df49ea0a7adf4bc9b6
---
 .../optimizer/generic/invalid-unboxed-let.rkt |  12 +++
 .../generic/invalid-unboxed-let2.rkt          |   7 ++
 .../optimizer/generic/unboxed-let.rkt         |   8 ++
 .../optimizer/inexact-complex.rkt             |  18 ++--
 collects/typed-scheme/optimizer/optimizer.rkt |  18 ++--
 .../typed-scheme/optimizer/unboxed-let.rkt    | 100 ++++++++++++++++++
 6 files changed, 149 insertions(+), 14 deletions(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt
 create mode 100644 collects/typed-scheme/optimizer/unboxed-let.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt
new file mode 100644
index 00000000..4039f652
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let.rkt
@@ -0,0 +1,12 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+(let ((t1 (+ 1.0+2.0i 2.0+4.0i)) ; can be unboxed
+      (t2 (+ 3.0+6.0i 4.0+8.0i)) ; can't be unboxed
+      (t3 1.0+2.0i) ; can't be unboxed
+      (t4 1))
+  (display (+ t1 t1))
+  (display t2)
+  (display t3)
+  (display t4))
diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt
new file mode 100644
index 00000000..f41ef094
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-unboxed-let2.rkt
@@ -0,0 +1,7 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+;; unboxing of let bindings does not currently work with multiple values
+(let-values (((t1 t2) (values (+ 1.0+2.0i 2.0+4.0i) (+ 3.0+6.0i 4.0+8.0i))))
+  (+ t1 t2))
diff --git a/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt b/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt
new file mode 100644
index 00000000..bbdf3f63
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt
@@ -0,0 +1,8 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+(let* ((t1 (+ 1.0+2.0i 2.0+4.0i))
+       (t2 (- t1 3.0+6.0i))
+       (t3 (- t1 4.0+8.0i)))
+  (+ t2 t3))
diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt
index 2de39867..09586da6 100644
--- a/collects/typed-scheme/optimizer/inexact-complex.rkt
+++ b/collects/typed-scheme/optimizer/inexact-complex.rkt
@@ -1,14 +1,19 @@
 #lang scheme/base
 
-(require syntax/parse
+(require syntax/parse syntax/id-table scheme/dict
          "../utils/utils.rkt"
          (for-template scheme/base scheme/math scheme/flonum scheme/unsafe/ops)
          (types abbrev type-table utils subtype)
          (optimizer utils float fixnum))
 
-(provide inexact-complex-opt-expr)
+(provide inexact-complex-opt-expr inexact-complex-arith-opt-expr
+         unboxed-inexact-complex-opt-expr unboxed-vars-table)
 
 
+;; contains the bindings which actually exist as separate bindings for each component
+;; associates identifiers to lists (real-part imag-part)
+(define unboxed-vars-table (make-free-id-table))
+
 ;; it's faster to take apart a complex number and use unsafe operations on
 ;; its parts than it is to use generic operations
 ;; we keep the real and imaginary parts unboxed as long as we stay within
@@ -209,11 +214,10 @@
 
   ;; if we see a variable that's already unboxed, use the unboxed bindings
   (pattern v:id
-           #:with unboxed-real-part (syntax-property #'v 'unboxed-real-part)
-           #:with unboxed-imag-part (syntax-property #'v 'unboxed-imag-part)
-           #:when (and (syntax-e #'unboxed-real-part) (syntax-e #'unboxed-imag-part))
-           #:with real-part #'unboxed-real-part
-           #:with imag-part #'unboxed-imag-part
+           #:with unboxed-info (dict-ref unboxed-vars-table #'v #f)
+           #:when (syntax->datum #'unboxed-info)
+           #:with real-part (car  (syntax->list #'unboxed-info))
+           #:with imag-part (cadr (syntax->list #'unboxed-info))
            #:with (bindings ...) #'())
   
   ;; else, do the unboxing here  
diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
index 5f6f6c49..d7ea4dff 100644
--- a/collects/typed-scheme/optimizer/optimizer.rkt
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -8,7 +8,7 @@
          "../utils/utils.rkt"
          (types abbrev type-table utils subtype)
          (optimizer utils number fixnum float inexact-complex vector string
-                    pair sequence box struct dead-code apply))
+                    pair sequence box struct dead-code apply unboxed-let))
 
 (provide optimize-top)
 
@@ -33,6 +33,7 @@
   (pattern e:box-opt-expr             #:with opt #'e.opt)
   (pattern e:struct-opt-expr          #:with opt #'e.opt)
   (pattern e:dead-code-opt-expr       #:with opt #'e.opt)
+  (pattern e:unboxed-let-opt-expr     #:with opt #'e.opt)
   
   ;; boring cases, just recur down
   (pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
@@ -40,12 +41,15 @@
            #:with opt #'(op formals e.opt ...))
   (pattern (case-lambda [formals e:opt-expr ...] ...)
            #:with opt #'(case-lambda [formals e.opt ...] ...))
-  (pattern (let-values ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
-           #:with opt #'(let-values ([ids e-rhs.opt] ...) e-body.opt ...))
-  (pattern (letrec-values ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
-           #:with opt #'(letrec-values ([ids e-rhs.opt] ...) e-body.opt ...))
-  (pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs:opt-expr] ...) e-body:opt-expr ...)
-           #:with opt #'(letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs.opt] ...) e-body.opt ...))
+  (pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
+            ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
+           #:with opt #'(op ([ids e-rhs.opt] ...) e-body.opt ...))
+  (pattern (letrec-syntaxes+values stx-bindings
+                                   ([(ids ...) e-rhs:opt-expr] ...)
+                                   e-body:opt-expr ...)
+           #:with opt #'(letrec-syntaxes+values stx-bindings
+                                                ([(ids ...) e-rhs.opt] ...)
+                                                e-body.opt ...))
   (pattern (kw:identifier expr ...)
            #:when 
 	   (for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt
new file mode 100644
index 00000000..40d11cdf
--- /dev/null
+++ b/collects/typed-scheme/optimizer/unboxed-let.rkt
@@ -0,0 +1,100 @@
+#lang scheme/base
+
+(require syntax/parse
+         scheme/list scheme/dict
+         "../utils/utils.rkt"
+         "../utils/tc-utils.rkt"
+         (for-template scheme/base)
+         (types abbrev)
+         (optimizer utils inexact-complex))
+
+(provide unboxed-let-opt-expr)
+
+;; possibly replace bindings of complex numbers by bindings of their 2 components
+;; useful for intermediate results used more than once and for loop variables
+
+(define-syntax-class unboxed-let-opt-expr
+  #:literal-sets (kernel-literals)
+  (pattern (~and exp (let-values (clause:expr ...) body:expr ...))
+           ;; we look for bindings of complexes that are not mutated and only
+           ;; used in positions where we would unbox them
+           ;; these are candidates for unboxing
+           #:with ((candidates ...) (others ...))
+           (let-values
+               (((candidates others)
+                 ;; clauses of form ((v) rhs), currently only suppose 1 lhs var
+                 (partition (lambda (p)
+                              (and (isoftype? (cadr p) -InexactComplex)
+                                   (let ((v (car (syntax-e (car p)))))
+                                     (not (is-var-mutated? v))
+                                     (could-be-unboxed-in? v #'(begin body ...)))))
+                            (map syntax->list (syntax->list #'(clause ...))))))
+             (list candidates others))
+           #:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...)
+           #:with (opt-others:let-clause ...) #'(others ...)
+           #:with opt
+           (begin (log-optimization "unboxed let bindings" #'exp)
+                  ;; add the unboxed bindings to the table, for them to be used by
+                  ;; further optimizations
+                  (for ((v (in-list (syntax->list #'(opt-candidates.id ...))))
+                        (r (in-list (syntax->list #'(opt-candidates.real-part ...))))
+                        (i (in-list (syntax->list #'(opt-candidates.imag-part ...)))))
+                       (dict-set! unboxed-vars-table v (list r i)))
+                  #`(let* (opt-candidates.bindings ... ... opt-others.res ...)
+                      #,@(map (optimize) (syntax->list #'(body ...)))))))
+
+;; if a variable is only used in complex arithmetic operations, it's safe
+;; to unbox it
+(define (could-be-unboxed-in? v exp)
+
+  (define (direct-child-of? exp)
+    (ormap (lambda (x) (and (identifier? x) (free-identifier=? x v)))
+           (syntax->list exp)))
+
+  ;; if v is a direct child of exp, that means it's used in a boxed
+  ;; fashion, and is not safe to unboxed
+  ;; if not, recur on the subforms
+  (define (look-at exp)
+    (and (not (direct-child-of? exp))
+         (andmap rec (syntax->list exp))))
+  
+  (define (rec exp)
+    (syntax-parse exp
+      #:literal-sets (kernel-literals)
+      
+      ;; used within a complex arithmetic expression? safe to unbox
+      [exp:inexact-complex-arith-opt-expr
+       (direct-child-of? #'exp)]
+      
+      ;; recur down
+      [((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
+        formals e:expr ...)
+       (look-at #'(e ...))]
+      [(case-lambda [formals e:expr ...] ...)
+       (look-at #'(e ... ...))]
+      [((~or (~literal let-values) (~literal letrec-values))
+        ([ids e-rhs:expr] ...) e-body:expr ...)
+       (look-at #'(e-rhs ... e-body ...))]
+      [(letrec-syntaxes+values stx-bindings
+                               ([(ids ...) e-rhs:expr] ...)
+                               e-body:expr ...)
+       (look-at #'(e-rhs ... e-body ...))]
+      [(kw:identifier expr ...)
+       #:when (ormap (lambda (k) (free-identifier=? k #'kw))
+                     (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
+                           #'#%variable-reference #'with-continuation-mark))
+       (look-at #'(expr ...))]
+            
+      ;; not used, safe to unbox
+      [_ #t]))
+  (rec exp))
+
+(define-syntax-class unboxed-let-clause
+  (pattern ((v:id) rhs:unboxed-inexact-complex-opt-expr)
+           #:with id #'v
+           #:with real-part #'rhs.real-part
+           #:with imag-part #'rhs.imag-part
+           #:with (bindings ...) #'(rhs.bindings ...)))
+(define-syntax-class let-clause ; to turn let-values clauses into let clauses
+  (pattern ((v:id) rhs:expr)
+           #:with res #`(v #,((optimize) #'rhs))))

From e9d9c2aca90d1d974d33ad5cb3cfc9c618b00ea8 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 23 Jul 2010 16:47:30 -0400
Subject: [PATCH 14/20] Added a test to the optimizer.

original commit: ea580e6ff88cb3be758690b99a1968179cbc3c26
---
 collects/tests/typed-scheme/optimizer/generic/let-rhs.rkt | 6 ++++++
 1 file changed, 6 insertions(+)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/let-rhs.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/let-rhs.rkt b/collects/tests/typed-scheme/optimizer/generic/let-rhs.rkt
new file mode 100644
index 00000000..e9f58d5d
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/let-rhs.rkt
@@ -0,0 +1,6 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+(let ((x (+ 1.0 2.0)))
+  x)

From a479e9d5e3fec2052c3e34923d4f58db8d10b36b Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 23 Jul 2010 17:03:02 -0400
Subject: [PATCH 15/20] The optimizer now ignores expressions ignored by the
 typechecker.

original commit: 82b064a520405575ea69e453dfd768ac2df2b17c
---
 collects/typed-scheme/optimizer/optimizer.rkt | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
index d7ea4dff..f5303671 100644
--- a/collects/typed-scheme/optimizer/optimizer.rkt
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -69,7 +69,12 @@
                   (current-output-port))))
     (begin0
       (parameterize ([current-output-port port]
-                     [optimize (syntax-parser [e:opt-expr #'e.opt])])
+                     [optimize (syntax-parser
+                                [e:expr
+                                 #:when (not (syntax-property #'e 'typechecker:ignore))
+                                 #:with e*:opt-expr #'e
+                                 #'e*.opt]
+                                [e:expr #'e])])
         ((optimize) stx))
       (when (and *log-optimizations?*
                  *log-optimizatons-to-log-file?*)

From 5c75aa179336f5355273a76e3e254447ed416f40 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 23 Jul 2010 17:03:53 -0400
Subject: [PATCH 16/20] Fixed typo.

original commit: 12ce9abda6916bd590ac76666a6f3db4a63dd2f3
---
 collects/typed-scheme/optimizer/unboxed-let.rkt | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt
index 40d11cdf..3dbc38ce 100644
--- a/collects/typed-scheme/optimizer/unboxed-let.rkt
+++ b/collects/typed-scheme/optimizer/unboxed-let.rkt
@@ -22,7 +22,7 @@
            #:with ((candidates ...) (others ...))
            (let-values
                (((candidates others)
-                 ;; clauses of form ((v) rhs), currently only suppose 1 lhs var
+                 ;; clauses of form ((v) rhs), currently only supports 1 lhs var
                  (partition (lambda (p)
                               (and (isoftype? (cadr p) -InexactComplex)
                                    (let ((v (car (syntax-e (car p)))))

From 56fde8109f34be0d67812f44f0e66e728ce858ac Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 23 Jul 2010 17:44:53 -0400
Subject: [PATCH 17/20] Fixed unboxing of let bindings.

original commit: 5892ef2fad2c92346cd2871e25846696f3312185
---
 collects/typed-scheme/optimizer/unboxed-let.rkt | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt
index 3dbc38ce..eeaca1e7 100644
--- a/collects/typed-scheme/optimizer/unboxed-let.rkt
+++ b/collects/typed-scheme/optimizer/unboxed-let.rkt
@@ -62,9 +62,9 @@
     (syntax-parse exp
       #:literal-sets (kernel-literals)
       
-      ;; used within a complex arithmetic expression? safe to unbox
+      ;; can be used in a complex arithmetic expr, can be a direct child
       [exp:inexact-complex-arith-opt-expr
-       (direct-child-of? #'exp)]
+       (andmap rec (syntax->list #'exp))]
       
       ;; recur down
       [((~and op (~or (~literal #%plain-lambda) (~literal define-values)))

From 27fe7f732fd2b0c64b6bf3dcc54b9dc4de909716 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 23 Jul 2010 17:51:36 -0400
Subject: [PATCH 18/20] Fixed a test that could not work because of shadowing
 in hand-optimized code.

original commit: 5d86813267521e3191b91e884418ac39bdb3a8e2
---
 collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt b/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt
index bbdf3f63..bfa8fff1 100644
--- a/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt
+++ b/collects/tests/typed-scheme/optimizer/generic/unboxed-let.rkt
@@ -4,5 +4,5 @@
 
 (let* ((t1 (+ 1.0+2.0i 2.0+4.0i))
        (t2 (- t1 3.0+6.0i))
-       (t3 (- t1 4.0+8.0i)))
+       (t3 4.0+8.0i))
   (+ t2 t3))

From ea0d96e9ddc23a0c20a561b7e04587d13d6ac81d Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 23 Jul 2010 18:35:36 -0400
Subject: [PATCH 19/20] The optimizer now ignores code that is inside a
 with-handlers form, since it would be typechecked in an unusual manner.

original commit: 80b6ef7dd19e7d094578ae176442ee3fa8047b96
---
 collects/typed-scheme/optimizer/optimizer.rkt | 44 +++++++++++++------
 1 file changed, 30 insertions(+), 14 deletions(-)

diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt
index f5303671..eb07adcd 100644
--- a/collects/typed-scheme/optimizer/optimizer.rkt
+++ b/collects/typed-scheme/optimizer/optimizer.rkt
@@ -37,27 +37,42 @@
   
   ;; boring cases, just recur down
   (pattern ((~and op (~or (~literal #%plain-lambda) (~literal define-values)))
-            formals e:opt-expr ...)
-           #:with opt #'(op formals e.opt ...))
-  (pattern (case-lambda [formals e:opt-expr ...] ...)
-           #:with opt #'(case-lambda [formals e.opt ...] ...))
+            formals e:expr ...)
+           #:with opt #`(op formals #,@(map (optimize) (syntax->list #'(e ...)))))
+  (pattern (case-lambda [formals e:expr ...] ...)
+           ;; optimize all the bodies
+           #:with (opt-parts ...)
+           (map (lambda (part)
+                  (let ((l (syntax->list part)))
+                    (cons (car l)
+                          (map (optimize) (cdr l)))))
+                (syntax->list #'([formals e ...] ...)))
+           #:with opt #'(case-lambda opt-parts ...))
   (pattern ((~and op (~or (~literal let-values) (~literal letrec-values)))
-            ([ids e-rhs:opt-expr] ...) e-body:opt-expr ...)
-           #:with opt #'(op ([ids e-rhs.opt] ...) e-body.opt ...))
+            ([ids e-rhs:expr] ...) e-body:expr ...)
+           #:with (opt-rhs ...) (map (optimize) (syntax->list #'(e-rhs ...)))
+           #:with opt #`(op ([ids opt-rhs] ...)
+                            #,@(map (optimize) (syntax->list #'(e-body ...)))))
   (pattern (letrec-syntaxes+values stx-bindings
-                                   ([(ids ...) e-rhs:opt-expr] ...)
-                                   e-body:opt-expr ...)
-           #:with opt #'(letrec-syntaxes+values stx-bindings
-                                                ([(ids ...) e-rhs.opt] ...)
-                                                e-body.opt ...))
+                                   ([(ids ...) e-rhs:expr] ...)
+                                   e-body:expr ...)
+           ;; optimize all the rhss
+           #:with (opt-clauses ...)
+           (map (lambda (clause)
+                  (let ((l (syntax->list clause)))
+                    (list (car l) ((optimize) (cadr l)))))
+                (syntax->list #'([(ids ...) e-rhs] ...)))
+           #:with opt #`(letrec-syntaxes+values
+                         stx-bindings
+                         (opt-clauses ...)
+                         #,@(map (optimize) (syntax->list #'(e-body ...)))))
   (pattern (kw:identifier expr ...)
            #:when 
 	   (for/or ([k (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression
 			     #'#%variable-reference #'with-continuation-mark)])
 	     (free-identifier=? k #'kw))
            ;; we don't want to optimize in the cases that don't match the #:when clause
-           #:with (expr*:opt-expr ...) #'(expr ...)
-           #:with opt #'(kw expr*.opt ...))
+           #:with opt #`(kw #,@(map (optimize) (syntax->list #'(expr ...)))))
   (pattern other:expr
            #:with opt #'other))
 
@@ -71,7 +86,8 @@
       (parameterize ([current-output-port port]
                      [optimize (syntax-parser
                                 [e:expr
-                                 #:when (not (syntax-property #'e 'typechecker:ignore))
+                                 #:when (and (not (syntax-property #'e 'typechecker:ignore))
+                                             (not (syntax-property #'e 'typechecker:with-handlers)))
                                  #:with e*:opt-expr #'e
                                  #'e*.opt]
                                 [e:expr #'e])])

From a248746a2d8d7e1cd1bbdce9352c47ab0cd720ea Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Sat, 24 Jul 2010 17:01:07 -0400
Subject: [PATCH 20/20] Added one more test for unboxed let bindings.

original commit: ec39ea5f3352068497a97c959e72814fab7089d0
---
 .../tests/typed-scheme/optimizer/generic/unboxed-let2.rkt  | 7 +++++++
 1 file changed, 7 insertions(+)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/unboxed-let2.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/unboxed-let2.rkt b/collects/tests/typed-scheme/optimizer/generic/unboxed-let2.rkt
new file mode 100644
index 00000000..f5f8c2a5
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/unboxed-let2.rkt
@@ -0,0 +1,7 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+(let ((t1 (+ 1.0+2.0i 2.0+4.0i))
+      (t2 (+ 3.0+6.0i 4.0+8.0i)))
+  (+ t1 t2))