Wrote a test harness and a couple of tests for Typed Scheme's optimizer.

collects/tests/typed-scheme/optimizer/generic/begin-float.rkt

@@ -0,0 +1,4 @@
+(module begin-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (begin (- 2.0 3.0)
+         (* 2.0 3.0)))

collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt

@@ -0,0 +1,4 @@
+(module define-begin-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define a (begin (display (- 2.0 3.0))
+                   (* 2.0 3.0))))

collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt

@@ -0,0 +1,3 @@
+(module define-call-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define x (cons (+ 1.0 2.0) 3.0)))

collects/tests/typed-scheme/optimizer/generic/define-float.rkt

@@ -0,0 +1,3 @@
+(module define-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define x (+ 1.0 2.0)))

collects/tests/typed-scheme/optimizer/generic/define-pair.rkt

@@ -0,0 +1,3 @@
+(module define-pair typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define x (car '(1 3))))

collects/tests/typed-scheme/optimizer/generic/double-float.rkt

@@ -0,0 +1,3 @@
+(module double-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 2.0 2.0 2.0))

collects/tests/typed-scheme/optimizer/generic/float-fun.rkt

@@ -0,0 +1,5 @@
+(module float-fun typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: f (Float -> Float))
+  (define (f x)
+    (+ x 1.0)))

collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt

@@ -0,0 +1,3 @@
+(module float-promotion typed/scheme #:optimize
+  (require racket/unsafe/ops racket/flonum)
+  (+ 1 2.0))

collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt

@@ -0,0 +1,3 @@
+(module float-promotion typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (/ 1 2.0))

collects/tests/typed-scheme/optimizer/generic/let-float.rkt

@@ -0,0 +1,4 @@
+(module let-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (let ((x (+ 3.0 2.0)))
+    (* 9.0 x)))

collects/tests/typed-scheme/optimizer/generic/nested-float.rkt

@@ -0,0 +1,3 @@
+(module nested-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 2.0 (+ 3.0 4.0)))

collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt

@@ -0,0 +1,3 @@
+(module nested-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 2.0 (* 3.0 4.0)))

collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt

