From 92347a18b6321df5196f823070bee69275d24667 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 23 Jun 2010 16:58:18 -0400 Subject: [PATCH] Wrote a test harness and a couple of tests for Typed Scheme's optimizer. original commit: fd987546b3d0293edba097f940c33fbdbf6c3b86 --- .../optimizer/generic/begin-float.rkt | 4 +++ .../optimizer/generic/define-begin-float.rkt | 4 +++ .../optimizer/generic/define-call-float.rkt | 3 ++ .../optimizer/generic/define-float.rkt | 3 ++ .../optimizer/generic/define-pair.rkt | 3 ++ .../optimizer/generic/double-float.rkt | 3 ++ .../optimizer/generic/float-fun.rkt | 5 +++ .../optimizer/generic/float-promotion.rkt | 3 ++ .../generic/invalid-float-promotion.rkt | 3 ++ .../optimizer/generic/let-float.rkt | 4 +++ .../optimizer/generic/nested-float.rkt | 3 ++ .../optimizer/generic/nested-float2.rkt | 3 ++ .../optimizer/generic/nested-pair1.rkt | 3 ++ .../optimizer/generic/nested-pair2.rkt | 3 ++ .../optimizer/generic/pair-fun.rkt | 7 ++++ .../optimizer/generic/simple-float.rkt | 3 ++ .../optimizer/generic/simple-pair.rkt | 3 ++ .../optimizer/generic/unary-float.rkt | 3 ++ collects/tests/typed-scheme/optimizer/run.rkt | 32 +++++++++++++++++++ 19 files changed, 95 insertions(+) create mode 100644 collects/tests/typed-scheme/optimizer/generic/begin-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/define-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/define-pair.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/double-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/float-fun.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/let-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/nested-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/simple-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/unary-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/run.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt b/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt new file mode 100644 index 00000000..a3bb961e --- /dev/null +++ b/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))) diff --git a/collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt b/collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt new file mode 100644 index 00000000..508bd0e5 --- /dev/null +++ b/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)))) diff --git a/collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt b/collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt new file mode 100644 index 00000000..fe2ff165 --- /dev/null +++ b/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))) diff --git a/collects/tests/typed-scheme/optimizer/generic/define-float.rkt b/collects/tests/typed-scheme/optimizer/generic/define-float.rkt new file mode 100644 index 00000000..9dfeb431 --- /dev/null +++ b/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))) diff --git a/collects/tests/typed-scheme/optimizer/generic/define-pair.rkt b/collects/tests/typed-scheme/optimizer/generic/define-pair.rkt new file mode 100644 index 00000000..ec30e20c --- /dev/null +++ b/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)))) diff --git a/collects/tests/typed-scheme/optimizer/generic/double-float.rkt b/collects/tests/typed-scheme/optimizer/generic/double-float.rkt new file mode 100644 index 00000000..1d686451 --- /dev/null +++ b/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)) diff --git a/collects/tests/typed-scheme/optimizer/generic/float-fun.rkt b/collects/tests/typed-scheme/optimizer/generic/float-fun.rkt new file mode 100644 index 00000000..788a2181 --- /dev/null +++ b/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))) diff --git a/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt new file mode 100644 index 00000000..3df6f684 --- /dev/null +++ b/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)) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt new file mode 100644 index 00000000..ee0f3875 --- /dev/null +++ b/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)) diff --git a/collects/tests/typed-scheme/optimizer/generic/let-float.rkt b/collects/tests/typed-scheme/optimizer/generic/let-float.rkt new file mode 100644 index 00000000..98e6a9fe --- /dev/null +++ b/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))) diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt new file mode 100644 index 00000000..04950423 --- /dev/null +++ b/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))) diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt new file mode 100644 index 00000000..ebe30a18 --- /dev/null +++ b/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))) diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt new file mode 100644 index 00000000..744d0c83 --- /dev/null +++ b/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)))) diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt new file mode 100644 index 00000000..a4c429d1 --- /dev/null +++ b/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))))) diff --git a/collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt b/collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt new file mode 100644 index 00000000..2fea5497 --- /dev/null +++ b/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)))) diff --git a/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt b/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt new file mode 100644 index 00000000..90676b7a --- /dev/null +++ b/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)) diff --git a/collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt b/collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt new file mode 100644 index 00000000..e5f69f70 --- /dev/null +++ b/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))) diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt new file mode 100644 index 00000000..d57f3950 --- /dev/null +++ b/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)) diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt new file mode 100644 index 00000000..331f3712 --- /dev/null +++ b/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))))