From 11304827253eb2b88bbf99b1f54f85cf89f2ab96 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 16 Jul 2010 15:24:23 -0400
Subject: [PATCH 01/12] Documented the optimizer. (cherry picked from commit
 8d6230956dc8c207c097a389fa1f0c7273bb55b7)

original commit: 536551ce5ec30081a4823a21512e8ecbfc448bbf
---
 .../scribblings/optimization.scrbl            | 21 +++++++++++++++++++
 .../typed-scheme/scribblings/ts-guide.scrbl   |  1 +
 .../scribblings/ts-reference.scrbl            | 13 ++++++++++++
 3 files changed, 35 insertions(+)
 create mode 100644 collects/typed-scheme/scribblings/optimization.scrbl

diff --git a/collects/typed-scheme/scribblings/optimization.scrbl b/collects/typed-scheme/scribblings/optimization.scrbl
new file mode 100644
index 00000000..e7d70054
--- /dev/null
+++ b/collects/typed-scheme/scribblings/optimization.scrbl
@@ -0,0 +1,21 @@
+#lang scribble/manual
+
+@begin[(require (for-label (only-meta-in 0 typed/racket)) scribble/eval
+		"utils.rkt" (only-in "quick.scrbl" typed-mod))]
+
+@(define the-eval (make-base-eval))
+@(the-eval '(require typed/racket))
+
+@title[#:tag "optimization"]{Optimization in Typed Racket}
+
+Typed Racket provides a type-driven optimizer that rewrites well-typed
+programs to potentially make them faster. It should in no way make
+your programs slower or unsafe.
+
+@section{Using the optimizer}
+
+Typed Racket's optimizer is not currently turned on by default. If you
+want to activate it, you must add the @racket[#:optimize] keyword when
+specifying the language of your program:
+
+@racketmod[typed/racket #:optimize]
diff --git a/collects/typed-scheme/scribblings/ts-guide.scrbl b/collects/typed-scheme/scribblings/ts-guide.scrbl
index 1c58c25c..948f7dbe 100644
--- a/collects/typed-scheme/scribblings/ts-guide.scrbl
+++ b/collects/typed-scheme/scribblings/ts-guide.scrbl
@@ -19,6 +19,7 @@ with Racket.  For an introduction to Racket, see the @(other-manual '(lib "scrib
 @include-section["begin.scrbl"]
 @include-section["more.scrbl"]
 @include-section["types.scrbl"]
+@include-section["optimization.scrbl"]
 
 @;@section{How the Type System Works}
 
diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl
index 4e063ef2..4b546d66 100644
--- a/collects/typed-scheme/scribblings/ts-reference.scrbl
+++ b/collects/typed-scheme/scribblings/ts-reference.scrbl
@@ -603,4 +603,17 @@ have the types ascribed to them; these types are converted to contracts and chec
   (define val 17))
 
 (fun val)]
+
+@section{Optimization in Typed Racket}
+
+Typed Racket provides a type-driven optimizer that rewrites well-typed
+programs to potentially make them faster. It should in no way make
+your programs slower or unsafe.
+
+Typed Racket's optimizer is not currently turned on by default. If you
+want to activate it, you must add the @racket[#:optimize] keyword when
+specifying the language of your program:
+
+@racketmod[typed/racket #:optimize]
+
 }

From 0161cda2d40715f3a4c156c209a2f119d8f6f778 Mon Sep 17 00:00:00 2001
From: Stevie Strickland <sstrickl@racket-lang.org>
Date: Fri, 16 Jul 2010 16:57:29 -0400
Subject: [PATCH 02/12] Two fixes in overlap checking.

 - Names were not being resolved, so a superstruct name and substruct name
   could be seen as non-overlapping.
 - Struct parents were not checked in the overlapping algorithm.
(cherry picked from commit 654b7df1decd52763ffedcdc507a4bf367b1cecf)

original commit: 3884d5661022ef970a77f127e7a58d052760d635
---
 .../typed-scheme/types/remove-intersect.rkt   | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt
index a646a54c..074af5da 100644
--- a/collects/typed-scheme/types/remove-intersect.rkt
+++ b/collects/typed-scheme/types/remove-intersect.rkt
@@ -23,7 +23,8 @@
          [(list _ (Univ:)) #t]
          [(list (F: _) _) #t]
          [(list _ (F: _)) #t]
-         [(list (Name: n) (Name: n*)) (free-identifier=? n n*)]
+         [(list (Name: n) (Name: n*)) 
+          (overlap (resolve-once t1) (resolve-once t2))]
          [(list (? Mu?) _) (overlap (unfold t1) t2)]
          [(list _ (? Mu?)) (overlap t1 (unfold t2))]
          [(list (Union: e) t)
@@ -68,12 +69,16 @@
          [(list (Struct: n #f flds _ _ _ _ _)
                 (StructTop: (Struct: n* #f flds* _ _ _ _ _)))
           #f]
-         [(list (Struct: n p flds _ _ _ _ _)
-                (Struct: n* p* flds* _ _ _ _ _))
-          (and (= (length flds) (length flds*)) 
-               (for/and ([f flds] [f* flds*]) 
-                 (match* (f f*)
-                   [((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))]
+         [(list (and t1 (Struct: n p flds _ _ _ _ _))
+                (and t2 (Struct: n* p* flds* _ _ _ _ _)))
+          (let ([p1 (if (Name? p) (resolve-name p) p)]
+                [p2 (if (Name? p*) (resolve-name p*) p*)])
+            (or (overlap t1 p2)
+                (overlap t2 p1)
+                (and (= (length flds) (length flds*)) 
+                     (for/and ([f flds] [f* flds*]) 
+                       (match* (f f*)
+                               [((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))))]
          [(list (== (-val eof))
                 (Function: _))
           #f]

From b71fbae36a7d6c51d7814d545d60e476a8c7efec Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Fri, 16 Jul 2010 18:16:51 -0400
Subject: [PATCH 03/12] Further fixes in overlap checking.

Rhss of code dispatching on overlapping structs are no longer
considered dead, and as such, are now typechecked.

Had to fix a test that passed only because some not-really-dead code
was not being typechecked.
(cherry picked from commit 4d5b50dee9e04aee167a7e04fbbe23526131fcad)

original commit: e0614cfed24dfc9e7f89b9a8c77e7930695b0269
---
 .../typed-scheme/fail/dead-substruct.rkt      |  16 +++
 .../optimizer/generic/dead-substructs.rkt     |  17 +++
 .../typed-scheme/succeed/priority-queue.scm   |  18 ++--
 .../typed-scheme/xfail/priority-queue.scm     | 101 ++++++++++++++++++
 .../typed-scheme/types/remove-intersect.rkt   |   7 +-
 5 files changed, 147 insertions(+), 12 deletions(-)
 create mode 100644 collects/tests/typed-scheme/fail/dead-substruct.rkt
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt
 create mode 100644 collects/tests/typed-scheme/xfail/priority-queue.scm

diff --git a/collects/tests/typed-scheme/fail/dead-substruct.rkt b/collects/tests/typed-scheme/fail/dead-substruct.rkt
new file mode 100644
index 00000000..eed75288
--- /dev/null
+++ b/collects/tests/typed-scheme/fail/dead-substruct.rkt
@@ -0,0 +1,16 @@
+#;
+(exn-pred 1)
+#lang typed/scheme
+
+(define-struct: parent ((x : Integer)))
+(define-struct: (child1 parent) ((y : Integer)))
+(define-struct: (child2 parent) ((y : Float)))
+
+(: f (parent -> Integer))
+(define (f x)
+  (cond [(child1? x) (+ "a" "b")] ; rhs was considered dead code
+        [(child2? x) 2]
+        [else (error "eh?")]))
+
+(f (make-child1 1 2))
+(f (make-child2 1 2.0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt b/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt
new file mode 100644
index 00000000..a01a5e5b
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt
@@ -0,0 +1,17 @@
+#lang typed/scheme #:optimize
+
+;; originally from nucleic3
+;; cond on substructs, branches were considered dead
+
+(define-struct: parent ((x : Integer)))
+(define-struct: (child1 parent) ((y : Integer)))
+(define-struct: (child2 parent) ((y : Float)))
+
+(: f (parent -> Integer))
+(define (f x)
+  (cond [(child1? x) 1]
+        [(child2? x) 2]
+        [else (error "eh?")]))
+
+(f (make-child1 1 2))
+(f (make-child2 1 2.0))
diff --git a/collects/tests/typed-scheme/succeed/priority-queue.scm b/collects/tests/typed-scheme/succeed/priority-queue.scm
index 091a284d..9454a314 100644
--- a/collects/tests/typed-scheme/succeed/priority-queue.scm
+++ b/collects/tests/typed-scheme/succeed/priority-queue.scm
@@ -65,15 +65,15 @@
 ;; "bug" found - handling of empty heaps
 (pdefine: (a) (find-min [pq : (priority-queue a)]) : a 
 	  (let ([h (heap pq)])
-	    (if (heap:heap-node? h)
-		(elm (heap:find-min h))
-		(error "priority queue empty"))))
+            (if (heap:empty? h)
+                (error "priority queue empty")
+                (elm (heap:find-min h)))))
 
 (pdefine: (a) (find-min-priority [pq : (priority-queue a)]) : number
 	  (let ([h (heap pq)])
-	    (if (heap:heap-node? h)
-		(pri (heap:find-min h))
-		(error "priority queue empty"))))
+	    (if (heap:empty? h)
+		(error "priority queue empty")
+                (pri (heap:find-min h)))))
 
 (pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a)
 	  (make (heap:insert (cons p x) (heap pq))))
@@ -84,9 +84,9 @@
 
 (pdefine: (a) (delete-min [pq : (priority-queue a)]) : (priority-queue a)
 	  (let ([h (heap pq)])
-	    (if (heap:heap-node? h)
-		(make (heap:delete-min h))
-		(error "priority queue empty"))))
+	    (if (heap:empty? h)
+                (error "priority queue empty")
+		(make (heap:delete-min h)))))
 
 
 (pdefine: (a) (size [pq : (priority-queue a)]) : number
diff --git a/collects/tests/typed-scheme/xfail/priority-queue.scm b/collects/tests/typed-scheme/xfail/priority-queue.scm
new file mode 100644
index 00000000..091a284d
--- /dev/null
+++ b/collects/tests/typed-scheme/xfail/priority-queue.scm
@@ -0,0 +1,101 @@
+#lang typed-scheme
+;;; priority-queue.scm  --  Jens Axel Søgaard
+;;; PURPOSE
+
+; This file implements priority queues on top of
+; a heap library.
+(define-type-alias number Number)
+(define-type-alias boolean Boolean)
+(define-type-alias symbol Symbol)
+(define-type-alias top Any)
+(define-type-alias list-of Listof)
+(require (prefix-in heap: "leftist-heap.ss")
+	 (except-in (lib "67.ss" "srfi") number-compare current-compare =? <?)
+	 (only-in "leftist-heap.ss" comparator))
+(require/typed number-compare (number number -> number) (lib "67.ss" "srfi"))
+(require/typed current-compare (-> (top top -> number)) (lib "67.ss" "srfi"))
+(require/typed =? ((top top -> number) top top -> boolean) (lib "67.ss" "srfi"))
+(require/typed <? ((top top -> number) top top -> boolean) (lib "67.ss" "srfi"))
+
+; a priority-queue is a heap of  (cons <priority> <element>)
+
+(define-type-alias (elem a) (cons number a))
+
+(define-typed-struct (a) priority-queue ([heap : (heap:Heap (elem a))]))
+
+(define-type-alias (pqh a) (heap:Heap (elem a)))
+
+; conveniences
+(pdefine: (a) (heap [pq : (priority-queue a)]) : (pqh a) (priority-queue-heap pq))
+(pdefine: (a) (pri [p : (elem a)]) : number (car p))
+(pdefine: (a) (elm [p : (elem a)]) : a  (cdr p))
+(pdefine: (a) (make [h : (pqh a)]) : (priority-queue a)  (make-priority-queue h))
+
+; sort after priority
+; TODO: and then element?
+(pdefine: (a) (compare [p1 : (elem a)] [p2 : (elem a)]) : number
+	  (number-compare (pri p1) (pri p2)))
+
+;;; OPERATIONS
+
+(define: (num-elems [h : (heap:Heap (cons number number))]) : (list-of (cons number number))
+  (heap:elements h))
+
+(pdefine: (a) (elements [pq : (priority-queue a)]) : (list-of a)
+          (map #{elm :: ((elem a) -> a)} (heap:elements (heap pq))))
+
+(pdefine: (a) (elements+priorities [pq : (priority-queue a)]) : (values (list-of a) (list-of number))
+	  (let: ([eps : (list-of (elem a)) (heap:elements (heap pq))])
+		(values (map #{elm :: ((elem a) -> a)} eps)
+			(map #{pri :: ((elem a) -> number)} eps))))
+
+(pdefine: (a) (empty? [pq : (priority-queue a)]) : boolean
+	  (heap:empty? (heap pq)))
+
+(define: empty : (All (a) (case-lambda (-> (priority-queue a)) (comparator -> (priority-queue a))))
+  (pcase-lambda: (a)
+		 [()    (#{empty @ a} (current-compare))]
+		 [([cmp : comparator]) (make (#{heap:empty :: (case-lambda (-> (pqh a))
+									   (comparator -> (pqh a)))} cmp))]))
+
+(pdefine: (e r) (fold [f : ((cons number e) r -> r)] [b : r] [a : (priority-queue e)]) : r
+	  (heap:fold f b (#{heap :: ((priority-queue e) -> (pqh e))} a)))
+
+
+;; "bug" found - handling of empty heaps
+(pdefine: (a) (find-min [pq : (priority-queue a)]) : a 
+	  (let ([h (heap pq)])
+	    (if (heap:heap-node? h)
+		(elm (heap:find-min h))
+		(error "priority queue empty"))))
+
+(pdefine: (a) (find-min-priority [pq : (priority-queue a)]) : number
+	  (let ([h (heap pq)])
+	    (if (heap:heap-node? h)
+		(pri (heap:find-min h))
+		(error "priority queue empty"))))
+
+(pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a)
+	  (make (heap:insert (cons p x) (heap pq))))
+
+;; FIXME -- too many annotations needed on cons
+(pdefine: (a) (insert* [xs : (list-of a)] [ps : (list-of number)] [pq : (priority-queue a)]) : (priority-queue a)
+          (make (heap:insert* (map #{cons @ number a} ps xs) (heap pq))))
+
+(pdefine: (a) (delete-min [pq : (priority-queue a)]) : (priority-queue a)
+	  (let ([h (heap pq)])
+	    (if (heap:heap-node? h)
+		(make (heap:delete-min h))
+		(error "priority queue empty"))))
+
+
+(pdefine: (a) (size [pq : (priority-queue a)]) : number
+	  (heap:size (heap pq)))
+
+(pdefine: (a) (union [pq1 : (priority-queue a)] [pq2 : (priority-queue a)]) : (priority-queue a)
+	  (make (heap:union (heap pq1) (heap pq2))))
+
+
+#;(require "signatures/priority-queue-signature.scm")
+#;(provide-priority-queue)
+
diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt
index 074af5da..64d55e8f 100644
--- a/collects/typed-scheme/types/remove-intersect.rkt
+++ b/collects/typed-scheme/types/remove-intersect.rkt
@@ -24,7 +24,8 @@
          [(list (F: _) _) #t]
          [(list _ (F: _)) #t]
          [(list (Name: n) (Name: n*)) 
-          (overlap (resolve-once t1) (resolve-once t2))]
+          (or (free-identifier=? n n*)
+              (overlap (resolve-once t1) (resolve-once t2)))]
          [(list (? Mu?) _) (overlap (unfold t1) t2)]
          [(list _ (? Mu?)) (overlap t1 (unfold t2))]
          [(list (Union: e) t)
@@ -73,8 +74,8 @@
                 (and t2 (Struct: n* p* flds* _ _ _ _ _)))
           (let ([p1 (if (Name? p) (resolve-name p) p)]
                 [p2 (if (Name? p*) (resolve-name p*) p*)])
-            (or (overlap t1 p2)
-                (overlap t2 p1)
+            (or (and p2 (overlap t1 p2))
+                (and p1 (overlap t2 p1))
                 (and (= (length flds) (length flds*)) 
                      (for/and ([f flds] [f* flds*]) 
                        (match* (f f*)

From 34d7dda8440c77e5cc0cbfe1f760a341b56693c5 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 8 Jul 2010 18:29:02 -0400
Subject: [PATCH 04/12] Added a test for cross-module struct optimization.
 (cherry picked from commit 4e6fc3154bd286d3edcd36a25bfc672cc6a0659d)

original commit: 8f47f0019fae4faf0ea8bb09d7fbd3b3e06254df
---
 .../optimizer/generic/cross-module-struct.rkt         |  5 +++++
 .../optimizer/generic/cross-module-struct2.rkt        |  5 +++++
 collects/tests/typed-scheme/optimizer/run.rkt         | 11 ++++++++---
 3 files changed, 18 insertions(+), 3 deletions(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt b/collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt
new file mode 100644
index 00000000..7b52b214
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt
@@ -0,0 +1,5 @@
+#lang typed/scheme #:optimize
+
+;; will be imported by cross-module-struct2
+(provide (struct-out x))
+(define-struct: x ((x : Integer)))
diff --git a/collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt b/collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt
new file mode 100644
index 00000000..45a1696e
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt
@@ -0,0 +1,5 @@
+#lang typed/scheme #:optimize
+
+(require (file "cross-module-struct.rkt") racket/unsafe/ops)
+(define a (make-x 1))
+(x-x a)
diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt
index b4139e25..6edd366d 100644
--- a/collects/tests/typed-scheme/optimizer/run.rkt
+++ b/collects/tests/typed-scheme/optimizer/run.rkt
@@ -15,7 +15,8 @@
    (match-lambda [(list 'define-values-for-syntax '() _ ...) #f] [_ #t])
    (cadddr
     (syntax->datum
-     (parameterize ([current-namespace (make-base-namespace)])
+     (parameterize ([current-namespace (make-base-namespace)]
+                    [read-accept-reader #t])
        (with-handlers
            ([exn:fail? (lambda (exn)
                          (printf "~a\n" (exn-message exn))
@@ -25,8 +26,12 @@
 (define (test gen)
   (let-values (((base name _) (split-path gen)))
     (or (regexp-match ".*~" name) ; we ignore backup files
-        (equal? (read-and-expand gen)
-                (read-and-expand (build-path base "../hand-optimized/" name)))
+        (equal? (parameterize ([current-load-relative-directory
+                                (build-path here "generic")])
+                  (read-and-expand gen))
+                (let ((hand-opt-dir (build-path here "hand-optimized")))
+                  (parameterize ([current-load-relative-directory hand-opt-dir])
+                    (read-and-expand (build-path hand-opt-dir name)))))
         (begin (printf "~a failed\n\n" name)
                #f))))
 

From 4c41407d64ad7e279afa32c8da287afdc58d8a37 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Tue, 3 Aug 2010 15:31:38 -0400
Subject: [PATCH 05/12] Added optimization for make-polar

original commit: fb31a6556e04d9aa6aa31c215394a80b9d146bd7
---
 .../optimizer/generic/invalid-make-polar.rkt  |  3 +++
 .../optimizer/generic/make-polar.rkt          |  9 +++++++
 .../optimizer/inexact-complex.rkt             | 24 ++++++++++++++++++-
 3 files changed, 35 insertions(+), 1 deletion(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-make-polar.rkt
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/make-polar.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-make-polar.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-make-polar.rkt
new file mode 100644
index 00000000..f6a646b6
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/invalid-make-polar.rkt
@@ -0,0 +1,3 @@
+#lang typed/scheme #:optimize
+
+(make-polar 0 0)
diff --git a/collects/tests/typed-scheme/optimizer/generic/make-polar.rkt b/collects/tests/typed-scheme/optimizer/generic/make-polar.rkt
new file mode 100644
index 00000000..137f0b17
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/make-polar.rkt
@@ -0,0 +1,9 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+;; top level
+(make-polar 1.0 1.0)
+
+;; nested
+(+ 1.0+2.0i (make-polar 2.0 4.0))
diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt
index d18ac9f0..5fed8415 100644
--- a/collects/typed-scheme/optimizer/inexact-complex.rkt
+++ b/collects/typed-scheme/optimizer/inexact-complex.rkt
@@ -232,8 +232,20 @@
            #:with imag-binding (unboxed-gensym)
            #:with (bindings ...)
            (begin (log-optimization "make-rectangular elimination" #'op)
-                  #`(((real-binding) real.opt)
+                  #'(((real-binding) real.opt)
                      ((imag-binding) imag.opt))))
+  (pattern (#%plain-app (~and op (~literal make-polar))
+                        r:float-coerce-expr theta:float-coerce-expr)
+           #:with magnitude    (unboxed-gensym)
+           #:with angle        (unboxed-gensym)
+           #:with real-binding (unboxed-gensym)
+           #:with imag-binding (unboxed-gensym)
+           #:with (bindings ...)
+           (begin (log-optimization "make-rectangular elimination" #'op)
+                  #'(((magnitude)    r.opt)
+                     ((angle)        theta.opt)
+                     ((real-binding) (unsafe-fl* magnitude (unsafe-flcos angle)))
+                     ((imag-binding) (unsafe-fl* magnitude (unsafe-flsin angle))))))
 
   ;; if we see a variable that's already unboxed, use the unboxed bindings
   (pattern v:id
@@ -308,6 +320,16 @@
            (begin (log-optimization "unary inexact complex" #'op)
                   #'(op.unsafe n.opt)))
 
+  (pattern (~and exp (#%plain-app (~and op (~literal make-polar)) r theta))
+           #:when (isoftype? #'exp -InexactComplex)
+           #:with exp*:unboxed-inexact-complex-opt-expr #'exp
+           #:with opt
+           (begin (log-optimization "make-polar" #'op)
+                  (reset-unboxed-gensym)
+                  #'(let*-values (exp*.bindings ...)
+                      (unsafe-make-flrectangular exp*.real-binding
+                                                 exp*.imag-binding))))
+
   (pattern (~and e (#%plain-app op:id args:expr ...))
            #:with unboxed-info (dict-ref unboxed-funs-table #'op #f)
            #:when (syntax->datum #'unboxed-info)

From 82340857d96691e3749ac45e740059df0cee3948 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Tue, 3 Aug 2010 16:55:03 -0400
Subject: [PATCH 06/12] Optimize coercion of integer literals.

original commit: bdf84f371d4ccf952e08251703a4249c37f81a85
---
 .../typed-scheme/optimizer/generic/float-promotion.rkt     | 2 +-
 .../optimizer/generic/inexact-complex-fixnum.rkt           | 2 +-
 .../tests/typed-scheme/optimizer/generic/literal-int.rkt   | 6 ++++++
 collects/typed-scheme/optimizer/float.rkt                  | 7 ++++++-
 4 files changed, 14 insertions(+), 3 deletions(-)
 create mode 100644 collects/tests/typed-scheme/optimizer/generic/literal-int.rkt

diff --git a/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt
index 1fc32fa9..09d106f4 100644
--- a/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt
+++ b/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt
@@ -1,4 +1,4 @@
 (module float-promotion typed/scheme #:optimize
   (require racket/unsafe/ops racket/flonum)
-  (+ 1 2.0)
+  (+ (quotient 1 1) 2.0)
   (+ (expt 100 100) 2.0))
diff --git a/collects/tests/typed-scheme/optimizer/generic/inexact-complex-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-fixnum.rkt
index 3f99e881..796242a9 100644
--- a/collects/tests/typed-scheme/optimizer/generic/inexact-complex-fixnum.rkt
+++ b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-fixnum.rkt
@@ -1,3 +1,3 @@
 #lang typed/scheme #:optimize
 (require racket/unsafe/ops)
-(+ 2 1.0+2.0i 3.0+6.0i)
+(+ (quotient 2 1) 1.0+2.0i 3.0+6.0i)
diff --git a/collects/tests/typed-scheme/optimizer/generic/literal-int.rkt b/collects/tests/typed-scheme/optimizer/generic/literal-int.rkt
new file mode 100644
index 00000000..6d6d6b8a
--- /dev/null
+++ b/collects/tests/typed-scheme/optimizer/generic/literal-int.rkt
@@ -0,0 +1,6 @@
+#lang typed/scheme #:optimize
+
+(require racket/unsafe/ops)
+
+(+ 1 2.0)
+1
diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt
index 17917d44..334b3600 100644
--- a/collects/typed-scheme/optimizer/float.rkt
+++ b/collects/typed-scheme/optimizer/float.rkt
@@ -1,7 +1,7 @@
 #lang scheme/base
 
 (require syntax/parse
-         syntax/id-table racket/dict
+         syntax/id-table racket/dict scheme/flonum
          (for-template scheme/base scheme/flonum scheme/unsafe/ops)
          "../utils/utils.rkt"
          (types abbrev type-table utils subtype)
@@ -59,6 +59,11 @@
 ;; note: none of the unary operations have types where non-float arguments
 ;;  can result in float (as opposed to real) results
 (define-syntax-class float-arg-expr
+  ;; we can convert literals right away
+  (pattern (quote n)
+           #:when (exact-integer? (syntax->datum #'n))
+           #:with opt
+           (datum->syntax #'here (->fl (syntax->datum #'n))))
   (pattern e:fixnum-expr
            #:with opt #'(unsafe-fx->fl e.opt))
   (pattern e:int-expr

From d65ea9ef3862ace67f942711b794c296e400cb43 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 4 Aug 2010 11:02:33 -0400
Subject: [PATCH 07/12] Unbox literals at expansion time.

original commit: 1105e70b302416c40269c11e60d7ddaa3d14b66e
---
 .../optimizer/inexact-complex.rkt             | 27 ++++++++++++++++++-
 1 file changed, 26 insertions(+), 1 deletion(-)

diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt
index 5fed8415..d74a9ea6 100644
--- a/collects/typed-scheme/optimizer/inexact-complex.rkt
+++ b/collects/typed-scheme/optimizer/inexact-complex.rkt
@@ -255,7 +255,32 @@
            #:with imag-binding (cadr (syntax->list #'unboxed-info))
            #:with (bindings ...) #'())
   
-  ;; else, do the unboxing here  
+  ;; else, do the unboxing here
+
+  ;; we can unbox literals right away
+  (pattern (quote n)
+           #:when (let ((x (syntax->datum #'n)))
+                    (and (number? x)
+                         (not (eq? (imag-part x) 0))))
+           #:with real-binding (unboxed-gensym)
+           #:with imag-binding (unboxed-gensym)
+           #:with (bindings ...)
+           (let ((n (syntax->datum #'n)))
+             #`(((real-binding) #,(datum->syntax
+                                   #'here
+                                   (exact->inexact (real-part n))))
+                ((imag-binding) #,(datum->syntax
+                                   #'here
+                                   (exact->inexact (imag-part n)))))))
+  (pattern (quote n)
+           #:when (real? (syntax->datum #'n))
+           #:with real-binding (unboxed-gensym)
+           #:with imag-binding #f
+           #:with (bindings ...)
+           #`(((real-binding) #,(datum->syntax
+                                 #'here
+                                 (exact->inexact (syntax->datum #'n))))))
+  
   (pattern e:expr
            #:when (isoftype? #'e -InexactComplex)
            #:with e* (unboxed-gensym)

From d1e64146d46945390893d71fb48f8e039be609ad Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 4 Aug 2010 13:17:15 -0400
Subject: [PATCH 08/12] Fixed parsing of keyword types.

original commit: 416591b35532d117bb70acf7a8282329b626c27b
---
 collects/typed-scheme/private/parse-type.rkt | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt
index bff49836..6005433a 100644
--- a/collects/typed-scheme/private/parse-type.rkt
+++ b/collects/typed-scheme/private/parse-type.rkt
@@ -88,6 +88,13 @@
   (pattern (~seq [k:keyword t:expr])
            #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f)))
 
+(define-syntax-class non-keyword-ty
+  (pattern (k e:expr ...)
+           #:when (not (keyword? (syntax->datum #'k))))
+  (pattern t:expr
+           #:when (and (not (keyword? (syntax->datum #'t)))
+                       (not (syntax->list #'t)))))
+
 (define-syntax-class path-elem
   #:description "path element"
   #:literals (car cdr)
@@ -214,7 +221,7 @@
        (add-type-name-reference #'kw)
        ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
        (make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (attribute latent.type) 0 (attribute latent.path))]
-      [(dom:expr ... rest:expr ddd:star kws:keyword-tys ... (~and kw t:->) rng)
+      [(dom:non-keyword-ty ... rest:non-keyword-ty ddd:star kws:keyword-tys ... (~and kw t:->) rng)
        (add-type-name-reference #'kw)
        (make-Function
         (list (make-arr
@@ -222,7 +229,7 @@
                (parse-values-type #'rng)
                #:rest (parse-type #'rest)
                #:kws (attribute kws.Keyword))))]
-      [(dom:expr ... rest:expr :ddd/bound (~and kw t:->) rng)
+      [(dom:non-keyword-ty ... rest:non-keyword-ty :ddd/bound (~and kw t:->) rng)
        (add-type-name-reference #'kw)
        (let* ([bnd (syntax-e #'bound)])
          (unless (bound-index? bnd)
@@ -236,7 +243,7 @@
                           (extend-tvars (list bnd)
                             (parse-type #'rest))
                           bnd))))]
-      [(dom:expr ... rest:expr _:ddd (~and kw t:->) rng)
+      [(dom:non-keyword-ty ... rest:non-keyword-ty _:ddd (~and kw t:->) rng)
        (add-type-name-reference #'kw)
        (let ([var (infer-index stx)])
          (make-Function
@@ -251,7 +258,7 @@
       (->* (map parse-type (syntax->list #'(dom ...)))
            (parse-values-type #'rng))]     |#
       ;; use expr to rule out keywords
-      [(dom:expr ... kws:keyword-tys ... (~and kw t:->) rng)
+      [(dom:non-keyword-ty ... kws:keyword-tys ... (~and kw t:->) rng)
        (add-type-name-reference #'kw)
       (let ([doms (for/list ([d (syntax->list #'(dom ...))])
                     (parse-type d))])

From a29f10633f5ff7434b1ae25972b04c3c8962c8a4 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 4 Aug 2010 15:08:27 -0400
Subject: [PATCH 09/12] Added another tracing option to TR.

original commit: 0b3c637f5d5215e3fced3e83433119524145b488
---
 collects/typed-scheme/tc-setup.rkt    | 3 +++
 collects/typed-scheme/utils/utils.rkt | 3 ++-
 2 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt
index e3288fe8..04f05fdb 100644
--- a/collects/typed-scheme/tc-setup.rkt
+++ b/collects/typed-scheme/tc-setup.rkt
@@ -3,6 +3,7 @@
 (require (rename-in "utils/utils.rkt" [infer r:infer])
          (except-in syntax/parse id)
          unstable/mutated-vars
+         racket/pretty
          scheme/base
          (private type-contract)
          (types utils convenience)
@@ -51,6 +52,8 @@
                      [type-name-references null])
         (do-time "Initialized Envs")
         (let ([fully-expanded-stx (local-expand stx expand-ctxt null)])
+          (when (show-input?)
+            (pretty-print (syntax->datum fully-expanded-stx)))
           (do-time "Local Expand Done")
           (parameterize ([mutated-vars (find-mutated-vars fully-expanded-stx)]
                          [orig-module-stx (or (orig-module-stx) orig-stx)]
diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt
index afed7b55..47c621d1 100644
--- a/collects/typed-scheme/utils/utils.rkt
+++ b/collects/typed-scheme/utils/utils.rkt
@@ -19,7 +19,7 @@ at least theoretically.
  ;; timing
  start-timing do-time  
  ;; logging
- printf/log
+ printf/log show-input?
  ;; struct printing
  custom-printer define-struct/printer
  ;; provide macros
@@ -27,6 +27,7 @@ at least theoretically.
 
 (define optimize? (make-parameter #f))
 (define-for-syntax enable-contracts? #f)
+(define show-input? (make-parameter #f))
 
 ;; fancy require syntax
 (define-syntax (define-requirer stx)

From ece22fd4fd7c0680f9c2e8b7a52b3ef81263071f Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 4 Aug 2010 15:52:41 -0400
Subject: [PATCH 10/12] Added opt-lambda:.

original commit: 4cb749130954c821754fd976d92c02aca2013429
---
 .../typed-scheme/private/annotate-classes.rkt | 22 +++++++++++++++++++
 collects/typed-scheme/private/prims.rkt       | 15 +++++++++++++
 2 files changed, 37 insertions(+)

diff --git a/collects/typed-scheme/private/annotate-classes.rkt b/collects/typed-scheme/private/annotate-classes.rkt
index e9d65a81..92c788cd 100644
--- a/collects/typed-scheme/private/annotate-classes.rkt
+++ b/collects/typed-scheme/private/annotate-classes.rkt
@@ -63,3 +63,25 @@
                                               (~or rest:annotated-star-rest rest:annotated-dots-rest)))
            #:with ann-formals #'(n.ann-name ... . rest.ann-name)
            #:with (arg-ty ...) #'(n.ty ... . rest.formal-ty)))
+
+(define-syntax-class opt-lambda-annotated-formal
+  #:description "annotated variable, potentially with a default value"
+  #:opaque
+  #:attributes (name ty ann-name)
+  (pattern [:annotated-name])
+  (pattern [n:annotated-name val]
+           #:with name #'n.name
+           #:with ty #'n.name
+           #:with ann-name #'(n.ann-name val)))
+
+(define-syntax-class opt-lambda-annotated-formals
+  #:attributes (ann-formals (arg-ty 1))
+  #:literals (:)
+  (pattern (n:opt-lambda-annotated-formal ...)
+           #:with ann-formals #'(n.ann-name ...)
+           #:with (arg-ty ...) #'(n.ty ...))
+  (pattern (n:opt-lambda-annotated-formal ...
+            (~describe "dotted or starred type"
+                       (~or rest:annotated-star-rest rest:annotated-dots-rest)))
+           #:with ann-formals #'(n.ann-name ... . rest.ann-name)
+           #:with (arg-ty ...) #'(n.ty ... . rest.formal-ty)))
diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt
index cef82b22..980675b3 100644
--- a/collects/typed-scheme/private/prims.rkt
+++ b/collects/typed-scheme/private/prims.rkt
@@ -27,6 +27,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
 
 (require "../utils/utils.rkt"
          racket/base
+         mzlib/etc
 	 (for-syntax 
           syntax/parse
 	  syntax/private/util
@@ -173,6 +174,15 @@ This file defines two sorts of primitives. All of them are provided into any mod
                            'typechecker:plambda
                            #'(tvars ...))))]))
 
+(define-syntax (popt-lambda: stx)
+  (syntax-parse stx
+    [(popt-lambda: (tvars:id ...) formals . body)
+     (quasisyntax/loc stx
+       (#%expression
+        #,(syntax-property (syntax/loc stx (opt-lambda: formals . body))
+                           'typechecker:plambda
+                           #'(tvars ...))))]))
+
 (define-syntax (pdefine: stx)
   (syntax-parse stx #:literals (:)
     [(pdefine: (tvars:id ...) (nm:id . formals:annotated-formals) : ret-ty . body)
@@ -223,6 +233,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
     [(case-lambda: [formals:annotated-formals . body] ...)
      (syntax/loc stx (case-lambda [formals.ann-formals . body] ...))]))
 
+(define-syntax (opt-lambda: stx)
+  (syntax-parse stx
+    [(opt-lambda: formals:opt-lambda-annotated-formals . body)
+     (syntax/loc stx (opt-lambda formals.ann-formals . body))]))
+
 (define-syntaxes (let-internal: let*: letrec:)
   (let ([mk (lambda (form)
               (lambda (stx)

From 79f4bcfbdb5c3f5ec690d298438de3d68bcafde7 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 4 Aug 2010 17:13:55 -0400
Subject: [PATCH 11/12] Generalize naturals to integers to minimize annotations
 on mutated variables.

original commit: b18f2353cab9712c827dda692649bcd16bc3e79e
---
 collects/tests/typed-scheme/succeed/metrics.rkt  | 16 ++++++++--------
 .../tests/typed-scheme/succeed/new-metrics.rkt   | 14 +++++++-------
 .../typed-scheme/unit-tests/typecheck-tests.rkt  |  4 ++--
 .../private/base-env-indexing-abs.rkt            |  2 +-
 4 files changed, 18 insertions(+), 18 deletions(-)

diff --git a/collects/tests/typed-scheme/succeed/metrics.rkt b/collects/tests/typed-scheme/succeed/metrics.rkt
index 04a679fb..8839c7dd 100644
--- a/collects/tests/typed-scheme/succeed/metrics.rkt
+++ b/collects/tests/typed-scheme/succeed/metrics.rkt
@@ -84,11 +84,11 @@
            [table
             `((,a-hits ,b-hits)
               (,a-misses ,b-misses))]
-           [expected (lambda: ([i : Natural] [j : Natural])
+           [expected (lambda: ([i : Integer] [j : Integer])
                               (/ (* (row-total i table) (col-total j table)) total-subjects))])
       (exact->inexact 
        (table-sum 
-        (lambda: ([i : Natural] [j : Natural])
+        (lambda: ([i : Integer] [j : Integer])
                  (/ (sqr (- (expected i j) (table-ref i j table))) (expected i j)))
         table)))))
 
@@ -473,7 +473,7 @@
           (show result ))))
 
 ;; applies only to the combined metric [or more generally to listof-answer results]
-(pdefine: (a b c) (total [experiment-number : Natural] [result : (Result (Listof number) b c)]) : (Listof number)
+(pdefine: (a b c) (total [experiment-number : Integer] [result : (Result (Listof number) b c)]) : (Listof number)
           (define: (total/s [s : Table]) : number (apply + (list-ref (pivot s) experiment-number)))
           (list (total/s (result-seqA result)) (total/s (result-seqB result))))
 
@@ -491,7 +491,7 @@
             [(null? l) '()]
             [else
              (let ([n (length (car l))])
-               (build-list n (lambda: ([i : Natural]) (map (lambda: ([j : (Listof X)]) (list-ref j i)) l))))]))
+               (build-list n (lambda: ([i : Integer]) (map (lambda: ([j : (Listof X)]) (list-ref j i)) l))))]))
 
 (define: (sqr [x : Real]) : Real (* x x))
 (define: (variance [xs : (Listof Real)]): Real
@@ -499,13 +499,13 @@
     (/ (apply + (map (lambda: ([x : number]) (sqr (- x avg))) xs))
        (sub1 (length xs)))))
 
-(define: (table-ref [i : Natural] [j : Natural] [table : Table]): number
+(define: (table-ref [i : Integer] [j : Integer] [table : Table]): number
   (list-ref (list-ref table i) j))
-(define: (row-total [i : Natural] [table : Table]) : number
+(define: (row-total [i : Integer] [table : Table]) : number
   (apply + (list-ref table i)))
-(define: (col-total [j : Natural] [table : Table]) : number
+(define: (col-total [j : Integer] [table : Table]) : number
   (apply + (map (lambda: ([x : (Listof number)]) (list-ref x j)) table)))
-(define: (table-sum [f : (Natural Natural -> Real)] [table : Table]) : number
+(define: (table-sum [f : (Integer Integer -> Real)] [table : Table]) : number
   (let ([rows (length table)]
         [cols (length (car table))])
     (let loop ([i 0] [j 0] [#{sum : Real} 0])
diff --git a/collects/tests/typed-scheme/succeed/new-metrics.rkt b/collects/tests/typed-scheme/succeed/new-metrics.rkt
index 5513eda8..4635f79f 100644
--- a/collects/tests/typed-scheme/succeed/new-metrics.rkt
+++ b/collects/tests/typed-scheme/succeed/new-metrics.rkt
@@ -61,7 +61,7 @@
            [table
             `((,a-hits ,b-hits)
               (,a-misses ,b-misses))]
-           [expected (λ: ([i : Natural] [j : Natural])
+           [expected (λ: ([i : Integer] [j : Integer])
                          (/ (* (row-total i table) (col-total j table)) total-subjects))])
       (exact->inexact 
        (table-sum 
@@ -425,7 +425,7 @@
           (show result))))
 
 ;; applies only to the combined metric [or more generally to listof-answer results]
-(: total (All (b c) (Natural (result (Listof Number) b c) -> (Listof Number))))
+(: total (All (b c) (Integer (result (Listof Number) b c) -> (Listof Number))))
 (define (total experiment-number result)
   (: total/s (Table -> Number))
   (define (total/s s) (apply + (list-ref (pivot s) experiment-number)))
@@ -447,7 +447,7 @@
     [(null? l) '()]
     [else
      (let ([n (length (car l))])
-       (build-list n (λ: ([i : Natural]) (map (λ: ([j : (Listof X)]) (list-ref j i)) l))))]))
+       (build-list n (λ: ([i : Integer]) (map (λ: ([j : (Listof X)]) (list-ref j i)) l))))]))
 
 (: variance ((Listof Number) -> Number))
 (define (variance xs)
@@ -455,16 +455,16 @@
     (/ (apply + (map (λ: ([x : Number]) (sqr (- x avg))) xs))
        (sub1 (length xs)))))
 
-(: table-ref (Natural Natural Table -> Number))
+(: table-ref (Integer Integer Table -> Number))
 (define (table-ref i j table)
   (list-ref (list-ref table i) j))
-(: row-total (Natural Table -> Number))
+(: row-total (Integer Table -> Number))
 (define (row-total i table)
   (apply + (list-ref table i)))
-(: col-total (Natural Table -> Number))
+(: col-total (Integer Table -> Number))
 (define (col-total j table)
   (apply + (map (λ: ([x : (Listof Number)]) (list-ref x j)) table)))
-(: table-sum ((Natural Natural -> Number) Table -> Number))
+(: table-sum ((Integer Integer -> Number) Table -> Number))
 (define (table-sum f table)
   (let ([rows (length table)]
         [cols (length (car table))])
diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
index 406dc955..e03ec46d 100644
--- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
+++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt
@@ -154,10 +154,10 @@
         [tc-e (void) -Void]
         [tc-e (void 3 4) -Void]
         [tc-e (void #t #f '(1 2 3)) -Void]
-        [tc-e/t #(3 4 5) (make-HeterogenousVector (list -Nat -Nat -Nat))]
+        [tc-e/t #(3 4 5) (make-HeterogenousVector (list -Integer -Integer -Integer))]
         [tc-e/t '(2 3 4) (-lst* -PositiveFixnum -PositiveFixnum -PositiveFixnum)]
         [tc-e/t '(2 3 #t) (-lst* -PositiveFixnum -PositiveFixnum (-val #t))]
-        [tc-e/t #(2 3 #t) (make-HeterogenousVector (list -Nat -Nat (-val #t)))]
+        [tc-e/t #(2 3 #t) (make-HeterogenousVector (list -Integer -Integer (-val #t)))]
         [tc-e/t '(#t #f) (-lst* (-val #t) (-val #f))]
         [tc-e/t (plambda: (a) ([l : (Listof a)]) (car l))
                 (make-Poly '(a) (t:-> (make-Listof (-v a)) (-v a)))]
diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt
index a2525f1d..c4c852d2 100644
--- a/collects/typed-scheme/private/base-env-indexing-abs.rkt
+++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt
@@ -137,7 +137,7 @@
    [unsafe-vector-set! (-poly (a) (-> (-vec a) index-type a -Void))]
    [unsafe-vector*-set! (-poly (a) (-> (-vec a) index-type a -Void))]
    [vector-copy! (-poly (a) ((-vec a) index-type (-vec a) [index-type index-type] . ->opt . -Void))]
-   [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Nat a))]
+   [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Integer a))]
                                  [(index-type a) (-vec a)]))]
 
    [bytes-ref (-> -Bytes index-type -NonnegativeFixnum)]

From 507afc21f4bc2b2d2d42b9bfe9caae3d9a9c2754 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 4 Aug 2010 17:46:03 -0400
Subject: [PATCH 12/12] Fixed source location for for:.

original commit: 500685c0f2b02ccc8ffb8746d93fde5b25a20ccc
---
 collects/typed-scheme/private/prims.rkt | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt
index 980675b3..bf9cdbc8 100644
--- a/collects/typed-scheme/private/prims.rkt
+++ b/collects/typed-scheme/private/prims.rkt
@@ -451,7 +451,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
          (syntax-parse clauses
            [(head:for-clause next:for-clause ... #:when rest ...)
             (syntax-property
-             (quasisyntax/loc clauses
+             (quasisyntax/loc stx
                (for
                 (head.expand next.expand ...)
                 #,(loop #'(#:when rest ...))))
@@ -459,18 +459,18 @@ This file defines two sorts of primitives. All of them are provided into any mod
              #'Void)]
            [(head:for-clause ...) ; we reached the end
             (syntax-property
-             (quasisyntax/loc clauses
+             (quasisyntax/loc stx
                (for
                 (head.expand ...)
                 #,@body))
              'type-ascription
              #'Void)]
            [(#:when guard) ; we end on a #:when clause
-            (quasisyntax/loc clauses
+            (quasisyntax/loc stx
               (when guard
                 #,@body))]
            [(#:when guard rest ...)
-            (quasisyntax/loc clauses
+            (quasisyntax/loc stx
               (when guard
                 #,(loop #'(rest ...))))])))]))