@@ -0,0 +1,3 @@
+(module nested-pair typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (car (cdr '(1 2))))

collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt

@@ -0,0 +1,3 @@
+(module nested-pair2 typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (car (cdr (cons 3 (cons (cons 2 '()) 1)))))

collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt

@@ -0,0 +1,7 @@
+(module pair-fun typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: f ((Listof Integer) -> Integer))
+  (define (f x)
+    (if (null? x)
+        1
+        (car x))))

collects/tests/typed-scheme/optimizer/generic/simple-float.rkt

@@ -0,0 +1,3 @@
+(module simple-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (+ 2.0 3.0))

collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt

@@ -0,0 +1,3 @@
+(module simple-pair typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (car (cons 1 2)))

collects/tests/typed-scheme/optimizer/generic/unary-float.rkt

@@ -0,0 +1,3 @@
+(module float-unary typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (sin 2.0))

collects/tests/typed-scheme/optimizer/hand-optimized/begin-float.rkt

@@ -0,0 +1,4 @@
+(module begin-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (begin (unsafe-fl- 2.0 3.0)
+         (unsafe-fl* 2.0 3.0)))

collects/tests/typed-scheme/optimizer/hand-optimized/define-begin-float.rkt

@@ -0,0 +1,4 @@
+(module define-begin-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define a (begin (display (unsafe-fl- 2.0 3.0))
+                   (unsafe-fl* 2.0 3.0))))

collects/tests/typed-scheme/optimizer/hand-optimized/define-call-float.rkt

@@ -0,0 +1,3 @@
+(module define-call-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define x (cons (unsafe-fl+ 1.0 2.0) 3.0)))

collects/tests/typed-scheme/optimizer/hand-optimized/define-float.rkt

@@ -0,0 +1,3 @@
+(module define-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define x (unsafe-fl+ 1.0 2.0)))

collects/tests/typed-scheme/optimizer/hand-optimized/define-pair.rkt

@@ -0,0 +1,3 @@
+(module define-pair typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (define x (unsafe-car '(1 3))))

collects/tests/typed-scheme/optimizer/hand-optimized/double-float.rkt

@@ -0,0 +1,3 @@
+(module double-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (unsafe-fl+ (unsafe-fl+ 2.0 2.0) 2.0))

collects/tests/typed-scheme/optimizer/hand-optimized/float-fun.rkt

@@ -0,0 +1,5 @@
+(module float-fun typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: f (Float -> Float))
+  (define (f x)
+    (unsafe-fl+ x 1.0)))

collects/tests/typed-scheme/optimizer/hand-optimized/float-promotion.rkt

@@ -0,0 +1,3 @@
+(module float-promotion typed/scheme #:optimize
+  (require racket/unsafe/ops racket/flonum)
+  (unsafe-fl+ (->fl 1) 2.0))

collects/tests/typed-scheme/optimizer/hand-optimized/invalid-float-promotion.rkt

@@ -0,0 +1,3 @@
+(module float-promotion typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (/ 1 2.0))

collects/tests/typed-scheme/optimizer/hand-optimized/let-float.rkt

@@ -0,0 +1,4 @@
+(module let-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (let ((x (unsafe-fl+ 3.0 2.0)))
+    (unsafe-fl* 9.0 x)))

collects/tests/typed-scheme/optimizer/hand-optimized/nested-float.rkt

@@ -0,0 +1,3 @@
+(module nested-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (unsafe-fl+ 2.0 (unsafe-fl+ 3.0 4.0)))

collects/tests/typed-scheme/optimizer/hand-optimized/nested-float2.rkt

@@ -0,0 +1,3 @@
+(module nested-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (unsafe-fl+ 2.0 (unsafe-fl* 3.0 4.0)))

collects/tests/typed-scheme/optimizer/hand-optimized/nested-pair1.rkt

@@ -0,0 +1,3 @@
+(module nested-pair typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (unsafe-car (unsafe-cdr '(1 2))))

collects/tests/typed-scheme/optimizer/hand-optimized/nested-pair2.rkt

@@ -0,0 +1,3 @@
+(module nested-pair2 typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (unsafe-car (unsafe-cdr (cons 3 (cons (cons 2 '()) 1)))))

collects/tests/typed-scheme/optimizer/hand-optimized/pair-fun.rkt

@@ -0,0 +1,7 @@
+(module pair-fun typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (: f ((Listof Integer) -> Integer))
+  (define (f x)
+    (if (null? x)
+        1
+        (unsafe-car x))))

collects/tests/typed-scheme/optimizer/hand-optimized/simple-float.rkt

@@ -0,0 +1,3 @@
+(module simple-float typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (unsafe-fl+ 2.0 3.0))

collects/tests/typed-scheme/optimizer/hand-optimized/simple-pair.rkt

@@ -0,0 +1,3 @@
+(module simple-pair typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (unsafe-car (cons 1 2)))

collects/tests/typed-scheme/optimizer/hand-optimized/unary-float.rkt

@@ -0,0 +1,3 @@
+(module float-unary typed/scheme #:optimize
+  (require racket/unsafe/ops)
+  (unsafe-flsin 2.0))

collects/tests/typed-scheme/optimizer/run.rkt

@@ -0,0 +1,32 @@
+#lang racket
+
+;; since Typed Scheme's optimizer does source to source transformations,
+;; we compare the expansion of automatically optimized and hand optimized
+;; modules
+(define (read-and-expand file)
+  (syntax->datum
+   (parameterize ([current-namespace (make-base-namespace)])
+     (with-handlers
+         ([exn:fail? (lambda (exn)
+                       (printf "~a\n" (exn-message exn))
+                       #'#f)])
+       (expand (with-input-from-file file read-syntax))))))
+
+(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)))
+        (begin (printf "~a failed\n\n" name)
+               #f))))
+
+(let ((n-failures
+       (if (> (vector-length (current-command-line-arguments)) 0)
+           (if (test (format "generic/~a.rkt"
+                             (vector-ref (current-command-line-arguments) 0)))
+               0 1)
+           (for/fold ((n-failures 0))
+               ((gen (in-directory "generic")))
+             (+ n-failures (if (test gen) 0 1))))))
+  (unless (= n-failures 0)
+    (error (format "~a tests failed." n-failures))))