diff --git a/collects/tests/typed-scheme/fail/back-and-forth.rkt b/collects/tests/typed-scheme/fail/back-and-forth.rkt index eac8be7d..ecaf6da2 100644 --- a/collects/tests/typed-scheme/fail/back-and-forth.rkt +++ b/collects/tests/typed-scheme/fail/back-and-forth.rkt @@ -1,5 +1,5 @@ #; -(exn-pred exn:fail:contract? #rx".*violator.*contract.*\\(-> Number Number\\).*f.*") +(exn-pred exn:fail:contract? #rx".*contract violation.*contract.*f.*\\(-> Number Number\\).*") #lang scheme/load diff --git a/collects/tests/typed-scheme/fail/dead-substruct.rkt b/collects/tests/typed-scheme/fail/dead-substruct.rkt index eed75288..2e79f4ae 100644 --- a/collects/tests/typed-scheme/fail/dead-substruct.rkt +++ b/collects/tests/typed-scheme/fail/dead-substruct.rkt @@ -1,5 +1,5 @@ #; -(exn-pred 1) +(exn-pred 2) #lang typed/scheme (define-struct: parent ((x : Integer))) diff --git a/collects/tests/typed-scheme/fail/log-not-complex.rkt b/collects/tests/typed-scheme/fail/log-not-complex.rkt new file mode 100644 index 00000000..450a6596 --- /dev/null +++ b/collects/tests/typed-scheme/fail/log-not-complex.rkt @@ -0,0 +1,5 @@ +#; +(exn-pred 1) +#lang typed/scheme + +(ann (log 2.0) Inexact-Complex) diff --git a/collects/tests/typed-scheme/fail/pr10594.rkt b/collects/tests/typed-scheme/fail/pr10594.rkt index 41eb8501..271775e8 100644 --- a/collects/tests/typed-scheme/fail/pr10594.rkt +++ b/collects/tests/typed-scheme/fail/pr10594.rkt @@ -1,5 +1,5 @@ #; -(exn-pred exn:fail:contract? #rx".*U broke the contract.*") +(exn-pred exn:fail:contract? #rx".*contract violation.*blaming 'U.*") #lang scheme/load (module T typed-scheme diff --git a/collects/tests/typed-scheme/fail/safe-letrec.rkt b/collects/tests/typed-scheme/fail/safe-letrec.rkt new file mode 100644 index 00000000..32acee2c --- /dev/null +++ b/collects/tests/typed-scheme/fail/safe-letrec.rkt @@ -0,0 +1,9 @@ +#; +(exn-pred 2) +#lang typed/racket + +;; make sure letrec takes into account that some bidings may be undefined + +(+ (letrec: ([x : Float x]) x) 1) ; PR 11511 + +(letrec: ([x : Float (+ x 1)]) 0) ; error in rhs diff --git a/collects/tests/typed-scheme/fail/tc-error-format.rkt b/collects/tests/typed-scheme/fail/tc-error-format.rkt new file mode 100644 index 00000000..f328fd5c --- /dev/null +++ b/collects/tests/typed-scheme/fail/tc-error-format.rkt @@ -0,0 +1,2 @@ +#lang typed/racket +(ann '~s Nothing) diff --git a/collects/tests/typed-scheme/fail/unbound-non-reg.rkt b/collects/tests/typed-scheme/fail/unbound-non-reg.rkt new file mode 100644 index 00000000..5b286373 --- /dev/null +++ b/collects/tests/typed-scheme/fail/unbound-non-reg.rkt @@ -0,0 +1,7 @@ +#; +(exn-pred 2) +#lang typed/racket + + +(define-struct: (T) Node ([v : T] [l : (BinTreeof t)] [r : (BinTreeof t)])) +(define-type (BinTreeof t) (U 'empty [Node t])) diff --git a/collects/tests/typed-scheme/fail/with-asserts.rkt b/collects/tests/typed-scheme/fail/with-asserts.rkt new file mode 100644 index 00000000..b543f7b9 --- /dev/null +++ b/collects/tests/typed-scheme/fail/with-asserts.rkt @@ -0,0 +1,7 @@ +#; +(exn-pred exn:fail?) +#lang typed/racket + +(let ([x 1] [y "2"]) + (with-asserts ([x string?] [y integer?]) + x)) diff --git a/collects/tests/typed-scheme/fail/with-asserts2.rkt b/collects/tests/typed-scheme/fail/with-asserts2.rkt new file mode 100644 index 00000000..79ec314a --- /dev/null +++ b/collects/tests/typed-scheme/fail/with-asserts2.rkt @@ -0,0 +1,7 @@ +#; +(exn-pred exn:fail?) +#lang typed/racket + +(let ([x 1] [y "2"]) + (with-asserts ([x string?]) + x)) diff --git a/collects/tests/typed-scheme/fail/with-asserts3.rkt b/collects/tests/typed-scheme/fail/with-asserts3.rkt new file mode 100644 index 00000000..f38cb1e6 --- /dev/null +++ b/collects/tests/typed-scheme/fail/with-asserts3.rkt @@ -0,0 +1,7 @@ +#; +(exn-pred exn:fail?) +#lang typed/racket + +(let ([x #f]) + (with-asserts ([x]) + x)) diff --git a/collects/tests/typed-scheme/main.rkt b/collects/tests/typed-scheme/main.rkt index 9fb96757..0d83c532 100644 --- a/collects/tests/typed-scheme/main.rkt +++ b/collects/tests/typed-scheme/main.rkt @@ -2,7 +2,7 @@ (provide go go/text) -(require rackunit rackunit/text-ui +(require rackunit rackunit/text-ui racket/file mzlib/etc scheme/port compiler/compiler scheme/match mzlib/compile @@ -134,7 +134,9 @@ (check-not-exn (λ () (cfile (build-path path p))))))))) (test-suite "compiling" (mk shootout) - (mk common))) + (delete-directory/files (build-path shootout "compiled")) + (mk common) + (delete-directory/files (build-path common "compiled")))) (provide go go/text just-one compile-benchmarks) diff --git a/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt b/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt deleted file mode 100644 index a3bb961e..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(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/binary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt deleted file mode 100644 index 6c1dcba3..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt +++ /dev/null @@ -1,5 +0,0 @@ -(module binary-fixnum typed/scheme #:optimize - (require racket/unsafe/ops) - (: f (All (X) ((Vectorof X) -> Natural))) - (define (f v) - (bitwise-and (vector-length v) 1))) diff --git a/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt deleted file mode 100644 index 0e5c46a6..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module binary-nonzero-fixnum typed/scheme #:optimize - (require racket/unsafe/ops) - (quotient (vector-length '#(1 2 3)) 2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt b/collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt deleted file mode 100644 index 45a1696e..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/cross-module-struct2.rkt +++ /dev/null @@ -1,5 +0,0 @@ -#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/generic/dead-else.rkt b/collects/tests/typed-scheme/optimizer/generic/dead-else.rkt deleted file mode 100644 index 6e2868ef..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/dead-else.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang typed/scheme #:optimize -(require racket/unsafe/ops) -(display (if (number? 3) - (+ 2.0 3.0) - (+ 4.0 5.0))) -(display (if #t - (+ 2.0 3.0) - (+ 4.0 5.0))) diff --git a/collects/tests/typed-scheme/optimizer/generic/dead-then.rkt b/collects/tests/typed-scheme/optimizer/generic/dead-then.rkt deleted file mode 100644 index c4ec905b..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/dead-then.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang typed/scheme #:optimize -(require racket/unsafe/ops) -(display (if (number? "eh") - (+ 2.0 3.0) - (+ 4.0 5.0))) -(display (if #f - (+ 2.0 3.0) - (+ 4.0 5.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 deleted file mode 100644 index 508bd0e5..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(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 deleted file mode 100644 index fe2ff165..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(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 deleted file mode 100644 index 9dfeb431..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/define-float.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(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 deleted file mode 100644 index ec30e20c..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/define-pair.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(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 deleted file mode 100644 index 1d686451..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/double-float.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(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/exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt deleted file mode 100644 index f19e3812..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module exact-inexact typed/scheme #:optimize - (require racket/flonum) - (exact->inexact (expt 10 100))) ; must not be a fixnum diff --git a/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt b/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt deleted file mode 100644 index 905b4c8b..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module fixnum-comparison typed/scheme #:optimize - (require racket/unsafe/ops) - (< (vector-length '#(1 2 3)) (string-length "asdf"))) diff --git a/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt b/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt deleted file mode 100644 index d644a1c9..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module float-comp typed/scheme #:optimize - (require racket/unsafe/ops) - (< 1.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 deleted file mode 100644 index 788a2181..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/float-fun.rkt +++ /dev/null @@ -1,5 +0,0 @@ -(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 deleted file mode 100644 index 1fc32fa9..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(module float-promotion typed/scheme #:optimize - (require racket/unsafe/ops racket/flonum) - (+ 1 2.0) - (+ (expt 100 100) 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt b/collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt deleted file mode 100644 index 34add429..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module flvector-length typed/scheme #:optimize - (require racket/unsafe/ops racket/flonum) - (flvector-length (flvector 0.0 1.2))) diff --git a/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt b/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt deleted file mode 100644 index ee505dfd..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module fx-fl typed/scheme #:optimize - (require racket/unsafe/ops) - (exact->inexact 1)) diff --git a/collects/tests/typed-scheme/optimizer/generic/in-bytes.rkt b/collects/tests/typed-scheme/optimizer/generic/in-bytes.rkt deleted file mode 100644 index 4abbe294..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/in-bytes.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang typed/scheme #:optimize -(require racket/unsafe/ops) -(for: ((i : Integer #"123")) - (display i)) diff --git a/collects/tests/typed-scheme/optimizer/generic/in-list.rkt b/collects/tests/typed-scheme/optimizer/generic/in-list.rkt deleted file mode 100644 index 6d9dde83..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/in-list.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(module in-list typed/scheme #:optimize - (require racket/unsafe/ops) - (for: ((i : Natural '(1 2 3))) - (display i))) diff --git a/collects/tests/typed-scheme/optimizer/generic/in-string.rkt b/collects/tests/typed-scheme/optimizer/generic/in-string.rkt deleted file mode 100644 index 5a17acc3..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/in-string.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang typed/scheme #:optimize -(require racket/unsafe/ops) -(for: ((i : Char "123")) - (display i)) diff --git a/collects/tests/typed-scheme/optimizer/generic/in-vector.rkt b/collects/tests/typed-scheme/optimizer/generic/in-vector.rkt deleted file mode 100644 index 6cddafcf..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/in-vector.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang typed/scheme #:optimize -(require racket/unsafe/ops) -(for: ((i : Integer (vector 1 2 3))) - (display i)) diff --git a/collects/tests/typed-scheme/optimizer/generic/inexact-complex-conjugate-top.rkt b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-conjugate-top.rkt deleted file mode 100644 index 3e9b4090..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/inexact-complex-conjugate-top.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang typed/scheme #:optimize -(require racket/unsafe/ops) -(conjugate (+ 1.0+2.0i 2.0+4.0i)) diff --git a/collects/tests/typed-scheme/optimizer/generic/inexact-complex-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/inexact-complex-fixnum.rkt deleted file mode 100644 index 3f99e881..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/inexact-complex-fixnum.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang typed/scheme #:optimize -(require racket/unsafe/ops) -(+ 2 1.0+2.0i 3.0+6.0i) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt deleted file mode 100644 index e1e94c47..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(module invalid-binary-nonzero-fixnum typed/scheme #:optimize - (: f ( -> Void)) - (define (f) ; in a function, to prevent evaluation - (display (quotient 4 0)))) ; 2 fixnums, but the second is 0, cannot optimize diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt deleted file mode 100644 index f0fec025..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt +++ /dev/null @@ -1,2 +0,0 @@ -(module exact-inexact typed/scheme #:optimize - (exact->inexact 1.0)) ; not an integer, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt deleted file mode 100644 index 1f972d6b..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module float-comp typed/scheme #:optimize - (require racket/unsafe/ops) - (< 1.0 2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt deleted file mode 100644 index 169909be..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt +++ /dev/null @@ -1,2 +0,0 @@ -(module float-promotion typed/scheme #:optimize - (/ 1 2.0)) ; result is not a float, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt deleted file mode 100644 index b0a2ab9d..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt +++ /dev/null @@ -1,2 +0,0 @@ -(module invalid-inexact-complex-parts.rkt typed/scheme #:optimize - (real-part 1+2i)) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt deleted file mode 100644 index ce166151..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt +++ /dev/null @@ -1,2 +0,0 @@ -(module invalid-make-flrectangular typed/scheme #:optimize - (make-rectangular 1 2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt deleted file mode 100644 index 39b0336c..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt +++ /dev/null @@ -1,2 +0,0 @@ -(module invalid-sqrt typed/scheme #:optimize - (sqrt -2.0)) ; not a nonnegative flonum, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt deleted file mode 100644 index 74714405..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(module invalid-vector-ref typed/scheme #:optimize - (: f ((Vectorof Integer) -> Integer)) - (define (f x) - (vector-ref x 0))) ; type is (Vectorof Integer), length is unknown, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt deleted file mode 100644 index b02fbdc0..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(module invalid-vector-set typed/scheme #:optimize - (: f ((Vectorof Integer) -> Void)) - (define (f x) - (vector-set! x 0 2))) ; type is (Vectorof Integer), length is ot known, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt b/collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt deleted file mode 100644 index 083d8730..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module known-vector-length typed/scheme #:optimize - (require racket/unsafe/ops) - (+ 2 (vector-length (ann (vector 1 2) (Vector Integer Integer))))) diff --git a/collects/tests/typed-scheme/optimizer/generic/let-float.rkt b/collects/tests/typed-scheme/optimizer/generic/let-float.rkt deleted file mode 100644 index 98e6a9fe..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/let-float.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(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/make-flrectangular.rkt b/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt deleted file mode 100644 index b9250d0e..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(module make-flrectangular typed/scheme #:optimize - (require racket/unsafe/ops racket/flonum) - (make-rectangular 1.0 2.2) - (make-flrectangular 1.0 2.2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/mpair.rkt b/collects/tests/typed-scheme/optimizer/generic/mpair.rkt deleted file mode 100644 index 5fc67a69..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/mpair.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang typed/scheme #:optimize -(require racket/unsafe/ops) -(: x (MPairof Integer Float)) -(define x (mcons 1 1.0)) -(mcar x) -(mcdr x) -(set-mcar! x (+ 1 2)) -(set-mcdr! x (+ 1.0 2.0)) - -(: f ((MListof Integer) -> Integer)) -(define (f x) - (if (null? x) - 0 - (mcar x))) diff --git a/collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt b/collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt deleted file mode 100644 index 54b59581..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module n-ary-float typed/scheme #:optimize - (require racket/unsafe/ops) - (+ 1.0 2.0 3.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt deleted file mode 100644 index 04950423..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(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 deleted file mode 100644 index ebe30a18..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(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 deleted file mode 100644 index 744d0c83..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(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 deleted file mode 100644 index a4c429d1..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(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 deleted file mode 100644 index 2fea5497..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt +++ /dev/null @@ -1,7 +0,0 @@ -(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/quote.rkt b/collects/tests/typed-scheme/optimizer/generic/quote.rkt deleted file mode 100644 index 2d62416f..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/quote.rkt +++ /dev/null @@ -1,2 +0,0 @@ -(module quote typed/scheme #:optimize - '(+ 1.0 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt b/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt deleted file mode 100644 index 90676b7a..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(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 deleted file mode 100644 index e5f69f70..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module simple-pair typed/scheme #:optimize - (require racket/unsafe/ops) - (car (cons 1 2))) diff --git a/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt b/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt deleted file mode 100644 index 411ff900..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt +++ /dev/null @@ -1,5 +0,0 @@ -(module sqrt typed/scheme #:optimize - (require racket/unsafe/ops) - (: f (Nonnegative-Float -> Nonnegative-Float)) - (define (f x) - (sqrt x))) diff --git a/collects/tests/typed-scheme/optimizer/generic/structs.rkt b/collects/tests/typed-scheme/optimizer/generic/structs.rkt deleted file mode 100644 index 4fb39c9d..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/structs.rkt +++ /dev/null @@ -1,6 +0,0 @@ -(module structs typed/scheme #:optimize - (require racket/unsafe/ops) - (define-struct: pt ((x : Integer) (y : Integer)) #:mutable) - (define a (pt 3 4)) - (pt-x a) - (set-pt-y! a 5)) diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt deleted file mode 100644 index 710197af..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module unary-fixnum-nested typed/scheme #:optimize - (require racket/unsafe/ops racket/fixnum) - (abs (bitwise-not (length '(1 2 3))))) diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt deleted file mode 100644 index b9309084..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module unary-fixnum typed/scheme #:optimize - (require racket/unsafe/ops) - (bitwise-not 4)) diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt deleted file mode 100644 index d57f3950..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module float-unary typed/scheme #:optimize - (require racket/unsafe/ops) - (sin 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-length-nested.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-length-nested.rkt deleted file mode 100644 index ade363e1..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/vector-length-nested.rkt +++ /dev/null @@ -1,7 +0,0 @@ -(module vector-length typed/scheme #:optimize - (require racket/unsafe/ops) - (vector-length - (vector-ref - (ann (vector (vector 1 2) 2 3) - (Vector (Vectorof Integer) Integer Integer)) - 0))) diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-length.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-length.rkt deleted file mode 100644 index 51093a09..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/vector-length.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module vector-length typed/scheme #:optimize - (require racket/unsafe/ops) - (vector-length (vector 1 2 3))) diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-ref-set-ref.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-ref-set-ref.rkt deleted file mode 100644 index 711633ea..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/vector-ref-set-ref.rkt +++ /dev/null @@ -1,7 +0,0 @@ -(module vector-ref-set-ref typed/scheme #:optimize - (require racket/unsafe/ops) - (: x (Vector Integer String)) - (define x (vector 1 "1")) - (vector-ref x 0) - (vector-set! x 1 "2") - (vector-ref x 1)) diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-ref.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-ref.rkt deleted file mode 100644 index 00261f8a..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/vector-ref.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module vector-ref typed/scheme #:optimize - (require racket/unsafe/ops) - (vector-ref (ann (vector 1 2) (Vector Integer Integer)) 0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt deleted file mode 100644 index 434fa07c..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module vector-ref2 typed/scheme #:optimize - (require racket/unsafe/ops) - (vector-ref (vector 1 2 3) 0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-set-quote.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-set-quote.rkt deleted file mode 100644 index 063b78d3..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/vector-set-quote.rkt +++ /dev/null @@ -1,5 +0,0 @@ -(module vector-set-quote typed/scheme #:optimize - (require racket/unsafe/ops) - (vector-set! (ann (vector '(1 2)) (Vector Any)) - 0 - '(+ 1.0 2.0))) ; we should not optimize under quote diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-set.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-set.rkt deleted file mode 100644 index 5f29aa5e..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/vector-set.rkt +++ /dev/null @@ -1,5 +0,0 @@ -(module vector-set typed/scheme #:optimize - (require racket/unsafe/ops) - (vector-set! (ann (vector 1 2) (Vector Integer Integer)) - 0 - 1)) diff --git a/collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt deleted file mode 100644 index 910575d5..00000000 --- a/collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module invalid-vector-set typed/scheme #:optimize - (require racket/unsafe/ops) - (vector-set! (vector 1 2) 0 2)) ; type is (Vectorof Integer), length is ot known, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt index 63cb7f8f..9dfe94d0 100644 --- a/collects/tests/typed-scheme/optimizer/run.rkt +++ b/collects/tests/typed-scheme/optimizer/run.rkt @@ -1,62 +1,92 @@ #lang racket -(require racket/runtime-path) +(require racket/runtime-path racket/sandbox) -;; 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) - ;; drop the type tables added by typed scheme, since they can be in a - ;; different order each time, and that would make tests fail when they - ;; shouldn't - (filter - ;; drop the "module", its name and its language, so that we can write - ;; the 2 versions of each test in different languages (typed and - ;; untyped) if need be - (match-lambda [(list 'define-values-for-syntax '() _ ...) #f] [_ #t]) - (cadddr - (syntax->datum - (parameterize ([current-namespace (make-base-namespace)] - [read-accept-reader #t]) - (with-handlers - ([exn:fail? (lambda (exn) - (printf "~a\n" (exn-message exn)) - #'(#f #f #f (#f)))]) ; for cadddr - (expand (with-input-from-file file read-syntax)))))))) +(define show-names? (make-parameter #f)) + +(define prog-rx + (pregexp (string-append "^\\s*" + "(#lang typed/(?:scheme|racket)(?:/base)?)" + "\\s+" + "#:optimize" + "\\s+"))) + +(define (evaluator file #:optimize [optimize? #f]) + (call-with-trusted-sandbox-configuration + (lambda () + (parameterize ([current-load-relative-directory tests-dir] + [sandbox-memory-limit #f] ; TR needs memory + [sandbox-output 'string] + [sandbox-namespace-specs + (list (car (sandbox-namespace-specs)) + 'typed/racket + 'typed/scheme)]) + ;; drop the expected log + (let* ([prog (with-input-from-file file + (lambda () + (read-line) ; drop #; + (read) ; drop expected log + (port->string)))] ; get the actual program + [m (or (regexp-match-positions prog-rx prog) + (error 'evaluator "bad program contents in ~e" file))] + [prog (string-append (substring prog (caadr m) (cdadr m)) + (if (not optimize?) "\n#:no-optimize\n" "\n") + (substring prog (cdar m)))] + [evaluator (make-module-evaluator prog)] + [out (get-output evaluator)]) + (kill-evaluator evaluator) + out))))) + +(define (generate-opt-log name) + (parameterize ([current-load-relative-directory tests-dir] + [current-command-line-arguments '#("--log-optimizations")]) + (let ((log-string + (with-output-to-string + (lambda () + (dynamic-require (build-path (current-load-relative-directory) + name) + #f))))) + ;; have the log as an sexp, since that's what the expected log is + (with-input-from-string (string-append "(" log-string ")") + read)))) (define (test gen) (let-values (((base name _) (split-path gen))) - (or (regexp-match ".*~" name) ; we ignore backup files - ;; machine optimized and hand optimized versions must expand to the - ;; same code - (and (or (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: expanded code mismatch\n\n" name) + (when (show-names?) (displayln name)) + (or (not (regexp-match ".*rkt$" name)) ; we ignore all but racket files + ;; we log optimizations and compare to an expected log to make sure + ;; that all the optimizations we expected did indeed happen + (and (or (let ((log (generate-opt-log name)) + ;; expected optimizer log, to see what was optimized + (expected + (with-input-from-file gen + (lambda () + (read-line) ; skip the #; + (read))))) ; get the log itself + (equal? log expected)) + (begin (printf "~a failed: optimization log mismatch\n\n" name) #f)) ;; optimized and non-optimized versions must evaluate to the ;; same thing - (or (equal? (with-output-to-string - (lambda () - (dynamic-require gen #f))) - (with-output-to-string - (lambda () - (let ((non-opt-dir (build-path here "non-optimized"))) - (dynamic-require (build-path non-opt-dir name) #f))))) + (or (equal? (evaluator gen) (evaluator gen #:optimize #t)) (begin (printf "~a failed: result mismatch\n\n" name) #f)))))) -(define-runtime-path here ".") +(define to-run + (command-line + #:once-each + ["--show-names" "show the names of tests as they are run" (show-names? #t)] + ;; we optionally take a test name. if none is given, run everything (#f) + #:args maybe-test-to-run + (and (not (null? maybe-test-to-run)) + (car maybe-test-to-run)))) + +(define-runtime-path tests-dir "./tests") (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) + (if to-run + (if (test to-run) 0 1) (for/fold ((n-failures 0)) - ((gen (in-directory (build-path here "generic")))) + ((gen (in-directory tests-dir))) (+ n-failures (if (test gen) 0 1)))))) (unless (= n-failures 0) (error (format "~a tests failed." n-failures)))) diff --git a/collects/tests/typed-scheme/optimizer/tests/apply-plus.rkt b/collects/tests/typed-scheme/optimizer/tests/apply-plus.rkt new file mode 100644 index 00000000..d3f4b79d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/apply-plus.rkt @@ -0,0 +1,13 @@ +#; +( +apply-plus.rkt line 12 col 7 - + - apply-map +apply-plus.rkt line 13 col 7 - * - apply-map +9 +24 +) + +#lang typed/racket +#:optimize + +(apply + (map add1 (list 1 2 3))) +(apply * (map add1 (list 1 2 3))) diff --git a/collects/tests/typed-scheme/optimizer/tests/begin-float.rkt b/collects/tests/typed-scheme/optimizer/tests/begin-float.rkt new file mode 100644 index 00000000..1514e0b0 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/begin-float.rkt @@ -0,0 +1,13 @@ +#; +( +begin-float.rkt line 12 col 8 - - - binary float +begin-float.rkt line 13 col 8 - * - binary float +-1.0 +6.0 +) + +#lang typed/scheme +#:optimize + +(begin (- 2.0 3.0) + (* 2.0 3.0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/binary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/tests/binary-fixnum.rkt new file mode 100644 index 00000000..0b6ab3e0 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/binary-fixnum.rkt @@ -0,0 +1,12 @@ +#; +( +binary-fixnum.rkt line 12 col 16 - vector-length - vector-length +binary-fixnum.rkt line 12 col 3 - bitwise-and - binary fixnum +) + +#lang typed/scheme +#:optimize + +(: f (All (X) ((Vectorof X) -> Natural))) +(define (f v) + (bitwise-and (vector-length v) 1)) diff --git a/collects/tests/typed-scheme/optimizer/tests/binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/tests/binary-nonzero-fixnum.rkt new file mode 100644 index 00000000..ed3f7ed4 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/binary-nonzero-fixnum.rkt @@ -0,0 +1,11 @@ +#; +( +binary-nonzero-fixnum.rkt line 11 col 9 - vector-length - vector-length +binary-nonzero-fixnum.rkt line 11 col 1 - modulo - binary nonzero fixnum +1 +) + +#lang typed/scheme +#:optimize + +(modulo (vector-length '#(1 2 3)) 2) diff --git a/collects/tests/typed-scheme/optimizer/tests/box.rkt b/collects/tests/typed-scheme/optimizer/tests/box.rkt new file mode 100644 index 00000000..9ea6b1df --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/box.rkt @@ -0,0 +1,19 @@ +#; +( +box.rkt line 17 col 1 - unbox - box +box.rkt line 18 col 1 - set-box! - box +box.rkt line 19 col 1 - unbox - box +1 +2 +) + +#lang typed/scheme +#:optimize + + + +(: x (Boxof Integer)) +(define x (box 1)) +(unbox x) +(set-box! x 2) +(unbox x) diff --git a/collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt b/collects/tests/typed-scheme/optimizer/tests/cross-module-struct.rkt similarity index 95% rename from collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt rename to collects/tests/typed-scheme/optimizer/tests/cross-module-struct.rkt index 7b52b214..0959962c 100644 --- a/collects/tests/typed-scheme/optimizer/generic/cross-module-struct.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/cross-module-struct.rkt @@ -1,3 +1,6 @@ +#; +() + #lang typed/scheme #:optimize ;; will be imported by cross-module-struct2 diff --git a/collects/tests/typed-scheme/optimizer/tests/cross-module-struct2.rkt b/collects/tests/typed-scheme/optimizer/tests/cross-module-struct2.rkt new file mode 100644 index 00000000..e310b047 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/cross-module-struct2.rkt @@ -0,0 +1,11 @@ +#; +( +cross-module-struct2.rkt line 11 col 1 - x-x - struct ref +1 +) + +#lang typed/scheme #:optimize + +(require (file "cross-module-struct.rkt")) +(define a (make-x 1)) +(x-x a) diff --git a/collects/tests/typed-scheme/optimizer/tests/dead-else.rkt b/collects/tests/typed-scheme/optimizer/tests/dead-else.rkt new file mode 100644 index 00000000..cbc34a9a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/dead-else.rkt @@ -0,0 +1,18 @@ +#; +( +#f line #f col #f - op - dead else branch +dead-else.rkt line 14 col 14 - + - binary float +#f line #f col #f - op - dead else branch +dead-else.rkt line 17 col 14 - + - binary float +5.05.0 +) + +#lang typed/scheme +#:optimize + +(display (if (number? 3) + (+ 2.0 3.0) + (+ 4.0 5.0))) +(display (if #t + (+ 2.0 3.0) + (+ 4.0 5.0))) diff --git a/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt b/collects/tests/typed-scheme/optimizer/tests/dead-substructs.rkt similarity index 90% rename from collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt rename to collects/tests/typed-scheme/optimizer/tests/dead-substructs.rkt index a01a5e5b..638a5cf0 100644 --- a/collects/tests/typed-scheme/optimizer/generic/dead-substructs.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/dead-substructs.rkt @@ -1,4 +1,11 @@ -#lang typed/scheme #:optimize +#; +( +1 +2 +) + +#lang typed/scheme +#:optimize ;; originally from nucleic3 ;; cond on substructs, branches were considered dead diff --git a/collects/tests/typed-scheme/optimizer/tests/dead-then.rkt b/collects/tests/typed-scheme/optimizer/tests/dead-then.rkt new file mode 100644 index 00000000..7e3ee6c8 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/dead-then.rkt @@ -0,0 +1,18 @@ +#; +( +#f line #f col #f - op - dead then branch +dead-then.rkt line 15 col 14 - + - binary float +#f line #f col #f - op - dead then branch +dead-then.rkt line 18 col 14 - + - binary float +9.09.0 +) + +#lang typed/scheme +#:optimize + +(display (if (number? "eh") + (+ 2.0 3.0) + (+ 4.0 5.0))) +(display (if #f + (+ 2.0 3.0) + (+ 4.0 5.0))) diff --git a/collects/tests/typed-scheme/optimizer/tests/define-begin-float.rkt b/collects/tests/typed-scheme/optimizer/tests/define-begin-float.rkt new file mode 100644 index 00000000..e7e3641e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/define-begin-float.rkt @@ -0,0 +1,12 @@ +#; +( +define-begin-float.rkt line 11 col 27 - - - binary float +define-begin-float.rkt line 12 col 18 - * - binary float +-1.0 +) + +#lang typed/scheme +#:optimize + +(define a (begin (display (- 2.0 3.0)) + (* 2.0 3.0))) diff --git a/collects/tests/typed-scheme/optimizer/tests/define-call-float.rkt b/collects/tests/typed-scheme/optimizer/tests/define-call-float.rkt new file mode 100644 index 00000000..479a47f2 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/define-call-float.rkt @@ -0,0 +1,9 @@ +#; +( +define-call-float.rkt line 9 col 17 - + - binary float +) + +#lang typed/scheme +#:optimize + +(define x (cons (+ 1.0 2.0) 3.0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/define-float.rkt b/collects/tests/typed-scheme/optimizer/tests/define-float.rkt new file mode 100644 index 00000000..853afc03 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/define-float.rkt @@ -0,0 +1,9 @@ +#; +( +define-float.rkt line 9 col 11 - + - binary float +) + +#lang typed/scheme +#:optimize + +(define x (+ 1.0 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/define-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/define-pair.rkt new file mode 100644 index 00000000..006029b3 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/define-pair.rkt @@ -0,0 +1,9 @@ +#; +( +define-pair.rkt line 9 col 11 - car - pair +) + +#lang typed/scheme +#:optimize + +(define x (car '(1 3))) diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt new file mode 100644 index 00000000..575cc1c9 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt @@ -0,0 +1,30 @@ +#; +( +#f line #f col #f - car - pair +#f line #f col #f - car - pair +derived-pair.rkt line 27 col 0 - (#%app caar (#%app cons (#%app cons (quote 1) (quote 2) +) (quote 3))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +derived-pair.rkt line 28 col 0 - (#%app cadr (#%app cons (quote 1) (#%app cons (quote 2) + (quote 3)))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +derived-pair.rkt line 29 col 0 - (#%app cdar (#%app cons (#%app cons (quote 1) (quote 2) +) (quote 3))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +derived-pair.rkt line 30 col 0 - (#%app cddr (#%app cons (quote 1) (#%app cons (quote 2) + (quote 3)))) - derived pair +1 +2 +2 +3 +) + +#lang typed/racket #:optimize + +(caar (cons (cons 1 2) 3)) +(cadr (cons 1 (cons 2 3))) +(cdar (cons (cons 1 2) 3)) +(cddr (cons 1 (cons 2 3))) diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt new file mode 100644 index 00000000..2f540a2a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair2.rkt @@ -0,0 +1,54 @@ +#; +( +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +derived-pair2.rkt line 47 col 0 - (#%app caaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +derived-pair2.rkt line 48 col 0 - (#%app caadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +derived-pair2.rkt line 49 col 0 - (#%app cadar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +derived-pair2.rkt line 50 col 0 - (#%app caddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +derived-pair2.rkt line 51 col 0 - (#%app cdaar (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +derived-pair2.rkt line 52 col 0 - (#%app cdadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +derived-pair2.rkt line 53 col 0 - (#%app cddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +derived-pair2.rkt line 54 col 0 - (#%app cdddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))))) - derived pair +1 +2 +2 +3 +2 +3 +3 +4 +) + +#lang typed/racket #:optimize + +(caaar (cons (cons (cons 1 2) 3) 4)) +(caadr (cons 1 (cons (cons 2 3) 4))) +(cadar (cons (cons 1 (cons 2 3)) 4)) +(caddr (cons 1 (cons 2 (cons 3 4)))) +(cdaar (cons (cons (cons 1 2) 3) 4)) +(cdadr (cons 1 (cons (cons 2 3) 4))) +(cddar (cons (cons 1 (cons 2 3)) 4)) +(cdddr (cons 1 (cons 2 (cons 3 4)))) diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt new file mode 100644 index 00000000..4fa58e4d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair3.rkt @@ -0,0 +1,118 @@ +#; +( +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +derived-pair3.rkt line 103 col 0 - (#%app caaaar (#%app cons (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4)) (quote 5))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +derived-pair3.rkt line 104 col 0 - (#%app caaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +derived-pair3.rkt line 105 col 0 - (#%app caadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +derived-pair3.rkt line 106 col 0 - (#%app caaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +derived-pair3.rkt line 107 col 0 - (#%app cadaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +derived-pair3.rkt line 108 col 0 - (#%app cadadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +derived-pair3.rkt line 109 col 0 - (#%app caddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +derived-pair3.rkt line 110 col 0 - (#%app cadddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (#%app cons (quote 4) (quote 5)))))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +derived-pair3.rkt line 111 col 0 - (#%app cdaaar (#%app cons (#%app cons (#%app cons (#%app cons (quote 1) (quote 2)) (quote 3)) (quote 4)) (quote 5))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +derived-pair3.rkt line 112 col 0 - (#%app cdaadr (#%app cons (quote 1) (#%app cons (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4)) (quote 5)))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +derived-pair3.rkt line 113 col 0 - (#%app cdadar (#%app cons (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (quote 3)) (quote 4))) (quote 5))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +derived-pair3.rkt line 114 col 0 - (#%app cdaddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (#%app cons (quote 3) (quote 4)) (quote 5))))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +derived-pair3.rkt line 115 col 0 - (#%app cddaar (#%app cons (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (quote 3))) (quote 4)) (quote 5))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +derived-pair3.rkt line 116 col 0 - (#%app cddadr (#%app cons (quote 1) (#%app cons (#%app cons (quote 2) (#%app cons (quote 3) (quote 4))) (quote 5)))) - derived pair +#f line #f col #f - car - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +derived-pair3.rkt line 117 col 0 - (#%app cdddar (#%app cons (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (quote 4)))) (quote 5))) - derived pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +#f line #f col #f - cdr - pair +derived-pair3.rkt line 118 col 0 - (#%app cddddr (#%app cons (quote 1) (#%app cons (quote 2) (#%app cons (quote 3) (#%app cons (quote 4) (quote 5)))))) - derived pair +1 +2 +2 +3 +2 +3 +3 +4 +2 +3 +3 +4 +3 +4 +4 +5 +) + +#lang typed/racket #:optimize + +(caaaar (cons (cons (cons (cons 1 2) 3) 4) 5)) +(caaadr (cons 1 (cons (cons (cons 2 3) 4) 5))) +(caadar (cons (cons 1 (cons (cons 2 3) 4)) 5)) +(caaddr (cons 1 (cons 2 (cons (cons 3 4) 5)))) +(cadaar (cons (cons (cons 1 (cons 2 3)) 4) 5)) +(cadadr (cons 1 (cons (cons 2 (cons 3 4)) 5))) +(caddar (cons (cons 1 (cons 2 (cons 3 4))) 5)) +(cadddr (cons 1 (cons 2 (cons 3 (cons 4 5))))) +(cdaaar (cons (cons (cons (cons 1 2) 3) 4) 5)) +(cdaadr (cons 1 (cons (cons (cons 2 3) 4) 5))) +(cdadar (cons (cons 1 (cons (cons 2 3) 4)) 5)) +(cdaddr (cons 1 (cons 2 (cons (cons 3 4) 5)))) +(cddaar (cons (cons (cons 1 (cons 2 3)) 4) 5)) +(cddadr (cons 1 (cons (cons 2 (cons 3 4)) 5))) +(cdddar (cons (cons 1 (cons 2 (cons 3 4))) 5)) +(cddddr (cons 1 (cons 2 (cons 3 (cons 4 5))))) diff --git a/collects/tests/typed-scheme/optimizer/generic/different-langs.rkt b/collects/tests/typed-scheme/optimizer/tests/different-langs.rkt similarity index 64% rename from collects/tests/typed-scheme/optimizer/generic/different-langs.rkt rename to collects/tests/typed-scheme/optimizer/tests/different-langs.rkt index 9754b392..cee704bb 100644 --- a/collects/tests/typed-scheme/optimizer/generic/different-langs.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/different-langs.rkt @@ -1,4 +1,10 @@ +#; +( +3 +) + +#lang typed/scheme +#:optimize ;; to see if the harness supports having the 2 versions of a test being ;; written in different languages -(module different-langs typed/scheme #:optimize - (+ 1 2)) +(+ 1 2) diff --git a/collects/tests/typed-scheme/optimizer/tests/double-float.rkt b/collects/tests/typed-scheme/optimizer/tests/double-float.rkt new file mode 100644 index 00000000..951ced61 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/double-float.rkt @@ -0,0 +1,10 @@ +#; +( +double-float.rkt line 10 col 1 - + - binary float +6.0 +) + +#lang typed/scheme +#:optimize + +(+ 2.0 2.0 2.0) diff --git a/collects/tests/typed-scheme/optimizer/tests/exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/tests/exact-inexact.rkt new file mode 100644 index 00000000..e2efe744 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/exact-inexact.rkt @@ -0,0 +1,10 @@ +#; +( +exact-inexact.rkt line 10 col 1 - exact->inexact - int to float +1e+100 +) + +#lang typed/scheme +#:optimize + +(exact->inexact (expt 10 100)) ; must not be a fixnum diff --git a/collects/tests/typed-scheme/optimizer/tests/fixnum-comparison.rkt b/collects/tests/typed-scheme/optimizer/tests/fixnum-comparison.rkt new file mode 100644 index 00000000..7dcbebe6 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/fixnum-comparison.rkt @@ -0,0 +1,12 @@ +#; +( +fixnum-comparison.rkt line 12 col 4 - vector-length - vector-length +#f line #f col #f - op - string-length +fixnum-comparison.rkt line 12 col 1 - < - binary fixnum +#t +) + +#lang typed/scheme +#:optimize + +(< (vector-length '#(1 2 3)) (string-length "asdf")) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-comp.rkt b/collects/tests/typed-scheme/optimizer/tests/float-comp.rkt new file mode 100644 index 00000000..0cd0d1ef --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-comp.rkt @@ -0,0 +1,10 @@ +#; +( +float-comp.rkt line 10 col 1 - < - binary float comp +#t +) + +#lang typed/scheme +#:optimize + +(< 1.0 2.0) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate-top.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate-top.rkt new file mode 100644 index 00000000..004a0a38 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate-top.rkt @@ -0,0 +1,14 @@ +#; +( +float-complex-conjugate-top.rkt line 14 col 14 - 1.0+2.0i - unboxed literal +float-complex-conjugate-top.rkt line 14 col 23 - 2.0+4.0i - unboxed literal +float-complex-conjugate-top.rkt line 14 col 12 - + - unboxed binary float complex +float-complex-conjugate-top.rkt line 14 col 1 - conjugate - unboxed unary float complex +float-complex-conjugate-top.rkt line 14 col 0 - (#%app conjugate (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i))) - unboxed float complex +3.0-6.0i +) + +#lang typed/scheme +#:optimize + +(conjugate (+ 1.0+2.0i 2.0+4.0i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate.rkt new file mode 100644 index 00000000..5ccabd70 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-conjugate.rkt @@ -0,0 +1,15 @@ +#; +( +float-complex-conjugate.rkt line 15 col 14 - 1.0+2.0i - unboxed literal +float-complex-conjugate.rkt line 15 col 4 - conjugate - unboxed unary float complex +float-complex-conjugate.rkt line 15 col 35 - 2.0+4.0i - unboxed literal +float-complex-conjugate.rkt line 15 col 25 - conjugate - unboxed unary float complex +float-complex-conjugate.rkt line 15 col 1 - + - unboxed binary float complex +float-complex-conjugate.rkt line 15 col 0 - (#%app + (#%app conjugate (quote 1.0+2.0i)) (#%app conjugate (quote 2.0+4.0i))) - unboxed float complex +3.0-6.0i +) + +#lang typed/scheme +#:optimize + +(+ (conjugate 1.0+2.0i) (conjugate 2.0+4.0i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-div.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-div.rkt new file mode 100644 index 00000000..d832839f --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-div.rkt @@ -0,0 +1,14 @@ +#; +( +float-complex-div.rkt line 14 col 3 - 1.0+2.0i - unboxed literal +float-complex-div.rkt line 14 col 12 - 2.0+4.0i - unboxed literal +float-complex-div.rkt line 14 col 21 - 3.0+6.0i - unboxed literal +float-complex-div.rkt line 14 col 1 - / - unboxed binary float complex +float-complex-div.rkt line 14 col 0 - (#%app / (quote 1.0+2.0i) (quote 2.0+4.0i) (quote 3.0+6.0i)) - unboxed float complex +0.03333333333333333-0.06666666666666667i +) + +#lang typed/scheme +#:optimize + +(/ 1.0+2.0i 2.0+4.0i 3.0+6.0i) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-fixnum.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-fixnum.rkt new file mode 100644 index 00000000..0d565583 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-fixnum.rkt @@ -0,0 +1,16 @@ +#; +( +float-complex-fixnum.rkt line 16 col 4 - modulo - binary nonzero fixnum +float-complex-fixnum.rkt line 16 col 4 - modulo - binary nonzero fixnum +float-complex-fixnum.rkt line 16 col 3 - (#%app modulo (quote 2) (quote 1)) - float-coerce-expr in complex ops +float-complex-fixnum.rkt line 16 col 16 - 1.0+2.0i - unboxed literal +float-complex-fixnum.rkt line 16 col 25 - 3.0+6.0i - unboxed literal +float-complex-fixnum.rkt line 16 col 1 - + - unboxed binary float complex +float-complex-fixnum.rkt line 16 col 0 - (#%app + (#%app modulo (quote 2) (quote 1)) (quote 1.0+2.0i) (quote 3.0+6.0i)) - unboxed float complex +4.0+8.0i +) + +#lang typed/scheme +#:optimize + +(+ (modulo 2 1) 1.0+2.0i 3.0+6.0i) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-float-div.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-float-div.rkt new file mode 100644 index 00000000..20e64f21 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-float-div.rkt @@ -0,0 +1,56 @@ +#; +( +float-complex-float-div.rkt line 47 col 62 - x - unbox float-complex +float-complex-float-div.rkt line 47 col 52 - real-part - unboxed float complex +float-complex-float-div.rkt line 48 col 62 - x - unbox float-complex +float-complex-float-div.rkt line 48 col 52 - imag-part - unboxed float complex +float-complex-float-div.rkt line 50 col 9 - (quote 1.0) - float-coerce-expr in complex ops +float-complex-float-div.rkt line 50 col 13 - 2.0+4.0i - unboxed literal +float-complex-float-div.rkt line 50 col 7 - / - unboxed binary float complex +float-complex-float-div.rkt line 50 col 6 - (#%app / (quote 1.0) (quote 2.0+4.0i)) - unboxed float complex +float-complex-float-div.rkt line 51 col 9 - 1.0+2.0i - unboxed literal +float-complex-float-div.rkt line 51 col 18 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float-div.rkt line 51 col 7 - / - unboxed binary float complex +float-complex-float-div.rkt line 51 col 6 - (#%app / (quote 1.0+2.0i) (quote 2.0)) - unboxed float complex +float-complex-float-div.rkt line 52 col 9 - (quote 1.0) - float-coerce-expr in complex ops +float-complex-float-div.rkt line 52 col 13 - 2.0+4.0i - unboxed literal +float-complex-float-div.rkt line 52 col 22 - 3.0+6.0i - unboxed literal +float-complex-float-div.rkt line 52 col 7 - / - unboxed binary float complex +float-complex-float-div.rkt line 52 col 6 - (#%app / (quote 1.0) (quote 2.0+4.0i) (quote 3.0+6.0i)) - unboxed float complex +float-complex-float-div.rkt line 53 col 9 - 1.0+2.0i - unboxed literal +float-complex-float-div.rkt line 53 col 18 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float-div.rkt line 53 col 22 - 3.0+6.0i - unboxed literal +float-complex-float-div.rkt line 53 col 7 - / - unboxed binary float complex +float-complex-float-div.rkt line 53 col 6 - (#%app / (quote 1.0+2.0i) (quote 2.0) (quote 3.0+6.0i)) - unboxed float complex +float-complex-float-div.rkt line 54 col 9 - 1.0+2.0i - unboxed literal +float-complex-float-div.rkt line 54 col 18 - 2.0+4.0i - unboxed literal +float-complex-float-div.rkt line 54 col 27 - (quote 3.0) - float-coerce-expr in complex ops +float-complex-float-div.rkt line 54 col 7 - / - unboxed binary float complex +float-complex-float-div.rkt line 54 col 6 - (#%app / (quote 1.0+2.0i) (quote 2.0+4.0i) (quote 3.0)) - unboxed float complex +float-complex-float-div.rkt line 55 col 9 - 1.0+2.0i - unboxed literal +float-complex-float-div.rkt line 55 col 18 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float-div.rkt line 55 col 22 - (quote 3.0) - float-coerce-expr in complex ops +float-complex-float-div.rkt line 55 col 7 - / - unboxed binary float complex +float-complex-float-div.rkt line 55 col 6 - (#%app / (quote 1.0+2.0i) (quote 2.0) (quote 3.0)) - unboxed float complex +float-complex-float-div.rkt line 56 col 9 - (quote 1.0) - float-coerce-expr in complex ops +float-complex-float-div.rkt line 56 col 13 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float-div.rkt line 56 col 17 - 3.0+6.0i - unboxed literal +float-complex-float-div.rkt line 56 col 7 - / - unboxed binary float complex +float-complex-float-div.rkt line 56 col 6 - (#%app / (quote 1.0) (quote 2.0) (quote 3.0+6.0i)) - unboxed float complex +'("0.1000000000-0.2000000000" "0.50000000001.0000000000" "-0.0200000000-0.0266666667" "0.16666666670.0000000000" "0.16666666670.0000000000" "0.16666666670.3333333333" "0.0333333333-0.0666666667") +) + +#lang typed/scheme +#:optimize + +(map (lambda: ((x : Inexact-Complex)) + (string-append (real->decimal-string (real-part x) 10) + (real->decimal-string (imag-part x) 10))) + (list + (/ 1.0 2.0+4.0i) + (/ 1.0+2.0i 2.0) + (/ 1.0 2.0+4.0i 3.0+6.0i) + (/ 1.0+2.0i 2.0 3.0+6.0i) + (/ 1.0+2.0i 2.0+4.0i 3.0) + (/ 1.0+2.0i 2.0 3.0) + (/ 1.0 2.0 3.0+6.0i))) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-float-mul.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-float-mul.rkt new file mode 100644 index 00000000..068906d9 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-float-mul.rkt @@ -0,0 +1,47 @@ +#; +( +float-complex-float-mul.rkt line 42 col 3 - (quote 1.0) - float-coerce-expr in complex ops +float-complex-float-mul.rkt line 42 col 7 - 2.0+4.0i - unboxed literal +float-complex-float-mul.rkt line 42 col 1 - * - unboxed binary float complex +float-complex-float-mul.rkt line 42 col 0 - (#%app * (quote 1.0) (quote 2.0+4.0i)) - unboxed float complex +float-complex-float-mul.rkt line 43 col 3 - 1.0+2.0i - unboxed literal +float-complex-float-mul.rkt line 43 col 12 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float-mul.rkt line 43 col 1 - * - unboxed binary float complex +float-complex-float-mul.rkt line 43 col 0 - (#%app * (quote 1.0+2.0i) (quote 2.0)) - unboxed float complex +float-complex-float-mul.rkt line 44 col 3 - (quote 1.0) - float-coerce-expr in complex ops +float-complex-float-mul.rkt line 44 col 7 - 2.0+4.0i - unboxed literal +float-complex-float-mul.rkt line 44 col 16 - 3.0+6.0i - unboxed literal +float-complex-float-mul.rkt line 44 col 1 - * - unboxed binary float complex +float-complex-float-mul.rkt line 44 col 0 - (#%app * (quote 1.0) (quote 2.0+4.0i) (quote 3.0+6.0i)) - unboxed float complex +float-complex-float-mul.rkt line 45 col 3 - 1.0+2.0i - unboxed literal +float-complex-float-mul.rkt line 45 col 12 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float-mul.rkt line 45 col 16 - 3.0+6.0i - unboxed literal +float-complex-float-mul.rkt line 45 col 1 - * - unboxed binary float complex +float-complex-float-mul.rkt line 45 col 0 - (#%app * (quote 1.0+2.0i) (quote 2.0) (quote 3.0+6.0i)) - unboxed float complex +float-complex-float-mul.rkt line 46 col 3 - 1.0+2.0i - unboxed literal +float-complex-float-mul.rkt line 46 col 12 - 2.0+4.0i - unboxed literal +float-complex-float-mul.rkt line 46 col 21 - (quote 3.0) - float-coerce-expr in complex ops +float-complex-float-mul.rkt line 46 col 1 - * - unboxed binary float complex +float-complex-float-mul.rkt line 46 col 0 - (#%app * (quote 1.0+2.0i) (quote 2.0+4.0i) (quote 3.0)) - unboxed float complex +float-complex-float-mul.rkt line 47 col 3 - 1.0+2.0i - unboxed literal +float-complex-float-mul.rkt line 47 col 12 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float-mul.rkt line 47 col 16 - (quote 3.0) - float-coerce-expr in complex ops +float-complex-float-mul.rkt line 47 col 1 - * - unboxed binary float complex +float-complex-float-mul.rkt line 47 col 0 - (#%app * (quote 1.0+2.0i) (quote 2.0) (quote 3.0)) - unboxed float complex +2.0+4.0i +2.0+4.0i +-18.0+24.0i +-18.0+24.0i +-18.0+24.0i +6.0+12.0i +) + +#lang typed/scheme +#:optimize + +(* 1.0 2.0+4.0i) +(* 1.0+2.0i 2.0) +(* 1.0 2.0+4.0i 3.0+6.0i) +(* 1.0+2.0i 2.0 3.0+6.0i) +(* 1.0+2.0i 2.0+4.0i 3.0) +(* 1.0+2.0i 2.0 3.0) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-float-small.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-float-small.rkt new file mode 100644 index 00000000..b12f779c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-float-small.rkt @@ -0,0 +1,40 @@ +#; +( +float-complex-float-small.rkt line 36 col 3 - 1.0+2.0i - unboxed literal +float-complex-float-small.rkt line 36 col 12 - (quote 3.0) - float-coerce-expr in complex ops +float-complex-float-small.rkt line 36 col 1 - + - unboxed binary float complex +float-complex-float-small.rkt line 36 col 0 - (#%app + (quote 1.0+2.0i) (quote 3.0)) - unboxed float complex +float-complex-float-small.rkt line 37 col 3 - (quote 1.0) - float-coerce-expr in complex ops +float-complex-float-small.rkt line 37 col 7 - 2.0+4.0i - unboxed literal +float-complex-float-small.rkt line 37 col 1 - + - unboxed binary float complex +float-complex-float-small.rkt line 37 col 0 - (#%app + (quote 1.0) (quote 2.0+4.0i)) - unboxed float complex +float-complex-float-small.rkt line 38 col 3 - 1.0+2.0i - unboxed literal +float-complex-float-small.rkt line 38 col 12 - (quote 3.0) - float-coerce-expr in complex ops +float-complex-float-small.rkt line 38 col 1 - - - unboxed binary float complex +float-complex-float-small.rkt line 38 col 0 - (#%app - (quote 1.0+2.0i) (quote 3.0)) - unboxed float complex +float-complex-float-small.rkt line 39 col 3 - (quote 1.0) - float-coerce-expr in complex ops +float-complex-float-small.rkt line 39 col 7 - 2.0+4.0i - unboxed literal +float-complex-float-small.rkt line 39 col 1 - - - unboxed binary float complex +float-complex-float-small.rkt line 39 col 0 - (#%app - (quote 1.0) (quote 2.0+4.0i)) - unboxed float complex +float-complex-float-small.rkt line 40 col 3 - 1.0+2.0i - unboxed literal +float-complex-float-small.rkt line 40 col 15 - (quote 1.0) - float-coerce-expr in complex ops +float-complex-float-small.rkt line 40 col 19 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float-small.rkt line 40 col 13 - + - binary float +float-complex-float-small.rkt line 40 col 12 - (#%app + (quote 1.0) (quote 2.0)) - float-coerce-expr in complex ops +float-complex-float-small.rkt line 40 col 1 - + - unboxed binary float complex +float-complex-float-small.rkt line 40 col 0 - (#%app + (quote 1.0+2.0i) (#%app + (quote 1.0) (quote 2.0))) - unboxed float complex +4.0+2.0i +3.0+4.0i +-2.0+2.0i +-1.0-4.0i +4.0+2.0i +) + +#lang typed/scheme +#:optimize + +(+ 1.0+2.0i 3.0) +(+ 1.0 2.0+4.0i) +(- 1.0+2.0i 3.0) +(- 1.0 2.0+4.0i) +(+ 1.0+2.0i (+ 1.0 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-float.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-float.rkt new file mode 100644 index 00000000..060813b5 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-float.rkt @@ -0,0 +1,35 @@ +#; +( +float-complex-float.rkt line 32 col 3 - 1.0+2.0i - unboxed literal +float-complex-float.rkt line 32 col 12 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float.rkt line 32 col 16 - 3.0+6.0i - unboxed literal +float-complex-float.rkt line 32 col 1 - + - unboxed binary float complex +float-complex-float.rkt line 32 col 0 - (#%app + (quote 1.0+2.0i) (quote 2.0) (quote 3.0+6.0i)) - unboxed float complex +float-complex-float.rkt line 33 col 3 - (quote 1.0) - float-coerce-expr in complex ops +float-complex-float.rkt line 33 col 7 - 2.0+4.0i - unboxed literal +float-complex-float.rkt line 33 col 16 - 3.0+6.0i - unboxed literal +float-complex-float.rkt line 33 col 1 - - - unboxed binary float complex +float-complex-float.rkt line 33 col 0 - (#%app - (quote 1.0) (quote 2.0+4.0i) (quote 3.0+6.0i)) - unboxed float complex +float-complex-float.rkt line 34 col 3 - 1.0+2.0i - unboxed literal +float-complex-float.rkt line 34 col 12 - (quote 2.0) - float-coerce-expr in complex ops +float-complex-float.rkt line 34 col 16 - 3.0+6.0i - unboxed literal +float-complex-float.rkt line 34 col 1 - - - unboxed binary float complex +float-complex-float.rkt line 34 col 0 - (#%app - (quote 1.0+2.0i) (quote 2.0) (quote 3.0+6.0i)) - unboxed float complex +float-complex-float.rkt line 35 col 3 - 1.0+2.0i - unboxed literal +float-complex-float.rkt line 35 col 12 - 2.0+4.0i - unboxed literal +float-complex-float.rkt line 35 col 21 - (quote 3.0) - float-coerce-expr in complex ops +float-complex-float.rkt line 35 col 1 - - - unboxed binary float complex +float-complex-float.rkt line 35 col 0 - (#%app - (quote 1.0+2.0i) (quote 2.0+4.0i) (quote 3.0)) - unboxed float complex +6.0+8.0i +-4.0-10.0i +-4.0-4.0i +-4.0-2.0i +) + +#lang typed/scheme +#:optimize + +(+ 1.0+2.0i 2.0 3.0+6.0i) +(- 1.0 2.0+4.0i 3.0+6.0i) +(- 1.0+2.0i 2.0 3.0+6.0i) +(- 1.0+2.0i 2.0+4.0i 3.0) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-i.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-i.rkt new file mode 100644 index 00000000..83e394cb --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-i.rkt @@ -0,0 +1,15 @@ +#; +( +float-complex-i.rkt line 15 col 3 - 1.0+2.0i - unboxed literal +float-complex-i.rkt line 15 col 15 - 0+1.0i - unboxed literal +float-complex-i.rkt line 15 col 21 - 2.0+4.0i - unboxed literal +float-complex-i.rkt line 15 col 13 - * - unboxed binary float complex +float-complex-i.rkt line 15 col 1 - + - unboxed binary float complex +float-complex-i.rkt line 15 col 0 - (#%app + (quote 1.0+2.0i) (#%app * (quote 0+1.0i) (quote 2.0+4.0i))) - unboxed float complex +-3.0+4.0i +) + +#lang typed/scheme +#:optimize + +(+ 1.0+2.0i (* +1.0i 2.0+4.0i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-integer.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-integer.rkt new file mode 100644 index 00000000..b9033e5d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-integer.rkt @@ -0,0 +1,13 @@ +#; +( +float-complex-integer.rkt line 13 col 3 - (#%app expt (quote 2) (quote 100)) - float-coerce-expr in complex ops +float-complex-integer.rkt line 13 col 16 - 1.0+2.0i - unboxed literal +float-complex-integer.rkt line 13 col 1 - + - unboxed binary float complex +float-complex-integer.rkt line 13 col 0 - (#%app + (#%app expt (quote 2) (quote 100)) (quote 1.0+2.0i)) - unboxed float complex +1.2676506002282294e+30+2.0i +) + +#lang typed/scheme +#:optimize + +(+ (expt 2 100) 1.0+2.0i) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-mult.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-mult.rkt new file mode 100644 index 00000000..0ad65681 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-mult.rkt @@ -0,0 +1,14 @@ +#; +( +float-complex-mult.rkt line 14 col 3 - 1.0+2.0i - unboxed literal +float-complex-mult.rkt line 14 col 12 - 2.0+4.0i - unboxed literal +float-complex-mult.rkt line 14 col 21 - 3.0+6.0i - unboxed literal +float-complex-mult.rkt line 14 col 1 - * - unboxed binary float complex +float-complex-mult.rkt line 14 col 0 - (#%app * (quote 1.0+2.0i) (quote 2.0+4.0i) (quote 3.0+6.0i)) - unboxed float complex +-66.0-12.0i +) + +#lang typed/scheme +#:optimize + +(* 1.0+2.0i 2.0+4.0i 3.0+6.0i) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-parts.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-parts.rkt new file mode 100644 index 00000000..4b3a63dc --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-parts.rkt @@ -0,0 +1,19 @@ +#; +( +float-complex-parts.rkt line 17 col 11 - 1.0+2.0i - unboxed literal +float-complex-parts.rkt line 17 col 1 - real-part - unboxed float complex +float-complex-parts.rkt line 18 col 11 - 1.0+2.0i - unboxed literal +float-complex-parts.rkt line 18 col 1 - imag-part - unboxed float complex +float-complex-parts.rkt line 19 col 11 - 1.0+2.0i - unboxed literal +float-complex-parts.rkt line 19 col 1 - real-part - unboxed float complex +1.0 +2.0 +1.0 +) + +#lang typed/scheme +#:optimize + +(real-part 1.0+2.0i) +(imag-part 1+2.0i) +(real-part 1.0+2i) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-parts2.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-parts2.rkt new file mode 100644 index 00000000..cc1de957 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-parts2.rkt @@ -0,0 +1,49 @@ +#; +( +float-complex-parts2.rkt line 46 col 14 - 1.0+2.0i - unboxed literal +float-complex-parts2.rkt line 46 col 23 - 2.0+4.0i - unboxed literal +float-complex-parts2.rkt line 46 col 12 - + - unboxed binary float complex +float-complex-parts2.rkt line 46 col 11 - (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)) - unboxed float complex +float-complex-parts2.rkt line 46 col 14 - 1.0+2.0i - unboxed literal +float-complex-parts2.rkt line 46 col 23 - 2.0+4.0i - unboxed literal +float-complex-parts2.rkt line 46 col 12 - + - unboxed binary float complex +float-complex-parts2.rkt line 46 col 1 - real-part - unboxed float complex +float-complex-parts2.rkt line 47 col 23 - 1.0+2.0i - unboxed literal +float-complex-parts2.rkt line 47 col 32 - 2.0+4.0i - unboxed literal +float-complex-parts2.rkt line 47 col 21 - + - unboxed binary float complex +float-complex-parts2.rkt line 47 col 20 - (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)) - unboxed float complex +float-complex-parts2.rkt line 47 col 23 - 1.0+2.0i - unboxed literal +float-complex-parts2.rkt line 47 col 32 - 2.0+4.0i - unboxed literal +float-complex-parts2.rkt line 47 col 21 - + - unboxed binary float complex +float-complex-parts2.rkt line 47 col 1 - unsafe-flreal-part - unboxed float complex +float-complex-parts2.rkt line 48 col 14 - 1.0+2.0i - unboxed literal +float-complex-parts2.rkt line 48 col 23 - 2.0+4.0i - unboxed literal +float-complex-parts2.rkt line 48 col 12 - + - unboxed binary float complex +float-complex-parts2.rkt line 48 col 11 - (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)) - unboxed float complex +float-complex-parts2.rkt line 48 col 14 - 1.0+2.0i - unboxed literal +float-complex-parts2.rkt line 48 col 23 - 2.0+4.0i - unboxed literal +float-complex-parts2.rkt line 48 col 12 - + - unboxed binary float complex +float-complex-parts2.rkt line 48 col 1 - imag-part - unboxed float complex +float-complex-parts2.rkt line 49 col 23 - 1.0+2.0i - unboxed literal +float-complex-parts2.rkt line 49 col 32 - 2.0+4.0i - unboxed literal +float-complex-parts2.rkt line 49 col 21 - + - unboxed binary float complex +float-complex-parts2.rkt line 49 col 20 - (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)) - unboxed float complex +float-complex-parts2.rkt line 49 col 23 - 1.0+2.0i - unboxed literal +float-complex-parts2.rkt line 49 col 32 - 2.0+4.0i - unboxed literal +float-complex-parts2.rkt line 49 col 21 - + - unboxed binary float complex +float-complex-parts2.rkt line 49 col 1 - unsafe-flimag-part - unboxed float complex +3.0 +3.0 +6.0 +6.0 +) + +#lang typed/scheme +#:optimize + +(require racket/unsafe/ops) + +(real-part (+ 1.0+2.0i 2.0+4.0i)) +(unsafe-flreal-part (+ 1.0+2.0i 2.0+4.0i)) +(imag-part (+ 1.0+2.0i 2.0+4.0i)) +(unsafe-flimag-part (+ 1.0+2.0i 2.0+4.0i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-parts3.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-parts3.rkt new file mode 100644 index 00000000..957c7d92 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-parts3.rkt @@ -0,0 +1,45 @@ +#; +( +float-complex-parts3.rkt line 42 col 3 - 1.0+2.0i - unboxed literal +float-complex-parts3.rkt line 42 col 26 - 2.0+4.0i - unboxed literal +float-complex-parts3.rkt line 42 col 35 - 3.0+6.0i - unboxed literal +float-complex-parts3.rkt line 42 col 24 - + - unboxed binary float complex +float-complex-parts3.rkt line 42 col 13 - real-part - unboxed unary float complex +float-complex-parts3.rkt line 42 col 1 - + - unboxed binary float complex +float-complex-parts3.rkt line 42 col 0 - (#%app + (quote 1.0+2.0i) (#%app real-part (#%app + (quote 2.0+4.0i) (quote 3.0+6.0i)))) - unboxed float complex +float-complex-parts3.rkt line 43 col 3 - 1.0+2.0i - unboxed literal +float-complex-parts3.rkt line 43 col 35 - 2.0+4.0i - unboxed literal +float-complex-parts3.rkt line 43 col 44 - 3.0+6.0i - unboxed literal +float-complex-parts3.rkt line 43 col 33 - + - unboxed binary float complex +float-complex-parts3.rkt line 43 col 13 - unsafe-flreal-part - unboxed unary float complex +float-complex-parts3.rkt line 43 col 1 - + - unboxed binary float complex +float-complex-parts3.rkt line 43 col 0 - (#%app + (quote 1.0+2.0i) (#%app unsafe-flreal-part (#%app + (quote 2.0+4.0i) (quote 3.0+6.0i)))) - unboxed float complex +float-complex-parts3.rkt line 44 col 3 - 1.0+2.0i - unboxed literal +float-complex-parts3.rkt line 44 col 26 - 2.0+4.0i - unboxed literal +float-complex-parts3.rkt line 44 col 35 - 3.0+6.0i - unboxed literal +float-complex-parts3.rkt line 44 col 24 - + - unboxed binary float complex +float-complex-parts3.rkt line 44 col 13 - imag-part - unboxed unary float complex +float-complex-parts3.rkt line 44 col 1 - + - unboxed binary float complex +float-complex-parts3.rkt line 44 col 0 - (#%app + (quote 1.0+2.0i) (#%app imag-part (#%app + (quote 2.0+4.0i) (quote 3.0+6.0i)))) - unboxed float complex +float-complex-parts3.rkt line 45 col 3 - 1.0+2.0i - unboxed literal +float-complex-parts3.rkt line 45 col 35 - 2.0+4.0i - unboxed literal +float-complex-parts3.rkt line 45 col 44 - 3.0+6.0i - unboxed literal +float-complex-parts3.rkt line 45 col 33 - + - unboxed binary float complex +float-complex-parts3.rkt line 45 col 13 - unsafe-flimag-part - unboxed unary float complex +float-complex-parts3.rkt line 45 col 1 - + - unboxed binary float complex +float-complex-parts3.rkt line 45 col 0 - (#%app + (quote 1.0+2.0i) (#%app unsafe-flimag-part (#%app + (quote 2.0+4.0i) (quote 3.0+6.0i)))) - unboxed float complex +6.0+2.0i +6.0+2.0i +11.0+2.0i +11.0+2.0i +) + +#lang typed/scheme +#:optimize + +(require racket/unsafe/ops) + +(+ 1.0+2.0i (real-part (+ 2.0+4.0i 3.0+6.0i))) +(+ 1.0+2.0i (unsafe-flreal-part (+ 2.0+4.0i 3.0+6.0i))) +(+ 1.0+2.0i (imag-part (+ 2.0+4.0i 3.0+6.0i))) +(+ 1.0+2.0i (unsafe-flimag-part (+ 2.0+4.0i 3.0+6.0i))) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex-sin.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex-sin.rkt new file mode 100644 index 00000000..0211deb0 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex-sin.rkt @@ -0,0 +1,15 @@ +#; +( +float-complex-sin.rkt line 14 col 13 - (#%app sin (#%app * t (quote 6.28))) - float-coerce-expr in complex ops +float-complex-sin.rkt line 14 col 30 - 0.0+0.0i - unboxed literal +float-complex-sin.rkt line 14 col 11 - + - unboxed binary float complex +float-complex-sin.rkt line 14 col 10 - (#%app + (#%app sin (#%app * t (quote 6.28))) (quote 0.0+0.0i)) - unboxed float complex +-0.0031853017931379904+0.0i +) + +#lang typed/scheme +#:optimize + +((lambda: ((t : Integer)) + (+ (sin (* t 6.28)) 0.0+0.0i)) + 1) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-complex.rkt b/collects/tests/typed-scheme/optimizer/tests/float-complex.rkt new file mode 100644 index 00000000..64721469 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-complex.rkt @@ -0,0 +1,19 @@ +#; +( +float-complex.rkt line 18 col 3 - 1.0+2.0i - unboxed literal +float-complex.rkt line 18 col 12 - 2.0+4.0i - unboxed literal +float-complex.rkt line 18 col 1 - + - unboxed binary float complex +float-complex.rkt line 18 col 0 - (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)) - unboxed float complex +float-complex.rkt line 19 col 3 - 1.0+2.0i - unboxed literal +float-complex.rkt line 19 col 12 - 2.0+4.0i - unboxed literal +float-complex.rkt line 19 col 1 - - - unboxed binary float complex +float-complex.rkt line 19 col 0 - (#%app - (quote 1.0+2.0i) (quote 2.0+4.0i)) - unboxed float complex +3.0+6.0i +-1.0-2.0i +) + +#lang typed/scheme +#:optimize + +(+ 1.0+2.0i 2.0+4.0i) +(- 1.0+2.0i 2.0+4.0i) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-fun.rkt b/collects/tests/typed-scheme/optimizer/tests/float-fun.rkt new file mode 100644 index 00000000..b659085c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-fun.rkt @@ -0,0 +1,12 @@ +#; +( +float-fun.rkt line 12 col 3 - + - binary float +) + +#lang typed/racket +#:optimize + + +(: f (Float -> Float)) +(define (f x) + (+ x 1.0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/float-promotion.rkt b/collects/tests/typed-scheme/optimizer/tests/float-promotion.rkt new file mode 100644 index 00000000..383a9a05 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/float-promotion.rkt @@ -0,0 +1,14 @@ +#; +( +float-promotion.rkt line 13 col 4 - modulo - binary nonzero fixnum +float-promotion.rkt line 13 col 1 - + - binary float +float-promotion.rkt line 14 col 1 - + - binary float +2.0 +1e+200 +) + +#lang typed/scheme +#:optimize + +(+ (modulo 1 1) 2.0) +(+ (expt 100 100) 2.0) diff --git a/collects/tests/typed-scheme/optimizer/tests/flvector-length.rkt b/collects/tests/typed-scheme/optimizer/tests/flvector-length.rkt new file mode 100644 index 00000000..5d30913b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/flvector-length.rkt @@ -0,0 +1,10 @@ +#; +( +flvector-length.rkt line 10 col 1 - flvector-length - flvector-length +2 +) + +#lang typed/scheme +#:optimize +(require racket/flonum) +(flvector-length (flvector 0.0 1.2)) diff --git a/collects/tests/typed-scheme/optimizer/tests/fx-fl.rkt b/collects/tests/typed-scheme/optimizer/tests/fx-fl.rkt new file mode 100644 index 00000000..7e63776a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/fx-fl.rkt @@ -0,0 +1,10 @@ +#; +( +fx-fl.rkt line 10 col 1 - exact->inexact - fixnum to float +1.0 +) + +#lang typed/scheme +#:optimize + +(exact->inexact 1) diff --git a/collects/tests/typed-scheme/optimizer/tests/in-bytes.rkt b/collects/tests/typed-scheme/optimizer/tests/in-bytes.rkt new file mode 100644 index 00000000..1835fe3f --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/in-bytes.rkt @@ -0,0 +1,10 @@ +#; +( +#f line #f col #f - make-sequence - in-bytes +495051) + +#lang typed/scheme +#:optimize + +(for: ((i : Integer #"123")) + (display i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/in-list.rkt b/collects/tests/typed-scheme/optimizer/tests/in-list.rkt new file mode 100644 index 00000000..d32781de --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/in-list.rkt @@ -0,0 +1,10 @@ +#; +( +#f line #f col #f - make-sequence - in-list +123) + +#lang typed/scheme +#:optimize + +(for: ((i : Natural '(1 2 3))) + (display i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/in-string.rkt b/collects/tests/typed-scheme/optimizer/tests/in-string.rkt new file mode 100644 index 00000000..869316f4 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/in-string.rkt @@ -0,0 +1,10 @@ +#; +( +#f line #f col #f - make-sequence - in-string +123) + +#lang typed/scheme +#:optimize + +(for: ((i : Char "123")) + (display i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/in-vector.rkt b/collects/tests/typed-scheme/optimizer/tests/in-vector.rkt new file mode 100644 index 00000000..cabc9474 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/in-vector.rkt @@ -0,0 +1,10 @@ +#; +( +#f line #f col #f - make-sequence - in-vector +123) + +#lang typed/scheme +#:optimize + +(for: ((i : Integer (vector 1 2 3))) + (display i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-binary-nonzero-fixnum.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-binary-nonzero-fixnum.rkt new file mode 100644 index 00000000..d4090067 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-binary-nonzero-fixnum.rkt @@ -0,0 +1,8 @@ +#; +() + +#lang typed/scheme +#:optimize +(: f ( -> Void)) +(define (f) ; in a function, to prevent evaluation + (display (quotient 4 0))) ; 2 fixnums, but the second is 0, cannot optimize diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-derived-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-derived-pair.rkt new file mode 100644 index 00000000..89a4ca52 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-derived-pair.rkt @@ -0,0 +1,14 @@ +#; +() + +#lang typed/racket #:optimize + +;; can't optimize, the lists may not be long enough +(: f ((Listof Integer) -> Integer)) +(define (f x) + (cadr x)) +(: g ((Listof Integer) -> Integer)) +(define (g x) + (if (null? x) + 0 + (cadr x))) diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-exact-inexact.rkt new file mode 100644 index 00000000..283a9c37 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-exact-inexact.rkt @@ -0,0 +1,9 @@ +#; +( +invalid-exact-inexact.rkt line 9 col 1 - exact->inexact - float to float +1.0 +) + +#lang typed/scheme +#:optimize +(exact->inexact 1.0) ; not an integer, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-float-comp.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-float-comp.rkt new file mode 100644 index 00000000..5e2c31ab --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-float-comp.rkt @@ -0,0 +1,9 @@ +#; +( +#t +) + +#lang typed/scheme +#:optimize + +(< 1.0 2) diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-float-promotion.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-float-promotion.rkt new file mode 100644 index 00000000..5a2588a8 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-float-promotion.rkt @@ -0,0 +1,8 @@ +#; +( +0.5 +) + +#lang typed/scheme +#:optimize +(/ 1 2.0) ; result is not a float, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-inexact-complex-parts.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-inexact-complex-parts.rkt new file mode 100644 index 00000000..3a8bad9e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-inexact-complex-parts.rkt @@ -0,0 +1,8 @@ +#; +( +1 +) + +#lang typed/scheme +#:optimize +(real-part 1+2i) diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-log-complex.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-log-complex.rkt new file mode 100644 index 00000000..e397660e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-log-complex.rkt @@ -0,0 +1,9 @@ +#; +( +0.6931471805599453 +) + +#lang typed/scheme +#:optimize + +(real-part (log 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-make-flrectangular.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-make-flrectangular.rkt new file mode 100644 index 00000000..607b0d4a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-make-flrectangular.rkt @@ -0,0 +1,8 @@ +#; +( +1+2i +) + +#lang typed/scheme +#:optimize +(make-rectangular 1 2) diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-make-polar.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-make-polar.rkt new file mode 100644 index 00000000..4c3b0d1d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-make-polar.rkt @@ -0,0 +1,9 @@ +#; +( +0 +) + +#lang typed/scheme +#:optimize + +(make-polar 0 0) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-mpair.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-mpair.rkt similarity index 63% rename from collects/tests/typed-scheme/optimizer/generic/invalid-mpair.rkt rename to collects/tests/typed-scheme/optimizer/tests/invalid-mpair.rkt index a7a74511..3d2995ba 100644 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-mpair.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-mpair.rkt @@ -1,4 +1,8 @@ -#lang typed/scheme #:optimize +#; +() + +#lang typed/scheme +#:optimize (: f ((MListof Integer) -> Integer)) (define (f x) (mcar x)) diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-sqrt.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-sqrt.rkt new file mode 100644 index 00000000..2f9bb37a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-sqrt.rkt @@ -0,0 +1,8 @@ +#; +( +0+1.4142135623730951i +) + +#lang typed/scheme +#:optimize +(sqrt -2.0) ; not a nonnegative flonum, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-unboxed-let.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-unboxed-let.rkt new file mode 100644 index 00000000..b7eb57fb --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-unboxed-let.rkt @@ -0,0 +1,41 @@ +#; +( +invalid-unboxed-let.rkt line 38 col 14 - t1 - unbox float-complex +invalid-unboxed-let.rkt line 38 col 17 - t1 - unbox float-complex +invalid-unboxed-let.rkt line 38 col 12 - + - unboxed binary float complex +invalid-unboxed-let.rkt line 38 col 11 - (#%app + t1 t1) - unboxed float complex +invalid-unboxed-let.rkt line 38 col 14 - t1 - unbox float-complex +invalid-unboxed-let.rkt line 38 col 17 - t1 - unbox float-complex +invalid-unboxed-let.rkt line 38 col 12 - + - unboxed binary float complex +invalid-unboxed-let.rkt line 38 col 11 - (#%app + t1 t1) - unboxed float complex +invalid-unboxed-let.rkt line 38 col 14 - t1 - unbox float-complex +invalid-unboxed-let.rkt line 38 col 17 - t1 - unbox float-complex +invalid-unboxed-let.rkt line 38 col 12 - + - unboxed binary float complex +invalid-unboxed-let.rkt line 38 col 11 - (#%app + t1 t1) - unboxed float complex +invalid-unboxed-let.rkt line 34 col 13 - 1.0+2.0i - unboxed literal +invalid-unboxed-let.rkt line 34 col 22 - 2.0+4.0i - unboxed literal +invalid-unboxed-let.rkt line 34 col 11 - + - unboxed binary float complex +invalid-unboxed-let.rkt line 35 col 13 - 3.0+6.0i - unboxed literal +invalid-unboxed-let.rkt line 35 col 22 - 4.0+8.0i - unboxed literal +invalid-unboxed-let.rkt line 35 col 11 - + - unboxed binary float complex +invalid-unboxed-let.rkt line 35 col 10 - (#%app + (quote 3.0+6.0i) (quote 4.0+8.0i)) - unboxed float complex +invalid-unboxed-let.rkt line 34 col 0 - (let-values (((t1) (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i))) ((t2) (#%app + (quote 3.0+6.0i) (quote 4.0+8.0i))) ((t3) (quote 1.0+2.0i)) ((t4) (quote 1))) (#%app display (#%app + t1 t1)) (#%app display t2) (#%app display t3) (#%app display t4)) - unboxed let bindings +invalid-unboxed-let.rkt line 38 col 14 - t1 - leave var unboxed +invalid-unboxed-let.rkt line 38 col 17 - t1 - leave var unboxed +invalid-unboxed-let.rkt line 38 col 12 - + - unboxed binary float complex +invalid-unboxed-let.rkt line 38 col 11 - (#%app + t1 t1) - unboxed float complex +6.0+12.0i7.0+14.0i1.0+2.0i1) + +#lang typed/scheme +#:optimize + + + +(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/tests/invalid-unboxed-let2.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-unboxed-let2.rkt new file mode 100644 index 00000000..ff2dd31f --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-unboxed-let2.rkt @@ -0,0 +1,25 @@ +#; +( +invalid-unboxed-let2.rkt line 24 col 33 - 1.0+2.0i - unboxed literal +invalid-unboxed-let2.rkt line 24 col 42 - 2.0+4.0i - unboxed literal +invalid-unboxed-let2.rkt line 24 col 31 - + - unboxed binary float complex +invalid-unboxed-let2.rkt line 24 col 30 - (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)) - unboxed float complex +invalid-unboxed-let2.rkt line 24 col 55 - 3.0+6.0i - unboxed literal +invalid-unboxed-let2.rkt line 24 col 64 - 4.0+8.0i - unboxed literal +invalid-unboxed-let2.rkt line 24 col 53 - + - unboxed binary float complex +invalid-unboxed-let2.rkt line 24 col 52 - (#%app + (quote 3.0+6.0i) (quote 4.0+8.0i)) - unboxed float complex +invalid-unboxed-let2.rkt line 25 col 5 - t1 - unbox float-complex +invalid-unboxed-let2.rkt line 25 col 8 - t2 - unbox float-complex +invalid-unboxed-let2.rkt line 25 col 3 - + - unboxed binary float complex +invalid-unboxed-let2.rkt line 25 col 2 - (#%app + t1 t2) - unboxed float complex +10.0+20.0i +) + +#lang typed/scheme +#:optimize + + + +;; 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/tests/invalid-vector-ref.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-vector-ref.rkt new file mode 100644 index 00000000..2bc6634e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-vector-ref.rkt @@ -0,0 +1,8 @@ +#; +() + +#lang typed/scheme +#:optimize +(: f ((Vectorof Integer) -> Integer)) +(define (f x) + (vector-ref x 0)) ; type is (Vectorof Integer), length is unknown, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/tests/invalid-vector-set.rkt b/collects/tests/typed-scheme/optimizer/tests/invalid-vector-set.rkt new file mode 100644 index 00000000..75abb3b6 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/invalid-vector-set.rkt @@ -0,0 +1,8 @@ +#; +() + +#lang typed/scheme +#:optimize +(: f ((Vectorof Integer) -> Void)) +(define (f x) + (vector-set! x 0 2)) ; type is (Vectorof Integer), length is ot known, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/tests/known-vector-length.rkt b/collects/tests/typed-scheme/optimizer/tests/known-vector-length.rkt new file mode 100644 index 00000000..c1503b60 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/known-vector-length.rkt @@ -0,0 +1,11 @@ +#; +( +known-vector-length.rkt line 11 col 6 - vector-length - known-length vector-length +known-vector-length.rkt line 11 col 6 - vector-length - known-length vector-length +4 +) + +#lang typed/scheme +#:optimize + +(+ 2 (vector-length (ann (vector 1 2) (Vector Integer Integer)))) diff --git a/collects/tests/typed-scheme/optimizer/tests/let-float.rkt b/collects/tests/typed-scheme/optimizer/tests/let-float.rkt new file mode 100644 index 00000000..a7e6d6fa --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/let-float.rkt @@ -0,0 +1,12 @@ +#; +( +let-float.rkt line 11 col 10 - + - binary float +let-float.rkt line 12 col 3 - * - binary float +45.0 +) + +#lang typed/scheme +#:optimize + +(let ((x (+ 3.0 2.0))) + (* 9.0 x)) diff --git a/collects/tests/typed-scheme/optimizer/tests/let-rhs.rkt b/collects/tests/typed-scheme/optimizer/tests/let-rhs.rkt new file mode 100644 index 00000000..4ffc7ce5 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/let-rhs.rkt @@ -0,0 +1,13 @@ +#; +( +let-rhs.rkt line 12 col 10 - + - binary float +3.0 +) + +#lang typed/scheme +#:optimize + + + +(let ((x (+ 1.0 2.0))) + x) diff --git a/collects/tests/typed-scheme/optimizer/tests/literal-int.rkt b/collects/tests/typed-scheme/optimizer/tests/literal-int.rkt new file mode 100644 index 00000000..7b54c8f5 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/literal-int.rkt @@ -0,0 +1,14 @@ +#; +( +literal-int.rkt line 13 col 1 - + - binary float +3.0 +1 +) + +#lang typed/scheme +#:optimize + + + +(+ 1 2.0) +1 diff --git a/collects/tests/typed-scheme/optimizer/tests/magnitude.rkt b/collects/tests/typed-scheme/optimizer/tests/magnitude.rkt new file mode 100644 index 00000000..0615ba8b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/magnitude.rkt @@ -0,0 +1,14 @@ +#; +( +magnitude.rkt line 14 col 11 - 3.0+4.0i - unboxed literal +magnitude.rkt line 14 col 1 - magnitude - unboxed unary float complex +magnitude.rkt line 14 col 0 - (#%app magnitude (quote 3.0+4.0i)) - unboxed float complex->float +5.0 +) + +#lang typed/racket/base +#:optimize + + + +(magnitude 3.0+4.0i) diff --git a/collects/tests/typed-scheme/optimizer/tests/make-flrectangular.rkt b/collects/tests/typed-scheme/optimizer/tests/make-flrectangular.rkt new file mode 100644 index 00000000..10e2ce82 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/make-flrectangular.rkt @@ -0,0 +1,13 @@ +#; +( +make-flrectangular.rkt line 12 col 1 - make-rectangular - binary float comp +make-flrectangular.rkt line 13 col 1 - make-flrectangular - binary float comp +1.0+2.2i +1.0+2.2i +) + +#lang typed/scheme +#:optimize +(require racket/flonum) +(make-rectangular 1.0 2.2) +(make-flrectangular 1.0 2.2) diff --git a/collects/tests/typed-scheme/optimizer/tests/make-polar.rkt b/collects/tests/typed-scheme/optimizer/tests/make-polar.rkt new file mode 100644 index 00000000..8fdd9f2e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/make-polar.rkt @@ -0,0 +1,33 @@ +#; +( +make-polar.rkt line 28 col 1 - make-polar - make-rectangular elimination +make-polar.rkt line 28 col 1 - make-polar - make-polar +make-polar.rkt line 32 col 50 - p - unbox float-complex +make-polar.rkt line 32 col 40 - real-part - unboxed unary float complex +make-polar.rkt line 32 col 39 - (#%app real-part p) - unboxed float complex->float +make-polar.rkt line 31 col 12 - 1.0+2.0i - unboxed literal +make-polar.rkt line 31 col 22 - make-polar - make-rectangular elimination +make-polar.rkt line 31 col 10 - + - unboxed binary float complex +make-polar.rkt line 31 col 0 - (let-values (((p) (#%app + (quote 1.0+2.0i) (#%app make-polar (quote 2.0) (quote 4.0))))) (#%app string-append (#%app real->decimal-string (#%app real-part p) (quote 10)) (#%app real->decimal-string (#%app imag-part p) (quote 10)))) - unboxed let bindings +make-polar.rkt line 32 col 50 - p - unboxed complex variable +make-polar.rkt line 32 col 50 - p - leave var unboxed +make-polar.rkt line 32 col 40 - real-part - unboxed float complex +make-polar.rkt line 33 col 50 - p - unboxed complex variable +make-polar.rkt line 33 col 50 - p - leave var unboxed +make-polar.rkt line 33 col 40 - imag-part - unboxed float complex +0.5403023058681398+0.8414709848078965i +"-0.30728724170.4863950094" +) + +#lang typed/scheme +#:optimize + + + +;; top level +(make-polar 1.0 1.0) + +;; nested +(let ((p (+ 1.0+2.0i (make-polar 2.0 4.0)))) + (string-append (real->decimal-string (real-part p) 10) + (real->decimal-string (imag-part p) 10))) diff --git a/collects/tests/typed-scheme/optimizer/tests/maybe-exact-complex.rkt b/collects/tests/typed-scheme/optimizer/tests/maybe-exact-complex.rkt new file mode 100644 index 00000000..12877a75 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/maybe-exact-complex.rkt @@ -0,0 +1,15 @@ +#; +( +maybe-exact-complex.rkt line 15 col 3 - 1.0+2.0i - unboxed literal +maybe-exact-complex.rkt line 15 col 12 - 2+4i - unboxed literal +maybe-exact-complex.rkt line 15 col 1 - + - unboxed binary float complex +maybe-exact-complex.rkt line 15 col 0 - (#%app + (quote 1.0+2.0i) (quote 2+4i)) - unboxed float complex +3.0+6.0i +) + +#lang typed/scheme +#:optimize + + + +(+ 1.0+2.0i 2+4i) diff --git a/collects/tests/typed-scheme/optimizer/tests/mpair.rkt b/collects/tests/typed-scheme/optimizer/tests/mpair.rkt new file mode 100644 index 00000000..ae62abbb --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/mpair.rkt @@ -0,0 +1,27 @@ +#; +( +mpair.rkt line 18 col 1 - mcar - mutable pair +mpair.rkt line 19 col 1 - mcdr - mutable pair +mpair.rkt line 20 col 1 - set-mcar! - mutable pair +mpair.rkt line 21 col 1 - set-mcdr! - mutable pair +mpair.rkt line 21 col 14 - + - binary float +mpair.rkt line 27 col 7 - mcar - mutable pair +1 +1.0 +) + +#lang typed/scheme +#:optimize + +(: x (MPairof Integer Float)) +(define x (mcons 1 1.0)) +(mcar x) +(mcdr x) +(set-mcar! x (+ 1 2)) +(set-mcdr! x (+ 1.0 2.0)) + +(: f ((MListof Integer) -> Integer)) +(define (f x) + (if (null? x) + 0 + (mcar x))) diff --git a/collects/tests/typed-scheme/optimizer/tests/n-ary-float-complex.rkt b/collects/tests/typed-scheme/optimizer/tests/n-ary-float-complex.rkt new file mode 100644 index 00000000..44416db9 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/n-ary-float-complex.rkt @@ -0,0 +1,15 @@ +#; +( +n-ary-float-complex.rkt line 15 col 3 - 1.0+2.0i - unboxed literal +n-ary-float-complex.rkt line 15 col 12 - 2.0+4.0i - unboxed literal +n-ary-float-complex.rkt line 15 col 21 - 3.0+6.0i - unboxed literal +n-ary-float-complex.rkt line 15 col 30 - 4.0+8.0i - unboxed literal +n-ary-float-complex.rkt line 15 col 1 - + - unboxed binary float complex +n-ary-float-complex.rkt line 15 col 0 - (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i) (quote 3.0+6.0i) (quote 4.0+8.0i)) - unboxed float complex +10.0+20.0i +) + +#lang typed/scheme +#:optimize + +(+ 1.0+2.0i 2.0+4.0i 3.0+6.0i 4.0+8.0i) diff --git a/collects/tests/typed-scheme/optimizer/tests/n-ary-float.rkt b/collects/tests/typed-scheme/optimizer/tests/n-ary-float.rkt new file mode 100644 index 00000000..5a02f030 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/n-ary-float.rkt @@ -0,0 +1,10 @@ +#; +( +n-ary-float.rkt line 10 col 1 - + - binary float +6.0 +) + +#lang typed/scheme +#:optimize + +(+ 1.0 2.0 3.0) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-float-complex.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-float-complex.rkt new file mode 100644 index 00000000..850de65b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/nested-float-complex.rkt @@ -0,0 +1,15 @@ +#; +( +nested-float-complex.rkt line 15 col 3 - 1.0+2.0i - unboxed literal +nested-float-complex.rkt line 15 col 15 - 2.0+4.0i - unboxed literal +nested-float-complex.rkt line 15 col 24 - 3.0+6.0i - unboxed literal +nested-float-complex.rkt line 15 col 13 - - - unboxed binary float complex +nested-float-complex.rkt line 15 col 1 - + - unboxed binary float complex +nested-float-complex.rkt line 15 col 0 - (#%app + (quote 1.0+2.0i) (#%app - (quote 2.0+4.0i) (quote 3.0+6.0i))) - unboxed float complex +0.0+0.0i +) + +#lang typed/scheme +#:optimize + +(+ 1.0+2.0i (- 2.0+4.0i 3.0+6.0i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-float.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-float.rkt new file mode 100644 index 00000000..326150d9 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/nested-float.rkt @@ -0,0 +1,11 @@ +#; +( +nested-float.rkt line 11 col 8 - + - binary float +nested-float.rkt line 11 col 1 - + - binary float +9.0 +) + +#lang typed/scheme +#:optimize + +(+ 2.0 (+ 3.0 4.0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-float2.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-float2.rkt new file mode 100644 index 00000000..942424a1 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/nested-float2.rkt @@ -0,0 +1,11 @@ +#; +( +nested-float2.rkt line 11 col 8 - * - binary float +nested-float2.rkt line 11 col 1 - + - binary float +14.0 +) + +#lang typed/scheme +#:optimize + +(+ 2.0 (* 3.0 4.0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt new file mode 100644 index 00000000..8a44e45b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/nested-let-loop.rkt @@ -0,0 +1,57 @@ +#; +( +nested-let-loop.rkt line 56 col 38 - r - unbox float-complex +nested-let-loop.rkt line 56 col 40 - s - unbox float-complex +nested-let-loop.rkt line 56 col 36 - + - unboxed binary float complex +nested-let-loop.rkt line 56 col 35 - (#%app + r s) - unboxed float complex +nested-let-loop.rkt line 49 col 8 - r - unboxed var -> table +nested-let-loop.rkt line 47 col 6 - loop1 - unboxed function -> table +nested-let-loop.rkt line 47 col 6 - loop1 - fun -> unboxed fun +nested-let-loop.rkt line 51 col 10 - r - unboxed complex variable +nested-let-loop.rkt line 56 col 38 - r - leave var unboxed +nested-let-loop.rkt line 56 col 40 - s - unbox float-complex +nested-let-loop.rkt line 56 col 36 - + - unboxed binary float complex +nested-let-loop.rkt line 56 col 35 - (#%app + r s) - unboxed float complex +nested-let-loop.rkt line 54 col 18 - s - unboxed var -> table +nested-let-loop.rkt line 52 col 16 - loop2 - unboxed function -> table +nested-let-loop.rkt line 52 col 16 - loop2 - fun -> unboxed fun +nested-let-loop.rkt line 56 col 38 - r - leave var unboxed +nested-let-loop.rkt line 56 col 40 - s - leave var unboxed +nested-let-loop.rkt line 56 col 36 - + - unboxed binary float complex +nested-let-loop.rkt line 56 col 21 - loop1 - unboxed call site +nested-let-loop.rkt line 56 col 28 - cdr - pair +nested-let-loop.rkt line 56 col 21 - loop1 - call to fun with unboxed args +nested-let-loop.rkt line 57 col 38 - s - leave var unboxed +nested-let-loop.rkt line 57 col 40 - (#%app car x) - unbox float-complex +nested-let-loop.rkt line 57 col 41 - car - pair +nested-let-loop.rkt line 57 col 48 - (#%app car y) - unbox float-complex +nested-let-loop.rkt line 57 col 49 - car - pair +nested-let-loop.rkt line 57 col 36 - + - unboxed binary float complex +nested-let-loop.rkt line 57 col 21 - loop2 - unboxed call site +nested-let-loop.rkt line 57 col 28 - cdr - pair +nested-let-loop.rkt line 57 col 21 - loop2 - call to fun with unboxed args +nested-let-loop.rkt line 54 col 38 - 0.0+0.0i - unboxed literal +#f line #f col #f - (letrec-values (((loop2) (lambda (y s) (if (#%app null? y) (#%app loop1 (#%app cdr x) (#%app + r s)) (#%app loop2 (#%app cdr y) (#%app + s (#%app car x) (#%app car y))))))) loop2) - unboxed call site +nested-let-loop.rkt line 52 col 16 - loop2 - unboxed let loop +nested-let-loop.rkt line 49 col 28 - 0.0+0.0i - unboxed literal +#f line #f col #f - (letrec-values (((loop1) (lambda (x r) (if (#%app null? x) r (#%app (letrec-values (((loop2) (lambda (y s) (if (#%app null? y) (#%app loop1 (#%app cdr x) (#%app + r s)) (#%app loop2 (#%app cdr y) (#%app + s (#%app car x) (#%app car y))))))) loop2) (quote (3.0+6.0i 4.0+8.0i)) (quote 0.0+0.0i)))))) loop1) - unboxed call site +nested-let-loop.rkt line 47 col 6 - loop1 - unboxed let loop +20.0+40.0i +) + +#lang typed/scheme +#:optimize + + + +(let: loop1 : Inexact-Complex + ((x : (Listof Inexact-Complex) '(1.0+2.0i 2.0+4.0i)) + (r : Inexact-Complex 0.0+0.0i)) + (if (null? x) + r + (let: loop2 : Inexact-Complex + ((y : (Listof Inexact-Complex) '(3.0+6.0i 4.0+8.0i)) + (s : Inexact-Complex 0.0+0.0i)) + (if (null? y) + (loop1 (cdr x) (+ r s)) + (loop2 (cdr y) (+ s (car x) (car y))))))) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt new file mode 100644 index 00000000..7e8a92fc --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/nested-pair1.rkt @@ -0,0 +1,11 @@ +#; +( +nested-pair1.rkt line 11 col 6 - cdr - pair +nested-pair1.rkt line 11 col 1 - car - pair +2 +) + +#lang typed/scheme +#:optimize + +(car (cdr '(1 2))) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt new file mode 100644 index 00000000..d43ba10f --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/nested-pair2.rkt @@ -0,0 +1,11 @@ +#; +( +nested-pair2.rkt line 11 col 6 - cdr - pair +nested-pair2.rkt line 11 col 1 - car - pair +'(2) +) + +#lang typed/scheme +#:optimize + +(car (cdr (cons 3 (cons (cons 2 '()) 1)))) diff --git a/collects/tests/typed-scheme/optimizer/tests/nested-unboxed-let.rkt b/collects/tests/typed-scheme/optimizer/tests/nested-unboxed-let.rkt new file mode 100644 index 00000000..20569e8c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/nested-unboxed-let.rkt @@ -0,0 +1,33 @@ +#; +( +nested-unboxed-let.rkt line 32 col 14 - x - unbox float-complex +nested-unboxed-let.rkt line 32 col 16 - 2.0+3.0i - unboxed literal +nested-unboxed-let.rkt line 32 col 12 - + - unboxed binary float complex +nested-unboxed-let.rkt line 32 col 11 - (#%app + x (quote 2.0+3.0i)) - unboxed float complex +nested-unboxed-let.rkt line 31 col 12 - 1.0+2.0i - unboxed literal +nested-unboxed-let.rkt line 31 col 21 - 2.0+3.0i - unboxed literal +nested-unboxed-let.rkt line 31 col 10 - + - unboxed binary float complex +nested-unboxed-let.rkt line 31 col 0 - (let-values (((x) (#%app + (quote 1.0+2.0i) (quote 2.0+3.0i)))) (let-values (((x) (#%app + x (quote 2.0+3.0i)))) (#%app + x (quote 3.0+6.0i)))) - unboxed let bindings +nested-unboxed-let.rkt line 33 col 7 - x - unbox float-complex +nested-unboxed-let.rkt line 33 col 9 - 3.0+6.0i - unboxed literal +nested-unboxed-let.rkt line 33 col 5 - + - unboxed binary float complex +nested-unboxed-let.rkt line 33 col 4 - (#%app + x (quote 3.0+6.0i)) - unboxed float complex +nested-unboxed-let.rkt line 32 col 14 - x - leave var unboxed +nested-unboxed-let.rkt line 32 col 16 - 2.0+3.0i - unboxed literal +nested-unboxed-let.rkt line 32 col 12 - + - unboxed binary float complex +nested-unboxed-let.rkt line 32 col 2 - (let-values (((x) (#%app + x (quote 2.0+3.0i)))) (#%app + x (quote 3.0+6.0i))) - unboxed let bindings +nested-unboxed-let.rkt line 33 col 7 - x - leave var unboxed +nested-unboxed-let.rkt line 33 col 9 - 3.0+6.0i - unboxed literal +nested-unboxed-let.rkt line 33 col 5 - + - unboxed binary float complex +nested-unboxed-let.rkt line 33 col 4 - (#%app + x (quote 3.0+6.0i)) - unboxed float complex +8.0+14.0i +) + +#lang typed/scheme +#:optimize + + + +(let ((x (+ 1.0+2.0i 2.0+3.0i))) + (let ((x (+ x 2.0+3.0i))) + (+ x 3.0+6.0i))) diff --git a/collects/tests/typed-scheme/optimizer/tests/one-arg-arith.rkt b/collects/tests/typed-scheme/optimizer/tests/one-arg-arith.rkt new file mode 100644 index 00000000..4b8af710 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/one-arg-arith.rkt @@ -0,0 +1,55 @@ +#; +( +one-arg-arith.rkt line 40 col 1 - - - unary fixnum +one-arg-arith.rkt line 41 col 1 - - - unary float +one-arg-arith.rkt line 42 col 1 - / - unary float +one-arg-arith.rkt line 44 col 1 - + - unary number +one-arg-arith.rkt line 45 col 1 - + - unary number +one-arg-arith.rkt line 46 col 1 - + - unary number +one-arg-arith.rkt line 47 col 1 - * - unary number +one-arg-arith.rkt line 48 col 1 - * - unary number +one-arg-arith.rkt line 49 col 1 - * - unary number +one-arg-arith.rkt line 50 col 1 - min - unary number +one-arg-arith.rkt line 51 col 1 - min - unary number +one-arg-arith.rkt line 52 col 1 - min - unary number +one-arg-arith.rkt line 53 col 1 - max - unary number +one-arg-arith.rkt line 54 col 1 - max - unary number +one-arg-arith.rkt line 55 col 1 - max - unary number +-12 +-12.0 +0.23809523809523808 +1 +1.0 +1267650600228229401496703205376 +1 +1.0 +1267650600228229401496703205376 +1 +1.0 +1267650600228229401496703205376 +1 +1.0 +1267650600228229401496703205376 +) + +#lang typed/scheme +#:optimize + + + +(- 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/tests/typed-scheme/optimizer/tests/pair-fun.rkt b/collects/tests/typed-scheme/optimizer/tests/pair-fun.rkt new file mode 100644 index 00000000..b369f81e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/pair-fun.rkt @@ -0,0 +1,13 @@ +#; +( +pair-fun.rkt line 13 col 7 - car - pair +) + +#lang typed/scheme +#:optimize + +(: f ((Listof Integer) -> Integer)) +(define (f x) + (if (null? x) + 1 + (car x))) diff --git a/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt b/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt new file mode 100644 index 00000000..96f4c232 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/pair-known-length-list.rkt @@ -0,0 +1,32 @@ +#; +( +pair-known-length-list.rkt line 27 col 1 - car - pair +pair-known-length-list.rkt line 28 col 1 - cdr - pair +pair-known-length-list.rkt line 29 col 6 - cdr - pair +pair-known-length-list.rkt line 29 col 1 - car - pair +pair-known-length-list.rkt line 30 col 6 - cdr - pair +pair-known-length-list.rkt line 30 col 1 - cdr - pair +pair-known-length-list.rkt line 31 col 11 - cdr - pair +pair-known-length-list.rkt line 31 col 6 - cdr - pair +pair-known-length-list.rkt line 31 col 1 - car - pair +pair-known-length-list.rkt line 32 col 11 - cdr - pair +pair-known-length-list.rkt line 32 col 6 - cdr - pair +pair-known-length-list.rkt line 32 col 1 - cdr - pair +1 +'(2 3) +2 +'(3) +3 +'() +) + +#lang typed/racket #:optimize + +(: x (List Integer Integer Integer)) +(define x (list 1 2 3)) +(car x) +(cdr x) +(car (cdr x)) +(cdr (cdr x)) +(car (cdr (cdr x))) +(cdr (cdr (cdr x))) diff --git a/collects/tests/typed-scheme/optimizer/tests/quote.rkt b/collects/tests/typed-scheme/optimizer/tests/quote.rkt new file mode 100644 index 00000000..a8be9955 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/quote.rkt @@ -0,0 +1,8 @@ +#; +( +'(+ 1.0 2.0) +) + +#lang typed/scheme +#:optimize +'(+ 1.0 2.0) diff --git a/collects/tests/typed-scheme/optimizer/tests/real-part-loop.rkt b/collects/tests/typed-scheme/optimizer/tests/real-part-loop.rkt new file mode 100644 index 00000000..b6bb0384 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/real-part-loop.rkt @@ -0,0 +1,34 @@ +#; +( +real-part-loop.rkt line 31 col 20 - v - unbox float-complex +real-part-loop.rkt line 31 col 10 - real-part - unboxed unary float complex +real-part-loop.rkt line 31 col 9 - (#%app real-part v) - unboxed float complex->float +real-part-loop.rkt line 30 col 13 - v - unboxed var -> table +real-part-loop.rkt line 30 col 6 - loop - unboxed function -> table +real-part-loop.rkt line 30 col 6 - loop - fun -> unboxed fun +real-part-loop.rkt line 31 col 20 - v - unboxed complex variable +real-part-loop.rkt line 31 col 20 - v - leave var unboxed +real-part-loop.rkt line 31 col 10 - real-part - unboxed float complex +real-part-loop.rkt line 31 col 7 - > - binary float comp +real-part-loop.rkt line 33 col 15 - v - leave var unboxed +real-part-loop.rkt line 33 col 17 - (quote 3.6) - float-coerce-expr in complex ops +real-part-loop.rkt line 33 col 13 - + - unboxed binary float complex +real-part-loop.rkt line 33 col 7 - loop - unboxed call site +real-part-loop.rkt line 33 col 7 - loop - call to fun with unboxed args +real-part-loop.rkt line 30 col 15 - 0.0+1.0i - unboxed literal +real-part-loop.rkt line 30 col 1 - (letrec-values (((loop) (lambda (v) (if (#%app > (#%app real-part v) (quote 70000.2)) (quote 0) (#%app loop (#%app + v (quote 3.6))))))) loop) - unboxed call site +real-part-loop.rkt line 30 col 6 - loop - unboxed let loop +0 +) + +#lang typed/racket/base +#:optimize + + + +(ann + (let loop ([v 0.0+1.0i]) + (if (> (real-part v) 70000.2) + 0 + (loop (+ v 3.6)))) + Integer) diff --git a/collects/tests/typed-scheme/optimizer/tests/simple-float.rkt b/collects/tests/typed-scheme/optimizer/tests/simple-float.rkt new file mode 100644 index 00000000..26b3550c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/simple-float.rkt @@ -0,0 +1,10 @@ +#; +( +simple-float.rkt line 10 col 1 - + - binary float +5.0 +) + +#lang typed/scheme +#:optimize + +(+ 2.0 3.0) diff --git a/collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt new file mode 100644 index 00000000..a4586341 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/simple-pair.rkt @@ -0,0 +1,10 @@ +#; +( +simple-pair.rkt line 10 col 1 - car - pair +1 +) + +#lang typed/scheme +#:optimize + +(car (cons 1 2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/sqrt-segfault.rkt b/collects/tests/typed-scheme/optimizer/tests/sqrt-segfault.rkt similarity index 50% rename from collects/tests/typed-scheme/optimizer/generic/sqrt-segfault.rkt rename to collects/tests/typed-scheme/optimizer/tests/sqrt-segfault.rkt index 887eb629..a72b5155 100644 --- a/collects/tests/typed-scheme/optimizer/generic/sqrt-segfault.rkt +++ b/collects/tests/typed-scheme/optimizer/tests/sqrt-segfault.rkt @@ -1,14 +1,21 @@ -#lang typed/scheme #:optimize +#; +( +sqrt-segfault.rkt line 18 col 15 - - - binary float +sqrt-segfault.rkt line 19 col 15 - * - binary float +) + +#lang typed/scheme +#:optimize + -(require racket/unsafe/ops) ;; from the nbody-generic benchmark. -;; the result of sqrt was an Inexact-Complex, so inexact complex opts kicked +;; the result of sqrt was an Inexact-Complex, so float complex opts kicked ;; in but they resulted in segfaulting code. ;; the problem was that having Float be a subtype of Inexact-Complex was wrong ;; since you can't do unsafe-flreal-part of a float (let* ([dx (- 0.0 0.0)] [dist2 (* dx dx)] - [mag (assert (* dist2 (sqrt dist2)) inexact-real?)]) + [mag (assert (* dist2 (sqrt dist2)) flonum?)]) (void)) diff --git a/collects/tests/typed-scheme/optimizer/tests/sqrt.rkt b/collects/tests/typed-scheme/optimizer/tests/sqrt.rkt new file mode 100644 index 00000000..cb5669a3 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/sqrt.rkt @@ -0,0 +1,11 @@ +#; +( +sqrt.rkt line 11 col 3 - sqrt - unary float +) + +#lang typed/scheme +#:optimize + +(: f (Nonnegative-Float -> Nonnegative-Float)) +(define (f x) + (sqrt x)) diff --git a/collects/tests/typed-scheme/optimizer/tests/string-length.rkt b/collects/tests/typed-scheme/optimizer/tests/string-length.rkt new file mode 100644 index 00000000..76cb9976 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/string-length.rkt @@ -0,0 +1,15 @@ +#; +( +#f line #f col #f - op - string-length +#f line #f col #f - op - bytes-length +2 +2 +) + +#lang typed/scheme +#:optimize + + + +(string-length "eh") +(bytes-length #"eh") diff --git a/collects/tests/typed-scheme/optimizer/tests/structs.rkt b/collects/tests/typed-scheme/optimizer/tests/structs.rkt new file mode 100644 index 00000000..be8e651a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/structs.rkt @@ -0,0 +1,14 @@ +#; +( +structs.rkt line 13 col 1 - pt-x - struct ref +structs.rkt line 14 col 1 - set-pt-y! - struct set +3 +) + +#lang typed/scheme +#:optimize + +(define-struct: pt ((x : Integer) (y : Integer)) #:mutable) +(define a (pt 3 4)) +(pt-x a) +(set-pt-y! a 5) diff --git a/collects/tests/typed-scheme/optimizer/tests/unary-fixnum-nested.rkt b/collects/tests/typed-scheme/optimizer/tests/unary-fixnum-nested.rkt new file mode 100644 index 00000000..ff5a1212 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unary-fixnum-nested.rkt @@ -0,0 +1,11 @@ +#; +( +unary-fixnum-nested.rkt line 11 col 6 - bitwise-not - unary fixnum +unary-fixnum-nested.rkt line 11 col 1 - abs - unary fixnum +4 +) + +#lang typed/scheme +#:optimize + +(abs (bitwise-not (length '(1 2 3)))) diff --git a/collects/tests/typed-scheme/optimizer/tests/unary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/tests/unary-fixnum.rkt new file mode 100644 index 00000000..51bb989b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unary-fixnum.rkt @@ -0,0 +1,10 @@ +#; +( +unary-fixnum.rkt line 10 col 1 - bitwise-not - unary fixnum +-5 +) + +#lang typed/scheme +#:optimize + +(bitwise-not 4) diff --git a/collects/tests/typed-scheme/optimizer/tests/unary-float.rkt b/collects/tests/typed-scheme/optimizer/tests/unary-float.rkt new file mode 100644 index 00000000..6d20a253 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unary-float.rkt @@ -0,0 +1,10 @@ +#; +( +unary-float.rkt line 10 col 1 - sin - unary float +0.9092974268256817 +) + +#lang typed/scheme +#:optimize + +(sin 2.0) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-for.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-for.rkt new file mode 100644 index 00000000..bf7dffc8 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-for.rkt @@ -0,0 +1,53 @@ +#; +( +#f line #f col #f - make-sequence - in-list +unboxed-for.rkt line 53 col 9 - i - unbox float-complex +unboxed-for.rkt line 53 col 11 - sum - unbox float-complex +unboxed-for.rkt line 53 col 7 - + - unboxed binary float complex +unboxed-for.rkt line 53 col 6 - (#%app + i sum) - unboxed float complex +unboxed-for.rkt line 53 col 9 - i - unbox float-complex +unboxed-for.rkt line 53 col 11 - sum - unbox float-complex +unboxed-for.rkt line 53 col 7 - + - unboxed binary float complex +unboxed-for.rkt line 53 col 6 - (#%app + i sum) - unboxed float complex +unboxed-for.rkt line 51 col 31 - sum - unboxed var -> table +#f line #f col #f - for-loop - unboxed function -> table +#f line #f col #f - for-loop - fun -> unboxed fun +unboxed-for.rkt line 51 col 31 - sum - unboxed complex variable +unboxed-for.rkt line 53 col 9 - i - unbox float-complex +unboxed-for.rkt line 53 col 11 - sum - unbox float-complex +unboxed-for.rkt line 53 col 7 - + - unboxed binary float complex +unboxed-for.rkt line 53 col 6 - (#%app + i sum) - unboxed float complex +#f line #f col #f - (#%app pos->vals pos) - unbox float-complex +#f line #f col #f - (let-values (((i) (#%app pos->vals pos))) (if (#%expression (#%app val-cont? i)) (let-values (((sum) (let-values (((sum) sum)) (let-values () (#%app + i sum))))) (if (#%expression (#%app all-cont? pos i)) (#%app for-loop sum (#%app pos-next pos)) sum)) sum)) - unboxed let bindings +unboxed-for.rkt line 52 col 13 - i - unboxed complex variable +unboxed-for.rkt line 52 col 13 - i - unboxed complex variable +unboxed-for.rkt line 53 col 9 - i - leave var unboxed +unboxed-for.rkt line 53 col 11 - sum - unbox float-complex +unboxed-for.rkt line 53 col 7 - + - unboxed binary float complex +unboxed-for.rkt line 53 col 6 - (#%app + i sum) - unboxed float complex +unboxed-for.rkt line 51 col 31 - sum - leave var unboxed +#f line #f col #f - (let-values (((sum) sum)) (let-values () (#%app + i sum))) - unboxed let bindings +unboxed-for.rkt line 53 col 9 - i - leave var unboxed +unboxed-for.rkt line 53 col 11 - sum - leave var unboxed +unboxed-for.rkt line 53 col 7 - + - unboxed binary float complex +unboxed-for.rkt line 53 col 6 - (#%app + i sum) - unboxed float complex +unboxed-for.rkt line 52 col 13 - i - unboxed complex variable +unboxed-for.rkt line 51 col 31 - sum - unbox float-complex +#f line #f col #f - for-loop - unboxed call site +#f line #f col #f - for-loop - call to fun with unboxed args +unboxed-for.rkt line 51 col 31 - sum - unboxed complex variable +unboxed-for.rkt line 51 col 31 - sum - unboxed complex variable +unboxed-for.rkt line 51 col 53 - 0.0+0.0i - unboxed literal +unboxed-for.rkt line 51 col 0 - (letrec-values (((for-loop) (lambda (sum pos) (if (#%expression (#%app pos-cont? pos)) (let-values (((i) (#%app pos->vals pos))) (if (#%expression (#%app val-cont? i)) (let-values (((sum) (let-values (((sum) sum)) (let-values () (#%app + i sum))))) (if (#%expression (#%app all-cont? pos i)) (#%app for-loop sum (#%app pos-next pos)) sum)) sum)) sum)))) for-loop) - unboxed call site +#f line #f col #f - for-loop - unboxed let loop +3.0+6.0i +) + +#lang typed/scheme +#:optimize + + + +(for/fold: : Inexact-Complex ((sum : Inexact-Complex 0.0+0.0i)) + ((i : Inexact-Complex '(1.0+2.0i 2.0+4.0i))) + (+ i sum)) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions1.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions1.rkt new file mode 100644 index 00000000..991ee793 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions1.rkt @@ -0,0 +1,29 @@ +#; +( +unboxed-let-functions1.rkt line 28 col 45 - x - unbox float-complex +unboxed-let-functions1.rkt line 28 col 47 - 3.0+6.0i - unboxed literal +unboxed-let-functions1.rkt line 28 col 43 - + - unboxed binary float complex +unboxed-let-functions1.rkt line 28 col 42 - (#%app + x (quote 3.0+6.0i)) - unboxed float complex +unboxed-let-functions1.rkt line 28 col 20 - x - unboxed var -> table +unboxed-let-functions1.rkt line 28 col 7 - f - unboxed function -> table +unboxed-let-functions1.rkt line 28 col 7 - f - fun -> unboxed fun +unboxed-let-functions1.rkt line 28 col 45 - x - leave var unboxed +unboxed-let-functions1.rkt line 28 col 47 - 3.0+6.0i - unboxed literal +unboxed-let-functions1.rkt line 28 col 43 - + - unboxed binary float complex +unboxed-let-functions1.rkt line 28 col 42 - (#%app + x (quote 3.0+6.0i)) - unboxed float complex +unboxed-let-functions1.rkt line 29 col 8 - 1.0+2.0i - unboxed literal +unboxed-let-functions1.rkt line 29 col 17 - 2.0+4.0i - unboxed literal +unboxed-let-functions1.rkt line 29 col 6 - + - unboxed binary float complex +unboxed-let-functions1.rkt line 29 col 3 - f - unboxed call site +unboxed-let-functions1.rkt line 29 col 3 - f - call to fun with unboxed args +6.0+12.0i +) + +#lang typed/scheme +#:optimize + + + +;; simple case, function with single complex arg +(let ((f (lambda: ((x : Inexact-Complex)) (+ x 3.0+6.0i)))) + (f (+ 1.0+2.0i 2.0+4.0i))) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions2.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions2.rkt new file mode 100644 index 00000000..4282f227 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions2.rkt @@ -0,0 +1,37 @@ +#; +( +unboxed-let-functions2.rkt line 35 col 21 - x - unbox float-complex +unboxed-let-functions2.rkt line 35 col 23 - y - unbox float-complex +unboxed-let-functions2.rkt line 35 col 19 - + - unboxed binary float complex +unboxed-let-functions2.rkt line 35 col 18 - (#%app + x y) - unboxed float complex +unboxed-let-functions2.rkt line 34 col 20 - x - unboxed var -> table +unboxed-let-functions2.rkt line 35 col 21 - x - unbox float-complex +unboxed-let-functions2.rkt line 35 col 23 - y - unbox float-complex +unboxed-let-functions2.rkt line 35 col 19 - + - unboxed binary float complex +unboxed-let-functions2.rkt line 35 col 18 - (#%app + x y) - unboxed float complex +unboxed-let-functions2.rkt line 34 col 42 - y - unboxed var -> table +unboxed-let-functions2.rkt line 34 col 7 - f - unboxed function -> table +unboxed-let-functions2.rkt line 34 col 7 - f - fun -> unboxed fun +unboxed-let-functions2.rkt line 35 col 21 - x - leave var unboxed +unboxed-let-functions2.rkt line 35 col 23 - y - leave var unboxed +unboxed-let-functions2.rkt line 35 col 19 - + - unboxed binary float complex +unboxed-let-functions2.rkt line 35 col 18 - (#%app + x y) - unboxed float complex +unboxed-let-functions2.rkt line 36 col 8 - 1.0+2.0i - unboxed literal +unboxed-let-functions2.rkt line 36 col 17 - 2.0+4.0i - unboxed literal +unboxed-let-functions2.rkt line 36 col 6 - + - unboxed binary float complex +unboxed-let-functions2.rkt line 37 col 5 - 3.0+6.0i - unboxed literal +unboxed-let-functions2.rkt line 36 col 3 - f - unboxed call site +unboxed-let-functions2.rkt line 36 col 3 - f - call to fun with unboxed args +6.0+12.0i +) + +#lang typed/scheme +#:optimize + + + +;; function with multiple complex args +(let ((f (lambda: ((x : Inexact-Complex) (y : Inexact-Complex)) + (+ x y)))) + (f (+ 1.0+2.0i 2.0+4.0i) + 3.0+6.0i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions3.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions3.rkt new file mode 100644 index 00000000..737a2068 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions3.rkt @@ -0,0 +1,31 @@ +#; +( +unboxed-let-functions3.rkt line 29 col 21 - x - unbox float-complex +unboxed-let-functions3.rkt line 29 col 23 - y - float-coerce-expr in complex ops +unboxed-let-functions3.rkt line 29 col 19 - + - unboxed binary float complex +unboxed-let-functions3.rkt line 29 col 18 - (#%app + x y) - unboxed float complex +unboxed-let-functions3.rkt line 28 col 20 - x - unboxed var -> table +unboxed-let-functions3.rkt line 28 col 7 - f - unboxed function -> table +unboxed-let-functions3.rkt line 28 col 7 - f - fun -> unboxed fun +unboxed-let-functions3.rkt line 29 col 21 - x - leave var unboxed +unboxed-let-functions3.rkt line 29 col 23 - y - float-coerce-expr in complex ops +unboxed-let-functions3.rkt line 29 col 19 - + - unboxed binary float complex +unboxed-let-functions3.rkt line 29 col 18 - (#%app + x y) - unboxed float complex +unboxed-let-functions3.rkt line 30 col 8 - 1.0+2.0i - unboxed literal +unboxed-let-functions3.rkt line 30 col 17 - 2.0+4.0i - unboxed literal +unboxed-let-functions3.rkt line 30 col 6 - + - unboxed binary float complex +unboxed-let-functions3.rkt line 30 col 3 - f - unboxed call site +unboxed-let-functions3.rkt line 30 col 3 - f - call to fun with unboxed args +6.0+6.0i +) + +#lang typed/scheme +#:optimize + + + +;; function with a mix of complex and non-complex args +(let ((f (lambda: ((x : Inexact-Complex) (y : Float)) + (+ x y)))) + (f (+ 1.0+2.0i 2.0+4.0i) + 3.0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions4.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions4.rkt new file mode 100644 index 00000000..12f4d0a0 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions4.rkt @@ -0,0 +1,31 @@ +#; +( +unboxed-let-functions4.rkt line 29 col 21 - x - unbox float-complex +unboxed-let-functions4.rkt line 29 col 23 - y - float-coerce-expr in complex ops +unboxed-let-functions4.rkt line 29 col 19 - + - unboxed binary float complex +unboxed-let-functions4.rkt line 29 col 18 - (#%app + x y) - unboxed float complex +unboxed-let-functions4.rkt line 28 col 32 - x - unboxed var -> table +unboxed-let-functions4.rkt line 28 col 7 - f - unboxed function -> table +unboxed-let-functions4.rkt line 28 col 7 - f - fun -> unboxed fun +unboxed-let-functions4.rkt line 29 col 21 - x - leave var unboxed +unboxed-let-functions4.rkt line 29 col 23 - y - float-coerce-expr in complex ops +unboxed-let-functions4.rkt line 29 col 19 - + - unboxed binary float complex +unboxed-let-functions4.rkt line 29 col 18 - (#%app + x y) - unboxed float complex +unboxed-let-functions4.rkt line 31 col 8 - 1.0+2.0i - unboxed literal +unboxed-let-functions4.rkt line 31 col 17 - 2.0+4.0i - unboxed literal +unboxed-let-functions4.rkt line 31 col 6 - + - unboxed binary float complex +unboxed-let-functions4.rkt line 30 col 3 - f - unboxed call site +unboxed-let-functions4.rkt line 30 col 3 - f - call to fun with unboxed args +6.0+6.0i +) + +#lang typed/scheme +#:optimize + + + +;; function with a mix of complex and non-complex args, non-complex first +(let ((f (lambda: ((y : Float) (x : Inexact-Complex)) + (+ x y)))) + (f 3.0 + (+ 1.0+2.0i 2.0+4.0i))) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions5.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions5.rkt new file mode 100644 index 00000000..0505dea8 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions5.rkt @@ -0,0 +1,20 @@ +#; +( +unboxed-let-functions5.rkt line 20 col 15 - 1.0+2.0i - unboxed literal +unboxed-let-functions5.rkt line 20 col 24 - 2.0+4.0i - unboxed literal +unboxed-let-functions5.rkt line 20 col 13 - + - unboxed binary float complex +unboxed-let-functions5.rkt line 20 col 12 - (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)) - unboxed float complex +3.0+6.0i +) + +#lang typed/scheme +#:optimize + + + +;; invalid: f "escapes", according to our analysis +(letrec: ((f : (Inexact-Complex -> Inexact-Complex) + (lambda: ((x : Inexact-Complex)) + (let: ((y : (Inexact-Complex -> Inexact-Complex) f)) + x)))) + (f (+ 1.0+2.0i 2.0+4.0i))) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt new file mode 100644 index 00000000..8f52c88d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions6.rkt @@ -0,0 +1,37 @@ +#; +( +unboxed-let-functions6.rkt line 35 col 13 - z - unbox float-complex +unboxed-let-functions6.rkt line 35 col 15 - 0.0+1.0i - unboxed literal +unboxed-let-functions6.rkt line 35 col 11 - + - unboxed binary float complex +unboxed-let-functions6.rkt line 35 col 10 - (#%app + z (quote 0.0+1.0i)) - unboxed float complex +unboxed-let-functions6.rkt line 32 col 31 - z - unboxed var -> table +unboxed-let-functions6.rkt line 32 col 6 - loop - unboxed function -> table +unboxed-let-functions6.rkt line 32 col 6 - loop - fun -> unboxed fun +unboxed-let-functions6.rkt line 35 col 13 - z - leave var unboxed +unboxed-let-functions6.rkt line 35 col 15 - 0.0+1.0i - unboxed literal +unboxed-let-functions6.rkt line 35 col 11 - + - unboxed binary float complex +unboxed-let-functions6.rkt line 35 col 10 - (#%app + z (quote 0.0+1.0i)) - unboxed float complex +unboxed-let-functions6.rkt line 36 col 19 - z - leave var unboxed +unboxed-let-functions6.rkt line 36 col 22 - car - pair +unboxed-let-functions6.rkt line 36 col 21 - (#%app car l) - float-coerce-expr in complex ops +unboxed-let-functions6.rkt line 36 col 17 - + - unboxed binary float complex +unboxed-let-functions6.rkt line 36 col 11 - loop - unboxed call site +unboxed-let-functions6.rkt line 37 col 17 - cdr - pair +unboxed-let-functions6.rkt line 36 col 11 - loop - call to fun with unboxed args +unboxed-let-functions6.rkt line 32 col 51 - 0.0+0.0i - unboxed literal +#f line #f col #f - (letrec-values (((loop) (lambda (z l) (if (#%app null? l) (#%app + z (quote 0.0+1.0i)) (#%app loop (#%app + z (#%app car l)) (#%app cdr l)))))) loop) - unboxed call site +unboxed-let-functions6.rkt line 32 col 6 - loop - unboxed let loop +6.0+1.0i +) + +#lang typed/scheme +#:optimize + + + +(let: loop : Inexact-Complex ((z : Inexact-Complex 0.0+0.0i) + (l : (Listof Integer) '(1 2 3))) + (if (null? l) + (+ z 0.0+1.0i) + (loop (+ z (car l)) + (cdr l)))) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt new file mode 100644 index 00000000..96e07c09 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions7.rkt @@ -0,0 +1,35 @@ +#; +( +unboxed-let-functions7.rkt line 34 col 15 - z - unbox float-complex +unboxed-let-functions7.rkt line 34 col 18 - car - pair +unboxed-let-functions7.rkt line 34 col 17 - (#%app car l) - float-coerce-expr in complex ops +unboxed-let-functions7.rkt line 34 col 13 - + - unboxed binary float complex +unboxed-let-functions7.rkt line 34 col 12 - (#%app + z (#%app car l)) - unboxed float complex +unboxed-let-functions7.rkt line 30 col 31 - z - unboxed var -> table +unboxed-let-functions7.rkt line 30 col 6 - loop - unboxed function -> table +unboxed-let-functions7.rkt line 30 col 6 - loop - fun -> unboxed fun +unboxed-let-functions7.rkt line 33 col 6 - z - unboxed complex variable +unboxed-let-functions7.rkt line 34 col 15 - z - leave var unboxed +unboxed-let-functions7.rkt line 34 col 18 - car - pair +unboxed-let-functions7.rkt line 34 col 17 - (#%app car l) - float-coerce-expr in complex ops +unboxed-let-functions7.rkt line 34 col 13 - + - unboxed binary float complex +unboxed-let-functions7.rkt line 34 col 7 - loop - unboxed call site +unboxed-let-functions7.rkt line 35 col 13 - cdr - pair +unboxed-let-functions7.rkt line 34 col 7 - loop - call to fun with unboxed args +unboxed-let-functions7.rkt line 30 col 51 - 0.0+0.0i - unboxed literal +#f line #f col #f - (letrec-values (((loop) (lambda (z l) (if (#%app null? l) z (#%app loop (#%app + z (#%app car l)) (#%app cdr l)))))) loop) - unboxed call site +unboxed-let-functions7.rkt line 30 col 6 - loop - unboxed let loop +6.0+0.0i +) + +#lang typed/scheme +#:optimize + + + +(let: loop : Inexact-Complex ((z : Inexact-Complex 0.0+0.0i) + (l : (Listof Integer) '(1 2 3))) + (if (null? l) + z ; boxed use. z should be unboxed anyway + (loop (+ z (car l)) + (cdr l)))) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions8.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions8.rkt new file mode 100644 index 00000000..73f41df3 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let-functions8.rkt @@ -0,0 +1,17 @@ +#; +( +unboxed-let-functions8.rkt line 15 col 67 - x - unbox float-complex +unboxed-let-functions8.rkt line 15 col 69 - 2.0+4.0i - unboxed literal +unboxed-let-functions8.rkt line 15 col 65 - + - unboxed binary float complex +unboxed-let-functions8.rkt line 15 col 64 - (#%app + x (quote 2.0+4.0i)) - unboxed float complex +3.0+6.0i +) + +#lang typed/scheme +#:optimize + + + +(letrec: ((f : (Inexact-Complex -> Inexact-Complex) (lambda (x) (+ x 2.0+4.0i))) + (g : (Inexact-Complex -> Inexact-Complex) f)) ; f escapes! can't unbox it's args + (f 1.0+2.0i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let.rkt new file mode 100644 index 00000000..47eb328a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let.rkt @@ -0,0 +1,40 @@ +#; +( +unboxed-let.rkt line 38 col 14 - t1 - unbox float-complex +unboxed-let.rkt line 38 col 17 - 3.0+6.0i - unboxed literal +unboxed-let.rkt line 38 col 12 - - - unboxed binary float complex +unboxed-let.rkt line 38 col 11 - (#%app - t1 (quote 3.0+6.0i)) - unboxed float complex +unboxed-let.rkt line 37 col 14 - 1.0+2.0i - unboxed literal +unboxed-let.rkt line 37 col 23 - 2.0+4.0i - unboxed literal +unboxed-let.rkt line 37 col 12 - + - unboxed binary float complex +unboxed-let.rkt line 37 col 0 - (let-values (((t1) (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)))) (let-values (((t2) (#%app - t1 (quote 3.0+6.0i)))) (let-values (((t3) (quote 4.0+8.0i))) (#%app + t2 t3)))) - unboxed let bindings +unboxed-let.rkt line 40 col 5 - t2 - unbox float-complex +unboxed-let.rkt line 40 col 8 - t3 - unbox float-complex +unboxed-let.rkt line 40 col 3 - + - unboxed binary float complex +unboxed-let.rkt line 40 col 2 - (#%app + t2 t3) - unboxed float complex +unboxed-let.rkt line 38 col 14 - t1 - leave var unboxed +unboxed-let.rkt line 38 col 17 - 3.0+6.0i - unboxed literal +unboxed-let.rkt line 38 col 12 - - - unboxed binary float complex +unboxed-let.rkt line 37 col 0 - (let-values (((t2) (#%app - t1 (quote 3.0+6.0i)))) (let-values (((t3) (quote 4.0+8.0i))) (#%app + t2 t3))) - unboxed let bindings +unboxed-let.rkt line 40 col 5 - t2 - leave var unboxed +unboxed-let.rkt line 40 col 8 - t3 - unbox float-complex +unboxed-let.rkt line 40 col 3 - + - unboxed binary float complex +unboxed-let.rkt line 40 col 2 - (#%app + t2 t3) - unboxed float complex +unboxed-let.rkt line 39 col 11 - 4.0+8.0i - unboxed literal +unboxed-let.rkt line 37 col 0 - (let-values (((t3) (quote 4.0+8.0i))) (#%app + t2 t3)) - unboxed let bindings +unboxed-let.rkt line 40 col 5 - t2 - leave var unboxed +unboxed-let.rkt line 40 col 8 - t3 - leave var unboxed +unboxed-let.rkt line 40 col 3 - + - unboxed binary float complex +unboxed-let.rkt line 40 col 2 - (#%app + t2 t3) - unboxed float complex +4.0+8.0i +) + +#lang typed/scheme +#:optimize + + + +(let* ((t1 (+ 1.0+2.0i 2.0+4.0i)) + (t2 (- t1 3.0+6.0i)) + (t3 4.0+8.0i)) + (+ t2 t3)) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let2.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let2.rkt new file mode 100644 index 00000000..55f51c6b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let2.rkt @@ -0,0 +1,32 @@ +#; +( +unboxed-let2.rkt line 32 col 5 - t1 - unbox float-complex +unboxed-let2.rkt line 32 col 8 - t2 - unbox float-complex +unboxed-let2.rkt line 32 col 3 - + - unboxed binary float complex +unboxed-let2.rkt line 32 col 2 - (#%app + t1 t2) - unboxed float complex +unboxed-let2.rkt line 32 col 5 - t1 - unbox float-complex +unboxed-let2.rkt line 32 col 8 - t2 - unbox float-complex +unboxed-let2.rkt line 32 col 3 - + - unboxed binary float complex +unboxed-let2.rkt line 32 col 2 - (#%app + t1 t2) - unboxed float complex +unboxed-let2.rkt line 30 col 13 - 1.0+2.0i - unboxed literal +unboxed-let2.rkt line 30 col 22 - 2.0+4.0i - unboxed literal +unboxed-let2.rkt line 30 col 11 - + - unboxed binary float complex +unboxed-let2.rkt line 31 col 13 - 3.0+6.0i - unboxed literal +unboxed-let2.rkt line 31 col 22 - 4.0+8.0i - unboxed literal +unboxed-let2.rkt line 31 col 11 - + - unboxed binary float complex +unboxed-let2.rkt line 30 col 0 - (let-values (((t1) (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i))) ((t2) (#%app + (quote 3.0+6.0i) (quote 4.0+8.0i)))) (#%app + t1 t2)) - unboxed let bindings +unboxed-let2.rkt line 32 col 5 - t1 - leave var unboxed +unboxed-let2.rkt line 32 col 8 - t2 - leave var unboxed +unboxed-let2.rkt line 32 col 3 - + - unboxed binary float complex +unboxed-let2.rkt line 32 col 2 - (#%app + t1 t2) - unboxed float complex +10.0+20.0i +) + +#lang typed/scheme +#:optimize + + + +(let ((t1 (+ 1.0+2.0i 2.0+4.0i)) + (t2 (+ 3.0+6.0i 4.0+8.0i))) + (+ t1 t2)) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-let3.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-let3.rkt new file mode 100644 index 00000000..d323037d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-let3.rkt @@ -0,0 +1,34 @@ +#; +( +unboxed-let3.rkt line 34 col 9 - x - unbox float-complex +unboxed-let3.rkt line 34 col 11 - 2.0+4.0i - unboxed literal +unboxed-let3.rkt line 34 col 7 - + - unboxed binary float complex +unboxed-let3.rkt line 34 col 6 - (#%app + x (quote 2.0+4.0i)) - unboxed float complex +unboxed-let3.rkt line 31 col 12 - 1.0+2.0i - unboxed literal +unboxed-let3.rkt line 31 col 21 - 2.0+4.0i - unboxed literal +unboxed-let3.rkt line 31 col 10 - + - unboxed binary float complex +unboxed-let3.rkt line 31 col 0 - (let-values (((x) (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)))) (if (#%app even? (quote 2)) x (#%app + x (quote 2.0+4.0i)))) - unboxed let bindings +unboxed-let3.rkt line 33 col 6 - x - unboxed complex variable +unboxed-let3.rkt line 34 col 9 - x - leave var unboxed +unboxed-let3.rkt line 34 col 11 - 2.0+4.0i - unboxed literal +unboxed-let3.rkt line 34 col 7 - + - unboxed binary float complex +unboxed-let3.rkt line 34 col 6 - (#%app + x (quote 2.0+4.0i)) - unboxed float complex +3.0+6.0i +) + +#lang typed/scheme +#:optimize + + + +;; both boxed and unboxed uses, we unbox anyway +;; causes unnecessary boxing/unboxing if we take a boxed path when +;; unboxing a complex literal or variable, but I expect this case +;; to be uncommon +;; by comparison, cases where we leave a result unboxed and box it +;; if needed (like here) or cases where this would unbox loop variables +;; are likely to be more common, and more interesting +(let ((x (+ 1.0+2.0i 2.0+4.0i))) + (if (even? 2) + x + (+ x 2.0+4.0i))) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-letrec-syntaxes+values.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-letrec-syntaxes+values.rkt new file mode 100644 index 00000000..582ee688 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-letrec-syntaxes+values.rkt @@ -0,0 +1,25 @@ +#; +( +unboxed-letrec-syntaxes+values.rkt line 25 col 27 - x - unbox float-complex +unboxed-letrec-syntaxes+values.rkt line 25 col 29 - 2.0+4.0i - unboxed literal +unboxed-letrec-syntaxes+values.rkt line 25 col 25 - + - unboxed binary float complex +unboxed-letrec-syntaxes+values.rkt line 25 col 24 - (#%app + x (quote 2.0+4.0i)) - unboxed float complex +unboxed-letrec-syntaxes+values.rkt line 24 col 33 - 1.0+2.0i - unboxed literal +unboxed-letrec-syntaxes+values.rkt line 24 col 42 - 2.0+4.0i - unboxed literal +unboxed-letrec-syntaxes+values.rkt line 24 col 31 - + - unboxed binary float complex +unboxed-letrec-syntaxes+values.rkt line 23 col 0 - (letrec-syntaxes+values (((s) (syntax-rules () ((_ x) x)))) (((x) (#%app + (quote 1.0+2.0i) (quote 2.0+4.0i)))) (#%app + x (quote 2.0+4.0i))) - unboxed let bindings +unboxed-letrec-syntaxes+values.rkt line 25 col 27 - x - leave var unboxed +unboxed-letrec-syntaxes+values.rkt line 25 col 29 - 2.0+4.0i - unboxed literal +unboxed-letrec-syntaxes+values.rkt line 25 col 25 - + - unboxed binary float complex +unboxed-letrec-syntaxes+values.rkt line 25 col 24 - (#%app + x (quote 2.0+4.0i)) - unboxed float complex +5.0+10.0i +) + +#lang typed/scheme +#:optimize + + + +(letrec-syntaxes+values (((s) (syntax-rules () [(_ x) x]))) + (((x) (+ 1.0+2.0i 2.0+4.0i))) + (+ x 2.0+4.0i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-letrec.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-letrec.rkt new file mode 100644 index 00000000..0b67b172 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-letrec.rkt @@ -0,0 +1,31 @@ +#; +( +unboxed-letrec.rkt line 31 col 5 - x - unbox float-complex +unboxed-letrec.rkt line 31 col 7 - y - unbox float-complex +unboxed-letrec.rkt line 31 col 3 - + - unboxed binary float complex +unboxed-letrec.rkt line 31 col 2 - (#%app + x y) - unboxed float complex +unboxed-letrec.rkt line 31 col 5 - x - unbox float-complex +unboxed-letrec.rkt line 31 col 7 - y - unbox float-complex +unboxed-letrec.rkt line 31 col 3 - + - unboxed binary float complex +unboxed-letrec.rkt line 31 col 2 - (#%app + x y) - unboxed float complex +unboxed-letrec.rkt line 29 col 31 - 1.0+2.0i - unboxed literal +unboxed-letrec.rkt line 30 col 34 - 2.0+4.0i - unboxed literal +unboxed-letrec.rkt line 30 col 43 - 3.0+6.0i - unboxed literal +unboxed-letrec.rkt line 30 col 32 - + - unboxed binary float complex +unboxed-letrec.rkt line 28 col 0 - (letrec-values (((f) (lambda (x) (#%app f x))) ((x) (quote 1.0+2.0i)) ((y) (#%app + (quote 2.0+4.0i) (quote 3.0+6.0i)))) (#%app + x y)) - unboxed let bindings +unboxed-letrec.rkt line 31 col 5 - x - leave var unboxed +unboxed-letrec.rkt line 31 col 7 - y - leave var unboxed +unboxed-letrec.rkt line 31 col 3 - + - unboxed binary float complex +unboxed-letrec.rkt line 31 col 2 - (#%app + x y) - unboxed float complex +6.0+12.0i +) + +#lang typed/scheme +#:optimize + + + +(letrec: ((f : (Any -> Any) (lambda: ((x : Any)) (f x))) + (x : Inexact-Complex 1.0+2.0i) + (y : Inexact-Complex (+ 2.0+4.0i 3.0+6.0i))) + (+ x y)) diff --git a/collects/tests/typed-scheme/optimizer/tests/unboxed-make-rectangular.rkt b/collects/tests/typed-scheme/optimizer/tests/unboxed-make-rectangular.rkt new file mode 100644 index 00000000..344a6519 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/unboxed-make-rectangular.rkt @@ -0,0 +1,35 @@ +#; +( +unboxed-make-rectangular.rkt line 33 col 5 - x - unbox float-complex +unboxed-make-rectangular.rkt line 33 col 7 - 2.0+4.0i - unboxed literal +unboxed-make-rectangular.rkt line 33 col 3 - + - unboxed binary float complex +unboxed-make-rectangular.rkt line 33 col 2 - (#%app + x (quote 2.0+4.0i)) - unboxed float complex +unboxed-make-rectangular.rkt line 32 col 10 - make-rectangular - make-rectangular elimination +unboxed-make-rectangular.rkt line 32 col 0 - (let-values (((x) (#%app make-rectangular (quote 1.0) (quote 2.0)))) (#%app + x (quote 2.0+4.0i))) - unboxed let bindings +unboxed-make-rectangular.rkt line 33 col 5 - x - leave var unboxed +unboxed-make-rectangular.rkt line 33 col 7 - 2.0+4.0i - unboxed literal +unboxed-make-rectangular.rkt line 33 col 3 - + - unboxed binary float complex +unboxed-make-rectangular.rkt line 33 col 2 - (#%app + x (quote 2.0+4.0i)) - unboxed float complex +unboxed-make-rectangular.rkt line 35 col 5 - x - unbox float-complex +unboxed-make-rectangular.rkt line 35 col 7 - 2.0+4.0i - unboxed literal +unboxed-make-rectangular.rkt line 35 col 3 - + - unboxed binary float complex +unboxed-make-rectangular.rkt line 35 col 2 - (#%app + x (quote 2.0+4.0i)) - unboxed float complex +unboxed-make-rectangular.rkt line 34 col 10 - unsafe-make-flrectangular - make-rectangular elimination +unboxed-make-rectangular.rkt line 34 col 0 - (let-values (((x) (#%app unsafe-make-flrectangular (quote 1.0) (quote 2.0)))) (#%app + x (quote 2.0+4.0i))) - unboxed let bindings +unboxed-make-rectangular.rkt line 35 col 5 - x - leave var unboxed +unboxed-make-rectangular.rkt line 35 col 7 - 2.0+4.0i - unboxed literal +unboxed-make-rectangular.rkt line 35 col 3 - + - unboxed binary float complex +unboxed-make-rectangular.rkt line 35 col 2 - (#%app + x (quote 2.0+4.0i)) - unboxed float complex +3.0+6.0i +3.0+6.0i +) + +#lang typed/scheme +#:optimize + +(require racket/unsafe/ops) + +(let ((x (make-rectangular 1.0 2.0))) + (+ x 2.0+4.0i)) +(let ((x (unsafe-make-flrectangular 1.0 2.0))) + (+ x 2.0+4.0i)) diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-length-nested.rkt b/collects/tests/typed-scheme/optimizer/tests/vector-length-nested.rkt new file mode 100644 index 00000000..c616eaf8 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/vector-length-nested.rkt @@ -0,0 +1,15 @@ +#; +( +vector-length-nested.rkt line 11 col 1 - vector-length - vector-length +vector-length-nested.rkt line 12 col 2 - vector-ref - vector +2 +) + +#lang typed/scheme +#:optimize + +(vector-length + (vector-ref + (ann (vector (vector 1 2) 2 3) + (Vector (Vectorof Integer) Integer Integer)) + 0)) diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-length.rkt b/collects/tests/typed-scheme/optimizer/tests/vector-length.rkt new file mode 100644 index 00000000..c045caa4 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/vector-length.rkt @@ -0,0 +1,10 @@ +#; +( +vector-length.rkt line 10 col 1 - vector-length - vector-length +3 +) + +#lang typed/scheme +#:optimize + +(vector-length (vector 1 2 3)) diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-ref-set-ref.rkt b/collects/tests/typed-scheme/optimizer/tests/vector-ref-set-ref.rkt new file mode 100644 index 00000000..02f1a5d3 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/vector-ref-set-ref.rkt @@ -0,0 +1,17 @@ +#; +( +vector-ref-set-ref.rkt line 15 col 1 - vector-ref - vector +vector-ref-set-ref.rkt line 16 col 1 - vector-set! - vector +vector-ref-set-ref.rkt line 17 col 1 - vector-ref - vector +1 +"2" +) + +#lang typed/scheme +#:optimize + +(: x (Vector Integer String)) +(define x (vector 1 "1")) +(vector-ref x 0) +(vector-set! x 1 "2") +(vector-ref x 1) diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-ref.rkt b/collects/tests/typed-scheme/optimizer/tests/vector-ref.rkt new file mode 100644 index 00000000..68a08817 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/vector-ref.rkt @@ -0,0 +1,10 @@ +#; +( +vector-ref.rkt line 10 col 1 - vector-ref - vector +1 +) + +#lang typed/scheme +#:optimize + +(vector-ref (ann (vector 1 2) (Vector Integer Integer)) 0) diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-ref2.rkt b/collects/tests/typed-scheme/optimizer/tests/vector-ref2.rkt new file mode 100644 index 00000000..d98f6174 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/vector-ref2.rkt @@ -0,0 +1,10 @@ +#; +( +vector-ref2.rkt line 10 col 1 - vector-ref - vector +1 +) + +#lang typed/scheme +#:optimize + +(vector-ref (vector 1 2 3) 0) diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-set-quote.rkt b/collects/tests/typed-scheme/optimizer/tests/vector-set-quote.rkt new file mode 100644 index 00000000..53c29712 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/vector-set-quote.rkt @@ -0,0 +1,11 @@ +#; +( +vector-set-quote.rkt line 9 col 1 - vector-set! - vector +) + +#lang typed/scheme +#:optimize + +(vector-set! (ann (vector '(1 2)) (Vector Any)) + 0 + '(+ 1.0 2.0)) ; we should not optimize under quote diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-set.rkt b/collects/tests/typed-scheme/optimizer/tests/vector-set.rkt new file mode 100644 index 00000000..92af9b8a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/vector-set.rkt @@ -0,0 +1,11 @@ +#; +( +vector-set.rkt line 9 col 1 - vector-set! - vector +) + +#lang typed/scheme +#:optimize + +(vector-set! (ann (vector 1 2) (Vector Integer Integer)) + 0 + 1) diff --git a/collects/tests/typed-scheme/optimizer/tests/vector-set2.rkt b/collects/tests/typed-scheme/optimizer/tests/vector-set2.rkt new file mode 100644 index 00000000..83e5a1f1 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/vector-set2.rkt @@ -0,0 +1,9 @@ +#; +( +vector-set2.rkt line 9 col 1 - vector-set! - vector +) + +#lang typed/scheme +#:optimize + +(vector-set! (vector 1 2) 0 2) ; type is (Vectorof Integer), length is ot known, can't optimize diff --git a/collects/tests/typed-scheme/optimizer/tests/zero.rkt b/collects/tests/typed-scheme/optimizer/tests/zero.rkt new file mode 100644 index 00000000..81eee79c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/tests/zero.rkt @@ -0,0 +1,14 @@ +#; +( +zero.rkt line 13 col 1 - zero? - fixnum zero? +zero.rkt line 14 col 8 - sqrt - unary float +zero.rkt line 14 col 1 - zero? - float zero? +#f +#f +) + +#lang typed/scheme +#:optimize + +(zero? 1) +(zero? (sqrt 3.0)) diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-scheme/run.rkt index 7f40679c..a9b16f90 100644 --- a/collects/tests/typed-scheme/run.rkt +++ b/collects/tests/typed-scheme/run.rkt @@ -4,30 +4,41 @@ (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] + [(the-tests) (the-tests)] + [else + (error "You must specify which tests should be run. See --help for more info.\n")])) + (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.\n"))) (when (opt?) (parameterize ([current-command-line-arguments #()]) (dynamic-require '(file "optimizer/run.rkt") #f)) diff --git a/collects/tests/typed-scheme/succeed/apply-dots-list.rkt b/collects/tests/typed-scheme/succeed/apply-dots-list.rkt index ec5c25fe..cd1b832f 100644 --- a/collects/tests/typed-scheme/succeed/apply-dots-list.rkt +++ b/collects/tests/typed-scheme/succeed/apply-dots-list.rkt @@ -10,14 +10,14 @@ (let aux ([tests tests] [num-passed 0]) (if (null? tests) - (printf "~a tests passed.~n" num-passed) + (printf "~a tests passed.\n" num-passed) (let ((test (car tests))) (let ((actual ((car test))) (expected (cadr test)) (msg (caddr test))) (if (equal? actual expected) (aux (cdr tests) (+ num-passed 1)) - (printf "Test failed: ~a. Expected ~a, got ~a.~n" + (printf "Test failed: ~a. Expected ~a, got ~a.\n" msg expected actual))))))) (apply check-all tests) ; Works in untyped, but not in typed diff --git a/collects/tests/typed-scheme/succeed/at-exp.rkt b/collects/tests/typed-scheme/succeed/at-exp.rkt new file mode 100644 index 00000000..1226a809 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/at-exp.rkt @@ -0,0 +1,9 @@ + +#lang at-exp typed/racket + +(define contents + (lambda args args)) + +(define doc @contents{x y}) + +@contents{x y} \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/basic-tests.rkt b/collects/tests/typed-scheme/succeed/basic-tests.rkt index 7fb9cfb9..f127a11b 100644 --- a/collects/tests/typed-scheme/succeed/basic-tests.rkt +++ b/collects/tests/typed-scheme/succeed/basic-tests.rkt @@ -17,7 +17,7 @@ #;(define: match-test : number (match 3 - [(? number? #{x number}) (+ 17 x)] + [(? number? #{x : number}) (+ 17 x)] [_ 12])) @@ -45,7 +45,7 @@ #;(define: (pt-add/match [v : top]) : number (match v - [($ pt #{x number} #{y number}) (+ x y)] + [($ pt #{x : number} #{y : number}) (+ x y)] [_ 0])) #;(pt-add/match x-struct) @@ -77,9 +77,9 @@ (define: (f [x : number] [y : number]) : number (+ x y)) (define: (g [x : number] [y : number]) : boolean - (let+ (#;[val #{z number} #f] - [val #{x1 number} (* x x)] - [rec #{y1 number} (* y y)]) + (let+ (#;[val #{z : number} #f] + [val #{x1 : number} (* x x)] + [rec #{y1 : number} (* y y)]) #|(define-syntax foo (syntax-rules () [(foo) (= x1 y1)])) diff --git a/collects/tests/typed-scheme/succeed/for-no-anns.rkt b/collects/tests/typed-scheme/succeed/for-no-anns.rkt new file mode 100644 index 00000000..951bc568 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/for-no-anns.rkt @@ -0,0 +1,16 @@ +#lang typed/racket + +;; test for optional annotation on for:-bound variables + +(for: ([i (in-range 10)] ; no annotation + [j : Integer (in-range 10 20)]) + (display (+ i j))) + +(for/fold: : Integer ([acc 0]) + ([i (in-range 10)]) + (+ i acc)) + +(let ((x '(1 3 5 7 9))) + (do: : Number ((x x (cdr x)) + (sum 0 (+ sum (car x)))) + ((null? x) sum))) diff --git a/collects/tests/typed-scheme/succeed/for-over-hash.rkt b/collects/tests/typed-scheme/succeed/for-over-hash.rkt new file mode 100644 index 00000000..be9e007b --- /dev/null +++ b/collects/tests/typed-scheme/succeed/for-over-hash.rkt @@ -0,0 +1,5 @@ +#lang typed/racket + +(: v : (Listof Number)) +(define v (for/list ([(k v) (make-hash (list (cons 1 2) (cons 3 4)))]) + (+ k v))) diff --git a/collects/tests/typed-scheme/succeed/ho-box.rkt b/collects/tests/typed-scheme/succeed/ho-box.rkt new file mode 100644 index 00000000..35edc08e --- /dev/null +++ b/collects/tests/typed-scheme/succeed/ho-box.rkt @@ -0,0 +1,6 @@ +#lang typed/racket + +(: f (Boxof (Number -> Number))) +(define f (box (lambda: ([x : Number]) x))) + +(provide f) diff --git a/collects/tests/typed-scheme/succeed/let-no-anns.rkt b/collects/tests/typed-scheme/succeed/let-no-anns.rkt new file mode 100644 index 00000000..15ff1f3e --- /dev/null +++ b/collects/tests/typed-scheme/succeed/let-no-anns.rkt @@ -0,0 +1,16 @@ +#lang typed/racket + +(let: ((x : Integer 3) + (y 4)) + (+ x y)) + +(let: ((x 3) (y 4)) + (+ x y)) + +(let*: ((x 3) + (y : Integer (+ x 1))) + (+ x y)) + +(letrec: ((x 3) + (y : (Integer -> Integer) (lambda (x) (y x)))) + x) diff --git a/collects/tests/typed-scheme/succeed/mandelbrot.rkt b/collects/tests/typed-scheme/succeed/mandelbrot.rkt new file mode 100644 index 00000000..f481e8ee --- /dev/null +++ b/collects/tests/typed-scheme/succeed/mandelbrot.rkt @@ -0,0 +1,31 @@ +#lang typed/racket/base #:optimize +(require racket/future racket/flonum) +(define: MAX-ITERS : Positive-Fixnum 50) +(define MAX-DIST 2.0) +(define: N : Positive-Fixnum 512) +(: mandelbrot-point : Integer Integer -> Integer) +(define (mandelbrot-point x y) + (define c + (+ (- (/ (* 2.0 (->fl x)) N) 1.5) + (* 0.0+1.0i (- (/ (* 2.0 (->fl y)) N) 1.0)))) + (let loop ((i 0) (z 0.0+0.0i)) + (cond + [(> i MAX-ITERS) (char->integer #\*)] + [(> (magnitude z) MAX-DIST) + (char->integer #\space)] + [else (loop (add1 i) (+ (* z z) c))]))) + +(: fs (Listof (Futureof Bytes))) +(define fs + (for/list ([y (in-range N)]) + (let ([bstr (make-bytes N)]) + (future + (lambda () + (for ([x (in-range N)]) + (bytes-set! bstr x (mandelbrot-point x y))) + bstr))))) + +(lambda () + (for: ([f : (Futureof Bytes) (in-list fs)]) + (write-bytes (touch f)) + (newline))) diff --git a/collects/tests/typed-scheme/succeed/match-expander-problem.rkt b/collects/tests/typed-scheme/succeed/match-expander-problem.rkt index dd563dfc..dc6400e6 100644 --- a/collects/tests/typed-scheme/succeed/match-expander-problem.rkt +++ b/collects/tests/typed-scheme/succeed/match-expander-problem.rkt @@ -14,7 +14,7 @@ (define: (pt-add/match/blah [v : Any]) : Number (match v - [(blah pt #{x Number} #{y Number}) (+ x y)] + [(blah pt #{x : Number} #{y : Number}) (+ x y)] [_ 0])) 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/fail/multi-arr-parse.rkt b/collects/tests/typed-scheme/succeed/multi-arr-parse.rkt similarity index 53% rename from collects/tests/typed-scheme/fail/multi-arr-parse.rkt rename to collects/tests/typed-scheme/succeed/multi-arr-parse.rkt index 10e1171c..9e045421 100644 --- a/collects/tests/typed-scheme/fail/multi-arr-parse.rkt +++ b/collects/tests/typed-scheme/succeed/multi-arr-parse.rkt @@ -1,6 +1,4 @@ -#; -(exn-pred #rx".*once in a form.*") #lang typed/scheme (: foo : (Integer -> Integer -> Integer)) -(define foo 1) +(define ((foo x) y) 1) diff --git a/collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt b/collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt new file mode 100644 index 00000000..4c1f16bd --- /dev/null +++ b/collects/tests/typed-scheme/succeed/mutable-poly-struct.rkt @@ -0,0 +1,9 @@ +#lang typed/racket + +(define-struct: (A) X ([b : A]) #:mutable) + +set-X-b! + +(struct: (A) Foo ([x : Integer]) #:mutable) +(define x (Foo 10)) +(set-Foo-x! x 100) 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/succeed/opt-lambda.rkt b/collects/tests/typed-scheme/succeed/opt-lambda.rkt new file mode 100644 index 00000000..5a55dd7b --- /dev/null +++ b/collects/tests/typed-scheme/succeed/opt-lambda.rkt @@ -0,0 +1,9 @@ +#lang typed/racket + +(: opt (case-lambda ( -> Void) + (Integer -> Void))) +(define opt + (opt-lambda: ((n : Integer 0)) + (display n))) +(opt) +(opt 1) diff --git a/collects/tests/typed-scheme/succeed/require-typed-parse.rkt b/collects/tests/typed-scheme/succeed/require-typed-parse.rkt new file mode 100644 index 00000000..faa11648 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/require-typed-parse.rkt @@ -0,0 +1,16 @@ +#lang racket/load + +(module m1 racket + (define x (make-parameter 1)) + (define y 1) + (provide y) + (provide/contract [x (parameter/c number?)])) + +(module m2 typed/racket + (require/typed 'm1 + [y Number] + [x (Parameterof Number)]) + (x 1) + (x)) + +(require 'm2) diff --git a/collects/tests/typed-scheme/succeed/safe-letrec.rkt b/collects/tests/typed-scheme/succeed/safe-letrec.rkt new file mode 100644 index 00000000..c71b4203 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/safe-letrec.rkt @@ -0,0 +1,23 @@ +#lang typed/racket + +;; make sure letrec takes into account that some bidings may be undefined + +(letrec: ([x : Number 3]) + x) +(letrec: ([x : Number 3] + [y : (-> Number) (lambda () x)]) ; lambdas are safe + y) +(letrec: ([a : (-> Void) (lambda () (b))] + [b : (-> Void) (lambda () (a))]) + a) +(letrec: ([x : (Number -> Number) (lambda (y) (+ y 3))] + [y : Number (x 4)]) + y) +(letrec-values: ([([a : (-> Number)]) (lambda () 3)] + [([b : (-> Number)]) (lambda () (a))] + [([x : Number] [y : Number]) (values (b) (b))]) + x) +(letrec: ([x : Number 3] + [y : (Number -> Number) (lambda (x) (if z 0 1))] ; not transitively safe, but safe + [z : Number x]) + z) diff --git a/collects/tests/typed-scheme/succeed/stream.rkt b/collects/tests/typed-scheme/succeed/stream.rkt new file mode 100644 index 00000000..afedf86e --- /dev/null +++ b/collects/tests/typed-scheme/succeed/stream.rkt @@ -0,0 +1,66 @@ +#lang typed/racket +#:optimize + +(provide Stream stream-cons stream-car stream-cdr empty-stream?) + +(define-type Stream + (All (A) + (Rec S + (U Null (Boxof (U (-> (Pair A S)) + (Pair A S))))))) + +(: empty-stream? : (All (A) ((Stream A) -> Boolean))) +(define (empty-stream? stream) (null? stream)) + +(define-syntax-rule (stream-cons x stream) + (box (lambda () (cons x stream)))) + +(: stream-car : (All (A) ((Stream A) -> A))) +(define (stream-car stream) + (if (null? stream) + (error 'stream-car "empty stream: ~e" stream) + (let ([p (unbox stream)]) + (if (procedure? p) + (let ([pair (p)]) + (set-box! stream pair) + (car pair)) + (car p))))) + +(: stream-cdr : (All (A) ((Stream A) -> (Stream A)))) +(define (stream-cdr stream) + (if (null? stream) + (error 'stream-cdr "empty stream: ~e" stream) + (let ([p (unbox stream)]) + (if (procedure? p) + (let ([pair (p)]) + (set-box! stream pair) + (cdr pair)) + (cdr p))))) + +(: stream : (All (A) (A * -> (Stream A)))) +(define (stream . xs) + (: loop : (All (A) ((Listof A) -> (Stream A)))) + (define (loop xs) + (if (null? xs) + '() + (box (cons (car xs) (loop (cdr xs)))))) + (loop xs)) + +(: stream->list : (All (A) ((Stream A) -> (Listof A)))) +(define (stream->list stream) + (if (null? stream) + '() + (cons (stream-car stream) (stream->list (stream-cdr stream))))) + +(: rotate : (All (A) ((Stream A) (Listof A) (Stream A) -> (Stream A)))) +(define (rotate frnt rer accum) + (let ([carrer (car rer)]) + ;; Manually expanded `stream-cons', and added type annotations + (if (empty-stream? frnt) + (stream-cons carrer accum) + (stream-cons + (stream-car frnt) + ((inst rotate A) + (stream-cdr frnt) + (cdr rer) + (box (lambda () (cons carrer accum)))))))) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/struct-mutable.rkt b/collects/tests/typed-scheme/succeed/struct-mutable.rkt new file mode 100644 index 00000000..3ea0c171 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/struct-mutable.rkt @@ -0,0 +1,6 @@ +#lang typed/racket + +(struct: foo ([x : Integer]) #:mutable) + +(: f (Integer -> foo)) +(define (f x) (foo x)) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/typed-scheme-no-check-arrow.rkt b/collects/tests/typed-scheme/succeed/typed-scheme-no-check-arrow.rkt new file mode 100644 index 00000000..bfa511c1 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/typed-scheme-no-check-arrow.rkt @@ -0,0 +1,3 @@ +#lang typed-scheme/no-check +(: foo : Void -> Void) +(define (foo x) x) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/with-asserts.rkt b/collects/tests/typed-scheme/succeed/with-asserts.rkt new file mode 100644 index 00000000..c6dc9b32 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/with-asserts.rkt @@ -0,0 +1,20 @@ +#lang typed/racket + +(let ([x 1] [y "2"]) + (with-asserts ([x integer?] [y string?]) + x)) +(let ([x 1] [y "2"]) + (with-asserts ([x integer?]) + x)) +(let ([x 1] [y "2"]) + (with-asserts () + x)) +(let ([x 1] [y "2"]) + (with-asserts ([x]) + x)) + +(: f : (U Integer String) -> Integer) +(define (f x) + (with-asserts ([x integer?]) + x)) +(f 1) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt b/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt index ac32ab7e..02995dd4 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt @@ -5,7 +5,7 @@ (env type-alias-env type-env-structs tvar-env type-name-env init-envs) (rep type-rep) (rename-in (types comparison subtype union utils convenience) - [Un t:Un] [-> t:->]) + [Un t:Un] [-> t:->] [->* t:->*]) (private base-types base-types-extra colon) (for-template (private base-types base-types-extra base-env colon)) (private parse-type) @@ -83,7 +83,7 @@ ;; requires transformer time stuff that doesn't work #;[(Refinement even?) (make-Refinement #'even?)] [(Number Number Number Boolean -> Number) (N N N B . t:-> . N)] - [(Number Number Number * -> Boolean) ((list N N) N . ->* . B)] + [(Number Number Number * -> Boolean) ((list N N) N . t:->* . B)] ;[((. Number) -> Number) (->* (list) N N)] ;; not legal syntax [(U Number Boolean) (t:Un N B)] [(U Number Boolean Number) (t:Un N B)] @@ -111,6 +111,12 @@ (-polydots (a) ((list) [a a] . ->... . N))] [(Any -> Boolean : Number) (make-pred-ty -Number)] + [(Any -> Boolean : #:+ (Number @ 0) #:- (! Number @ 0)) + (make-pred-ty -Number)] + [(Any -> Boolean : #:+ (! Number @ 0) #:- (Number @ 0)) + (t:->* (list Univ) -Boolean : (-FS (-not-filter -Number 0 null) (-filter -Number 0 null)))] + [(Number -> Number -> Number) + (t:-> -Number (t:-> -Number -Number))] [(Integer -> (All (X) (X -> X))) (t:-> -Integer (-poly (x) (t:-> x x)))] diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 406dc955..6c82cc3c 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -3,10 +3,9 @@ (require "test-utils.ss" (for-syntax scheme/base) (for-template scheme/base)) -(require (private base-env prims type-annotation - base-types-extra - base-env-numeric - base-env-indexing +(require (private prims type-annotation + base-types-extra base-special-env + base-env-indexing base-structs parse-type) (typecheck typechecker) (rep type-rep filter-rep object-rep) @@ -24,15 +23,20 @@ (for-syntax (utils tc-utils) (typecheck typechecker) (env global-env) - (private base-env base-env-numeric - base-env-indexing)) - (for-template (private base-env base-types base-types-extra - base-env-numeric + (private #;base-env #;base-env-numeric + base-env-indexing base-special-env)) + (for-template (private #;base-env base-types base-types-extra + #;base-env-numeric base-special-env base-env-indexing)) (for-syntax syntax/kerncase syntax/parse)) +(require (prefix-in b: (private base-env)) + (prefix-in n: (private base-env-numeric))) + (provide typecheck-tests g tc-expr/expand) +(b:init) (n:init) (initialize-structs) (initialize-indexing) + (define N -Number) (define B -Boolean) (define Sym -Symbol) @@ -142,6 +146,12 @@ N] (tc-e/t (if (let ([y 12]) y) 3 4) -PositiveFixnum) (tc-e/t 3 -PositiveFixnum) + (tc-e/t 100 -PositiveFixnum) + (tc-e/t -100 -NegativeFixnum) + (tc-e/t 2147483647 -PositiveFixnum) + (tc-e/t -2147483647 -NegativeFixnum) + (tc-e/t 2147483648 -Pos) + (tc-e/t -2147483648 -Integer) (tc-e/t "foo" -String) (tc-e (+ 3 4) -Pos) [tc-e/t (lambda: () 3) (t:-> -PositiveFixnum : -true-lfilter)] @@ -154,10 +164,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)))] @@ -640,6 +650,9 @@ (apply (plambda: (b ...) ([x : Number] . [y : Number ... b]) x) 1 w)) (-polydots (a) ((list -String) (N a) . ->... . N))] + [tc-e/t (let ([f (plambda: (a ...) [w : a ... a] w)]) + (f 1 "hello" #\c)) + (-pair -PositiveFixnum (-pair -String (-pair -Char (-val null))))] ;; instantiating non-dotted terms [tc-e/t (inst (plambda: (a) ([x : a]) x) Integer) (make-Function (list (make-arr* (list -Integer) -Integer @@ -826,6 +839,7 @@ (make-pred-ty (-val eof))] [tc-e ((inst map Number (Pairof Number Number)) car (ann (list (cons 1 2) (cons 2 3) (cons 4 5)) (Listof (Pairof Number Number)))) (-lst -Number)] + [tc-err (list (values 1 2))] ) (test-suite "check-type tests" @@ -847,9 +861,9 @@ (tc-l -5.0 -Flonum) (tc-l -5.1 -Flonum) (tc-l 1+1i N) - (tc-l 1+1.0i -InexactComplex) - (tc-l 1.0+1i -InexactComplex) - (tc-l 1.0+1.1i -InexactComplex) + (tc-l 1+1.0i -FloatComplex) + (tc-l 1.0+1i -FloatComplex) + (tc-l 1.0+1.1i -FloatComplex) (tc-l #t (-val #t)) (tc-l "foo" -String) (tc-l foo (-val 'foo)) diff --git a/collects/tests/typed-scheme/xfail/for-inference.rkt b/collects/tests/typed-scheme/xfail/for-inference.rkt index 14a3a70d..38ac3357 100644 --- a/collects/tests/typed-scheme/xfail/for-inference.rkt +++ b/collects/tests/typed-scheme/xfail/for-inference.rkt @@ -79,3 +79,9 @@ (for/and: : Boolean ((i : Exact-Positive-Integer '(1 2 3))) (< i 3)) + +;; for/vector: would need stronger inference. same for for*/vector and +;; both flvector variants +(for/vector: : (Vectorof Integer) + ((x : Integer (in-range 10))) + x) 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 =? 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 number) top top -> boolean) (lib "67.ss" "srfi")) + +; a priority-queue is a heap of (cons ) + +(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/core.rkt b/collects/typed-scheme/core.rkt new file mode 100644 index 00000000..e2e1bc90 --- /dev/null +++ b/collects/typed-scheme/core.rkt @@ -0,0 +1,72 @@ +#lang racket/base + +(require (rename-in "utils/utils.rkt" [infer r:infer]) + (for-syntax racket/base) + (for-template racket/base) + (private with-types type-contract) + (except-in syntax/parse id) + racket/match unstable/syntax unstable/match + (optimizer optimizer) + (types utils convenience) + (typecheck typechecker provide-handling tc-toplevel) + (env type-name-env type-alias-env) + (r:infer infer) + (rep type-rep) + (except-in (utils utils tc-utils) infer) + (only-in (r:infer infer-dummy) infer-param) + "tc-setup.rkt") + +(provide mb-core ti-core wt-core) + +(define (mb-core stx) + (syntax-parse stx + [(mb (~optional (~or (~and #:optimize (~bind [opt? #'#t])) ; kept for backward compatibility + (~and #:no-optimize (~bind [opt? #'#f])))) + forms ...) + (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))]) + (parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?)) + (and (attribute opt?) (syntax-e (attribute opt?))))]) + (tc-setup + stx pmb-form 'module-begin new-mod tc-module after-code + (with-syntax* + (;; pmb = #%plain-module-begin + [(pmb . body2) new-mod] + ;; add in syntax property on useless expression to draw check-syntax arrows + [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))] + ;; perform the provide transformation from [Culpepper 07] + [transformed-body (remove-provides #'body2)] + ;; add the real definitions of contracts on requires + [transformed-body (change-contract-fixups #'transformed-body)] + ;; potentially optimize the code based on the type information + [(optimized-body ...) + ;; do we optimize? + (if (optimize?) + (begin0 (map optimize-top (syntax->list #'transformed-body)) + (do-time "Optimized")) + #'transformed-body)]) + ;; reconstruct the module with the extra code + ;; use the regular %#module-begin from `racket/base' for top-level printing + #`(#%module-begin optimized-body ... #,after-code check-syntax-help)))))])) + +(define (ti-core stx) + (syntax-parse stx + [(_ . ((~datum module) . rest)) + #'(module . rest)] + [(_ . form) + (tc-setup + stx #'form 'top-level body2 tc-toplevel-form type + (syntax-parse body2 + ;; any of these do not produce an expression to be printed + [(head:invis-kw . _) body2] + [_ (let ([ty-str (match type + ;; don't print results of type void + [(tc-result1: (== -Void type-equal?)) #f] + [(tc-result1: t f o) + (format "- : ~a\n" t)] + [(tc-results: t) + (format "- : ~a\n" (cons 'Values t))] + [x (int-err "bad type result: ~a" x)])]) + (if ty-str + #`(let ([type '#,ty-str]) + (begin0 #,body2 (display type))) + body2))]))])) \ No newline at end of file diff --git a/collects/typed-scheme/env/global-env.rkt b/collects/typed-scheme/env/global-env.rkt index 369f6cfd..b22f47c2 100644 --- a/collects/typed-scheme/env/global-env.rkt +++ b/collects/typed-scheme/env/global-env.rkt @@ -39,7 +39,7 @@ ;; add a single type to the mapping ;; identifier type -> void (define (register-type/undefined id type) - ;(printf "register-type/undef ~a~n" (syntax-e id)) + ;(printf "register-type/undef ~a\n" (syntax-e id)) (if (free-id-table-ref the-mapping id (lambda _ #f)) (void (tc-error/expr #:stx id "Duplicate type annotation for ~a" (syntax-e id))) (free-id-table-set! the-mapping id (box type)))) diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt index d9a3729c..3a39da0b 100644 --- a/collects/typed-scheme/env/init-envs.rkt +++ b/collects/typed-scheme/env/init-envs.rkt @@ -10,7 +10,7 @@ (types union) mzlib/pconvert mzlib/shared scheme/base) (types union convenience) - mzlib/pconvert scheme/match mzlib/shared) + mzlib/pconvert racket/match mzlib/shared) (define (initialize-type-name-env initial-type-names) (for-each (lambda (nm/ty) (register-resolved-type-alias (car nm/ty) (cadr nm/ty))) initial-type-names)) diff --git a/collects/typed-scheme/env/type-alias-env.rkt b/collects/typed-scheme/env/type-alias-env.rkt index 0d1b6298..35e88063 100644 --- a/collects/typed-scheme/env/type-alias-env.rkt +++ b/collects/typed-scheme/env/type-alias-env.rkt @@ -4,7 +4,7 @@ syntax/boundmap (utils tc-utils) mzlib/trace - scheme/match) + racket/match) (provide register-type-alias lookup-type-alias @@ -27,7 +27,7 @@ ;; add a name to the mapping ;; identifier type-stx -> void (define (register-type-alias id stx) - ;(printf "registering type ~a~n~a~n" (syntax-e id) id) + ;(printf "registering type ~a\n~a\n" (syntax-e id) id) (mapping-put! id (make-unresolved stx #f))) (define (register-resolved-type-alias id ty) diff --git a/collects/typed-scheme/env/type-env-structs.rkt b/collects/typed-scheme/env/type-env-structs.rkt index 1d9047b9..6cb5a6fe 100644 --- a/collects/typed-scheme/env/type-env-structs.rkt +++ b/collects/typed-scheme/env/type-env-structs.rkt @@ -2,7 +2,7 @@ (require scheme/contract unstable/sequence racket/dict syntax/id-table (prefix-in r: "../utils/utils.rkt") - scheme/match (r:rep filter-rep rep-utils type-rep) unstable/struct + racket/match (r:rep filter-rep rep-utils type-rep) unstable/struct (except-in (r:utils tc-utils) make-env)) (provide extend @@ -20,8 +20,16 @@ ;; eq? has the type of equal?, and l is an alist (with conses!) ;; props is a list of known propositions -(r:d-s/c env ([l (and/c (not/c dict-mutable?) dict?)]) #:transparent) -(r:d-s/c (prop-env env) ([props (listof Filter/c)]) #:transparent) +(r:d-s/c env ([l (and/c (not/c dict-mutable?) dict?)]) + #:transparent + #:property prop:custom-write + (lambda (e prt mode) + (fprintf prt "(env ~a)" (dict-map (env-l e) list)))) +(r:d-s/c (prop-env env) ([props (listof Filter/c)]) + #:transparent + #:property prop:custom-write + (lambda (e prt mode) + (fprintf prt "(env ~a ~a)" (dict-map (env-l e) list) (prop-env-props e)))) (define (mk-env orig dict) (match orig diff --git a/collects/typed-scheme/env/type-name-env.rkt b/collects/typed-scheme/env/type-name-env.rkt index c741b552..47b553db 100644 --- a/collects/typed-scheme/env/type-name-env.rkt +++ b/collects/typed-scheme/env/type-name-env.rkt @@ -24,7 +24,7 @@ ;; add a name to the mapping ;; identifier Type -> void (define (register-type-name id [type #t]) - ;(printf "registering type ~a~n~a~n" (syntax-e id) id) + ;(printf "registering type ~a\n~a\n" (syntax-e id) id) (mapping-put! id type)) ;; add a bunch of names to the mapping diff --git a/collects/typed-scheme/infer/constraint-structs.rkt b/collects/typed-scheme/infer/constraint-structs.rkt index 82e65033..395bc2f4 100644 --- a/collects/typed-scheme/infer/constraint-structs.rkt +++ b/collects/typed-scheme/infer/constraint-structs.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require "../utils/utils.rkt" (rep type-rep) scheme/contract scheme/match (for-syntax scheme/base syntax/parse)) +(require "../utils/utils.rkt" (rep type-rep) scheme/contract racket/match (for-syntax scheme/base syntax/parse)) ;; S, T types ;; X a var diff --git a/collects/typed-scheme/infer/constraints.rkt b/collects/typed-scheme/infer/constraints.rkt index 444ddca9..6d6c6f30 100644 --- a/collects/typed-scheme/infer/constraints.rkt +++ b/collects/typed-scheme/infer/constraints.rkt @@ -6,7 +6,7 @@ (utils tc-utils) unstable/sequence unstable/hash "signatures.rkt" "constraint-structs.rkt" - scheme/match) + racket/match) (import restrict^ dmap^) (export constraints^) diff --git a/collects/typed-scheme/infer/dmap.rkt b/collects/typed-scheme/infer/dmap.rkt index c76702bf..52022f12 100644 --- a/collects/typed-scheme/infer/dmap.rkt +++ b/collects/typed-scheme/infer/dmap.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" "signatures.rkt" "constraint-structs.rkt" (utils tc-utils) racket/contract - unstable/sequence unstable/hash scheme/match) + unstable/sequence unstable/hash racket/match) (import constraints^) (export dmap^) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index e5fff323..813fa321 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -1,6 +1,6 @@ -#lang scheme/unit +#lang racket/unit -(require scheme/require (path-up "utils/utils.rkt") +(require racket/require (path-up "utils/utils.rkt") (except-in (combine-in (utils tc-utils) @@ -11,11 +11,11 @@ make-env -> ->* one-of/c) "constraint-structs.rkt" "signatures.rkt" - scheme/match + racket/match mzlib/etc racket/trace racket/contract unstable/sequence unstable/list unstable/debug unstable/hash - scheme/list) + racket/list) (import dmap^ constraints^ promote-demote^) (export infer^) @@ -476,6 +476,9 @@ ;; syntax is covariant [((Syntax: s1) (Syntax: s2)) (cg s1 s2)] + ;; futures are covariant + [((Future: s1) (Future: s2)) + (cg s1 s2)] ;; parameters are just like one-arg functions [((Param: in1 out1) (Param: in2 out2)) (cset-meet (cg in2 in1) (cg out1 out2))] @@ -522,7 +525,7 @@ (match v [(c S X T) (let ([var (hash-ref h (or variable X) Constant)]) - ;(printf "variance was: ~a~nR was ~a~nX was ~a~nS T ~a ~a~n" var R (or variable X) S T) + ;(printf "variance was: ~a\nR was ~a\nX was ~a\nS T ~a ~a\n" var R (or variable X) S T) (evcase var [Constant S] [Covariant S] diff --git a/collects/typed-scheme/infer/promote-demote.rkt b/collects/typed-scheme/infer/promote-demote.rkt index 334eecc7..eee913af 100644 --- a/collects/typed-scheme/infer/promote-demote.rkt +++ b/collects/typed-scheme/infer/promote-demote.rkt @@ -4,7 +4,7 @@ (require (rep type-rep rep-utils) (types convenience union utils) "signatures.rkt" - scheme/list scheme/match) + scheme/list racket/match) (import) (export promote-demote^) diff --git a/collects/typed-scheme/infer/restrict.rkt b/collects/typed-scheme/infer/restrict.rkt index 9664ee4b..e09f0ac3 100644 --- a/collects/typed-scheme/infer/restrict.rkt +++ b/collects/typed-scheme/infer/restrict.rkt @@ -4,7 +4,7 @@ (require (rep type-rep) (types utils union subtype remove-intersect resolve substitute) "signatures.rkt" - scheme/match mzlib/trace) + racket/match mzlib/trace) (import infer^) (export restrict^) diff --git a/collects/typed-scheme/info.rkt b/collects/typed-scheme/info.rkt index c18cc35e..30046e05 100644 --- a/collects/typed-scheme/info.rkt +++ b/collects/typed-scheme/info.rkt @@ -1,4 +1,4 @@ #lang setup/infotab -(define scribblings '(("scribblings/ts-reference.scrbl" ()) - ("scribblings/ts-guide.scrbl" (multi-page)))) +(define scribblings '(("scribblings/ts-reference.scrbl" () (language -1)) + ("scribblings/ts-guide.scrbl" (multi-page) (language)))) diff --git a/collects/typed-scheme/language-info.rkt b/collects/typed-scheme/language-info.rkt index ebecb8e2..89f207ac 100644 --- a/collects/typed-scheme/language-info.rkt +++ b/collects/typed-scheme/language-info.rkt @@ -14,5 +14,5 @@ (require (for-syntax typed-scheme/utils/tc-utils scheme/base)) (begin-for-syntax (set-box! typed-context? #t))) (current-namespace)) - (current-readtable readtable)) + (current-readtable (readtable))) diff --git a/collects/typed-scheme/main.rkt b/collects/typed-scheme/main.rkt index c135bc51..016cdebf 100644 --- a/collects/typed-scheme/main.rkt +++ b/collects/typed-scheme/main.rkt @@ -2,7 +2,7 @@ -(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app) +(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app for for*) (except "private/prims.rkt") (except "private/base-types.rkt") (except "private/base-types-extra.rkt")) @@ -10,12 +10,8 @@ #%top-interaction lambda #%app)) -(require "private/base-env.rkt" - "private/base-special-env.rkt" - "private/base-env-numeric.rkt" - "private/base-env-indexing.rkt" - "private/extra-procs.rkt" +(require "private/extra-procs.rkt" (for-syntax "private/base-types-extra.rkt")) (provide (rename-out [with-handlers: with-handlers]) (for-syntax (all-from-out "private/base-types-extra.rkt")) - assert with-type) + assert defined? with-type for for*) diff --git a/collects/typed-scheme/no-check.rkt b/collects/typed-scheme/no-check.rkt index ed542f85..fb1ac85d 100644 --- a/collects/typed-scheme/no-check.rkt +++ b/collects/typed-scheme/no-check.rkt @@ -3,10 +3,11 @@ (require (except-in "private/prims.rkt" require/typed require/opaque-type require-typed-struct) + "private/base-types-extra.rkt" (for-syntax scheme/base syntax/parse syntax/struct)) (provide (all-from-out scheme/base) (all-defined-out) - (all-from-out "private/prims.rkt")) + (all-from-out "private/prims.rkt" "private/base-types-extra.rkt")) (define-syntax (require/typed stx) diff --git a/collects/typed-scheme/optimizer/apply.rkt b/collects/typed-scheme/optimizer/apply.rkt new file mode 100644 index 00000000..e85c2dee --- /dev/null +++ b/collects/typed-scheme/optimizer/apply.rkt @@ -0,0 +1,29 @@ +#lang scheme/base +(require syntax/parse + (for-template scheme/unsafe/ops racket/base (prefix-in k: '#%kernel)) + "../utils/utils.rkt" + (optimizer utils)) + +(provide apply-opt-expr) + +(define-syntax-class apply-op + #:commit + #:literals (+ *) + (pattern + #:with identity #'0) + (pattern * #:with identity #'1)) + +(define-syntax-class apply-opt-expr + #:commit + #: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/box.rkt b/collects/typed-scheme/optimizer/box.rkt new file mode 100644 index 00000000..66f3d097 --- /dev/null +++ b/collects/typed-scheme/optimizer/box.rkt @@ -0,0 +1,32 @@ +#lang scheme/base + +(require syntax/parse unstable/syntax + racket/match + "../utils/utils.rkt" + (for-template scheme/base scheme/unsafe/ops) + (rep type-rep) + (types type-table utils) + (optimizer utils)) + +(provide box-opt-expr) + +(define-syntax-class box-expr + #:commit + (pattern e:expr + #:when (match (type-of #'e) + [(tc-result1: (Box: _)) #t] + [_ #f]) + #:with opt ((optimize) #'e))) + +(define-syntax-class box-op + #:commit + ;; 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 + #:commit + (pattern (#%plain-app op:box-op b:box-expr new:expr ...) + #:with opt + (begin (log-optimization "box" #'op) + #`(op.unsafe b.opt #,@(syntax-map (optimize) #'(new ...)))))) diff --git a/collects/typed-scheme/optimizer/dead-code.rkt b/collects/typed-scheme/optimizer/dead-code.rkt index f20019de..c6ba8180 100644 --- a/collects/typed-scheme/optimizer/dead-code.rkt +++ b/collects/typed-scheme/optimizer/dead-code.rkt @@ -2,13 +2,14 @@ (require syntax/parse (for-template scheme/base) - "../utils/utils.rkt" "../utils/tc-utils.rkt" + "../utils/utils.rkt" (types type-table) (optimizer utils)) (provide dead-code-opt-expr) (define-syntax-class dead-code-opt-expr + #:commit ;; if one of the brances of an if is unreachable, we can eliminate it ;; we have to keep the test, in case it has side effects (pattern (if tst:expr thn:expr els:expr) diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt index 8959261e..0573112c 100644 --- a/collects/typed-scheme/optimizer/fixnum.rkt +++ b/collects/typed-scheme/optimizer/fixnum.rkt @@ -3,7 +3,7 @@ (require syntax/parse "../utils/utils.rkt" (for-template scheme/base scheme/fixnum scheme/unsafe/ops) - (types abbrev type-table utils subtype) + (types abbrev) (optimizer utils)) (provide fixnum-expr fixnum-opt-expr) @@ -30,30 +30,36 @@ #'bitwise-xor #'unsafe-fxxor) #'fxxor #'unsafe-fxxor)) (define-syntax-class fixnum-unary-op + #:commit (pattern (~or (~literal bitwise-not) (~literal fxnot)) #:with unsafe #'unsafe-fxnot) (pattern (~or (~literal abs) (~literal fxabs)) #:with unsafe #'unsafe-fxabs)) ;; closed on fixnums, but 2nd argument must not be 0 (define-syntax-class nonzero-fixnum-binary-op - (pattern (~or (~literal quotient) (~literal fxquotient)) #:with unsafe #'unsafe-fxquotient) + #:commit + ;; quotient is not closed. (quotient most-negative-fixnum -1) is not a fixnum (pattern (~or (~literal modulo) (~literal fxmodulo)) #:with unsafe #'unsafe-fxmodulo) (pattern (~or (~literal remainder) (~literal fxremainder)) #:with unsafe #'unsafe-fxremainder)) (define-syntax-class (fixnum-op tbl) + #:commit (pattern i:id #:when (dict-ref tbl #'i #f) #:with unsafe (dict-ref tbl #'i))) (define-syntax-class fixnum-expr + #:commit (pattern e:expr #:when (subtypeof? #'e -Fixnum) #:with opt ((optimize) #'e))) (define-syntax-class nonzero-fixnum-expr + #:commit (pattern e:expr #:when (or (isoftype? #'e -PositiveFixnum) (isoftype? #'e -NegativeFixnum)) #:with opt ((optimize) #'e))) (define-syntax-class fixnum-opt-expr + #:commit (pattern (#%plain-app op:fixnum-unary-op n:fixnum-expr) #:with opt (begin (log-optimization "unary fixnum" #'op) @@ -71,7 +77,18 @@ #: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) - #'(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-complex.rkt b/collects/typed-scheme/optimizer/float-complex.rkt new file mode 100644 index 00000000..421cc50d --- /dev/null +++ b/collects/typed-scheme/optimizer/float-complex.rkt @@ -0,0 +1,470 @@ +#lang scheme/base + +(require syntax/parse syntax/id-table scheme/dict unstable/syntax + "../utils/utils.rkt" racket/unsafe/ops + (for-template scheme/base scheme/math racket/flonum scheme/unsafe/ops) + (types abbrev) + (optimizer utils float)) + +(provide float-complex-opt-expr + float-complex-arith-opt-expr + unboxed-float-complex-opt-expr + float-complex-call-site-opt-expr + unboxed-vars-table unboxed-funs-table) + + +;; contains the bindings which actually exist as separate bindings for each component +;; associates identifiers to lists (real-binding imag-binding) +(define unboxed-vars-table (make-free-id-table)) + +;; associates the names of functions with unboxed args (and whose call sites have to +;; be modified) to the arguments which can be unboxed and those which have to be boxed +;; entries in the table are of the form: +;; ((unboxed ...) (boxed ...)) +;; all these values are indices, since arg names don't make sense for call sites +;; the new calling convention for these functions have all real parts of unboxed +;; params first, then all imaginary parts, then all boxed arguments +(define unboxed-funs-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 +;; complex operations +(define-syntax-class unboxed-float-complex-opt-expr + #:commit + + (pattern (#%plain-app (~and op (~literal +)) + c1:unboxed-float-complex-opt-expr + c2:unboxed-float-complex-opt-expr + cs:unboxed-float-complex-opt-expr ...) + #:when (isoftype? this-syntax -FloatComplex) + #:with real-binding (unboxed-gensym "unboxed-real-") + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with (bindings ...) + (begin (log-optimization "unboxed binary float complex" #'op) + #`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...)) + (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-binding) #,(skip-0s #'(c1.real-binding c2.real-binding cs.real-binding ...))) + #`((imag-binding) #,(skip-0s #'(c1.imag-binding c2.imag-binding cs.imag-binding ...))))))))) + + (pattern (#%plain-app (~and op (~literal -)) + c1:unboxed-float-complex-opt-expr + c2:unboxed-float-complex-opt-expr + cs:unboxed-float-complex-opt-expr ...) + #:when (isoftype? this-syntax -FloatComplex) + #:with real-binding (unboxed-gensym "unboxed-real-") + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with (bindings ...) + (begin (log-optimization "unboxed binary float complex" #'op) + #`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...)) + (let () + ;; unlike addition, we simply can't skip real parts of imaginaries + (define (skip-0s l) + (let* ((l1 (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) 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-binding) #,(skip-0s #'(c1.real-binding c2.real-binding cs.real-binding ...))) + #`((imag-binding) #,(skip-0s #'(c1.imag-binding c2.imag-binding cs.imag-binding ...))))))))) + + (pattern (#%plain-app (~and op (~literal *)) + c1:unboxed-float-complex-opt-expr + c2:unboxed-float-complex-opt-expr + cs:unboxed-float-complex-opt-expr ...) + #:when (or (isoftype? this-syntax -FloatComplex) (isoftype? this-syntax -Number)) + #:with real-binding (unboxed-gensym "unboxed-real-") + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with (bindings ...) + (begin (log-optimization "unboxed binary float complex" #'op) + #`(c1.bindings ... c2.bindings ... cs.bindings ... ... + ;; we want to bind the intermediate results to reuse them + ;; the final results are bound to real-binding and imag-binding + #,@(let ((lr (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) + #'(c1.real-binding c2.real-binding cs.real-binding ...))) + (li (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) + #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)))) + (let loop ([o1 (car lr)] + [o2 (car li)] + [e1 (cdr lr)] + [e2 (cdr li)] + [rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-")) + #'(cs.real-binding ...)) + (list #'real-binding))] + [is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-")) + #'(cs.imag-binding ...)) + (list #'imag-binding))] + [res '()]) + (if (null? e1) + (reverse res) + (loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is) + ;; complex multiplication, imag part, then real part (reverse) + ;; we eliminate operations on the imaginary parts of reals + (let ((o-real? (equal? (syntax->datum o2) 0.0)) + (e-real? (equal? (syntax->datum (car e2)) 0.0))) + (list* #`((#,(car is)) + #,(cond ((and o-real? e-real?) #'0.0) + (o-real? #`(unsafe-fl* #,o1 #,(car e2))) + (e-real? #`(unsafe-fl* #,o2 #,(car e1))) + (else + #`(unsafe-fl+ (unsafe-fl* #,o2 #,(car e1)) + (unsafe-fl* #,o1 #,(car e2)))))) + #`((#,(car rs)) + #,(cond ((or o-real? e-real?) + #`(unsafe-fl* #,o1 #,(car e1))) + (else + #`(unsafe-fl- (unsafe-fl* #,o1 #,(car e1)) + (unsafe-fl* #,o2 #,(car e2)))))) + res))))))))) + + (pattern (#%plain-app (~and op (~literal /)) + c1:unboxed-float-complex-opt-expr + c2:unboxed-float-complex-opt-expr + cs:unboxed-float-complex-opt-expr ...) + #:when (or (isoftype? this-syntax -FloatComplex) (isoftype? this-syntax -Number)) + #:with real-binding (unboxed-gensym "unboxed-real-") + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with reals (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) + #'(c1.real-binding c2.real-binding cs.real-binding ...)) + #:with imags (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) + #'(c1.imag-binding c2.imag-binding cs.imag-binding ...)) + #:with (bindings ...) + (begin (log-optimization "unboxed binary float complex" #'op) + #`(c1.bindings ... c2.bindings ... cs.bindings ... ... + ;; we want to bind the intermediate results to reuse them + ;; the final results are bound to real-binding and imag-binding + #,@(let loop ([o1 (car (syntax->list #'reals))] + [o2 (car (syntax->list #'imags))] + [e1 (cdr (syntax->list #'reals))] + [e2 (cdr (syntax->list #'imags))] + [rs (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-")) + #'(cs.real-binding ...)) + (list #'real-binding))] + [is (append (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-")) + #'(cs.imag-binding ...)) + (list #'imag-binding))] + [ds (syntax-map (lambda (x) (unboxed-gensym)) + #'(c2.real-binding cs.real-binding ...))] + [res '()]) + (if (null? e1) + (reverse res) + (loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is) (cdr ds) + ;; complex division, imag part, real part, then denominator (reverse) + (let ((o-real? (equal? (syntax->datum o2) 0.0)) + (e-real? (equal? (syntax->datum (car e2)) 0.0))) + (cond [(and o-real? e-real?) + (list* + #`((#,(car is)) 0.0) ; currently not propagated + #`((#,(car rs)) (unsafe-fl/ #,o1 #,(car e1))) + res)] + [o-real? + (list* + #`((#,(car is)) + (unsafe-fl/ (unsafe-fl- 0.0 + (unsafe-fl* #,o1 #,(car e2))) + #,(car ds))) + #`((#,(car rs)) (unsafe-fl/ (unsafe-fl* #,o1 #,(car e1)) + #,(car ds))) + #`((#,(car ds)) (unsafe-fl+ (unsafe-fl* #,(car e1) #,(car e1)) + (unsafe-fl* #,(car e2) #,(car e2)))) + res)] + [e-real? + (list* + #`((#,(car is)) (unsafe-fl/ #,o2 #,(car e1))) + #`((#,(car rs)) (unsafe-fl/ #,o1 #,(car e1))) + res)] + [else + (list* + #`((#,(car is)) + (unsafe-fl/ (unsafe-fl- (unsafe-fl* #,o2 #,(car e1)) + (unsafe-fl* #,o1 #,(car e2))) + #,(car ds))) + #`((#,(car rs)) + (unsafe-fl/ (unsafe-fl+ (unsafe-fl* #,o1 #,(car e1)) + (unsafe-fl* #,o2 #,(car e2))) + #,(car ds))) + #`((#,(car ds)) + (unsafe-fl+ (unsafe-fl* #,(car e1) #,(car e1)) + (unsafe-fl* #,(car e2) #,(car e2)))) + res)])))))))) + + (pattern (#%plain-app (~and op (~literal conjugate)) c:unboxed-float-complex-opt-expr) + #:when (isoftype? this-syntax -FloatComplex) + #:with real-binding #'c.real-binding + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with (bindings ...) + (begin (log-optimization "unboxed unary float complex" #'op) + #`(#,@(append (syntax->list #'(c.bindings ...)) + (list #'((imag-binding) (unsafe-fl- 0.0 c.imag-binding))))))) + + (pattern (#%plain-app (~and op (~literal magnitude)) c:unboxed-float-complex-opt-expr) + #:with real-binding (unboxed-gensym "unboxed-real-") + #:with imag-binding #f + #:with (bindings ...) + (begin (log-optimization "unboxed unary float complex" #'op) + #`(c.bindings ... + ((real-binding) (unsafe-flsqrt + (unsafe-fl+ (unsafe-fl* c.real-binding c.real-binding) + (unsafe-fl* c.imag-binding c.imag-binding))))))) + + (pattern (#%plain-app (~and op (~or (~literal real-part) (~literal unsafe-flreal-part))) + c:unboxed-float-complex-opt-expr) + #:with real-binding #'c.real-binding + #:with imag-binding #f + #:with (bindings ...) + (begin (log-optimization "unboxed unary float complex" #'op) + #'(c.bindings ...))) + (pattern (#%plain-app (~and op (~or (~literal imag-part) (~literal unsafe-flimag-part))) + c:unboxed-float-complex-opt-expr) + #:with real-binding #'c.imag-binding + #:with imag-binding #f + #:with (bindings ...) + (begin (log-optimization "unboxed unary float complex" #'op) + #'(c.bindings ...))) + + ;; special handling of reals inside complex operations + ;; must be after any cases that we are supposed to handle + (pattern e:float-coerce-expr + #:with real-binding (unboxed-gensym 'unboxed-float-) + #:with imag-binding #f + #:when (log-optimization "float-coerce-expr in complex ops" #'e) + #:with (bindings ...) + #`(((real-binding) e.opt))) + + + ;; we can eliminate boxing that was introduced by the user + (pattern (#%plain-app (~and op (~or (~literal make-rectangular) + (~literal unsafe-make-flrectangular))) + real:float-coerce-expr imag:float-coerce-expr) + #:with real-binding (unboxed-gensym "unboxed-real-") + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with (bindings ...) + (begin (log-optimization "make-rectangular elimination" #'op) + #'(((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 "unboxed-real-") + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #: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 + #:with unboxed-info (dict-ref unboxed-vars-table #'v #f) + #:when (syntax->datum #'unboxed-info) + #:with real-binding (car (syntax->list #'unboxed-info)) + #:with imag-binding (cadr (syntax->list #'unboxed-info)) + #:with (bindings ...) + (begin (log-optimization "leave var unboxed" #'v) + #'())) + + ;; 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 "unboxed-real-") + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with (bindings ...) + (begin (log-optimization "unboxed literal" #'n) + (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 "unboxed-real-") + #:with imag-binding #f + #:with (bindings ...) + (begin (log-optimization "unboxed literal" #'n) + #`(((real-binding) #,(datum->syntax + #'here + (exact->inexact (syntax->datum #'n))))))) + + (pattern e:expr + #:when (isoftype? #'e -FloatComplex) + #:with e* (unboxed-gensym) + #:with real-binding (unboxed-gensym "unboxed-real-") + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with (bindings ...) + (begin (log-optimization "unbox float-complex" #'e) + #`(((e*) #,((optimize) #'e)) + ((real-binding) (unsafe-flreal-part e*)) + ((imag-binding) (unsafe-flimag-part e*))))) + (pattern e:expr + #:when (isoftype? #'e -Number) ; complex, maybe exact, maybe not + #:with e* (unboxed-gensym) + #:with real-binding (unboxed-gensym "unboxed-real-") + #:with imag-binding (unboxed-gensym "unboxed-imag-") + #:with (bindings ...) + (begin (log-optimization "unbox complex" #'e) + #`(((e*) #,((optimize) #'e)) + ((real-binding) (exact->inexact (real-part e*))) + ((imag-binding) (exact->inexact (imag-part e*)))))) + (pattern e:expr + #:with (bindings ...) + (error "non exhaustive pattern match") + #:with real-binding #f + #:with imag-binding #f)) + +(define-syntax-class float-complex-unary-op + #:commit + (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 float-complex-op + #:commit + (pattern (~or (~literal +) (~literal -) (~literal *) (~literal /) (~literal conjugate)))) + +(define-syntax-class float-complex->float-op + #:commit + (pattern (~or (~literal magnitude) + (~literal real-part) (~literal flreal-part) (~literal unsafe-flreal-part) + (~literal imag-part) (~literal flimag-part) (~literal unsafe-flimag-part)))) + +(define-syntax-class float-complex-expr + #:commit + (pattern e:expr + #:when (isoftype? #'e -FloatComplex) + #:with opt ((optimize) #'e))) + +(define-syntax-class float-complex-opt-expr + #:commit + + ;; 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 flreal-part) (~literal unsafe-flreal-part) + (~literal imag-part) (~literal flimag-part) (~literal unsafe-flimag-part))) + c:float-complex-expr) + #:with c*:unboxed-float-complex-opt-expr #'c + #:with opt + (begin (log-optimization "unboxed float complex" #'op) + (reset-unboxed-gensym) + #`(let*-values (c*.bindings ...) + #,(if (or (free-identifier=? #'op #'real-part) + (free-identifier=? #'op #'flreal-part) + (free-identifier=? #'op #'unsafe-flreal-part)) + #'c*.real-binding + #'c*.imag-binding)))) + + (pattern (#%plain-app op:float-complex-unary-op n:float-complex-expr) + #:with opt + (begin (log-optimization "unary float complex" #'op) + #'(op.unsafe n.opt))) + + (pattern (#%plain-app (~and op (~literal make-polar)) r theta) + #:when (isoftype? this-syntax -FloatComplex) + #:with exp*:unboxed-float-complex-opt-expr this-syntax + #: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 (#%plain-app op:id args:expr ...) + #:with unboxed-info (dict-ref unboxed-funs-table #'op #f) + #:when (syntax->datum #'unboxed-info) + #:with (~var e* (float-complex-call-site-opt-expr + #'unboxed-info #'op)) ; no need to optimize op + this-syntax + #:with opt + (begin (log-optimization "call to fun with unboxed args" #'op) + #'e*.opt)) + + (pattern e:float-complex-arith-opt-expr + #:with opt #'e.opt)) + +(define-syntax-class float-complex-arith-opt-expr + #:commit + + (pattern (#%plain-app op:float-complex->float-op e:expr ...) + #:when (subtypeof? this-syntax -Flonum) + #:with exp*:unboxed-float-complex-opt-expr this-syntax + #:with real-binding #'exp*.real-binding + #:with imag-binding #f + #:with (bindings ...) #'(exp*.bindings ...) + #:with opt + (begin (log-optimization "unboxed float complex->float" this-syntax) + (reset-unboxed-gensym) + #'(let*-values (exp*.bindings ...) + real-binding))) + + (pattern (#%plain-app op:float-complex-op e:expr ...) + #:when (isoftype? this-syntax -FloatComplex) + #:with exp*:unboxed-float-complex-opt-expr this-syntax + #:with real-binding #'exp*.real-binding + #:with imag-binding #'exp*.imag-binding + #:with (bindings ...) #'(exp*.bindings ...) + #:with opt + (begin (log-optimization "unboxed float complex" this-syntax) + (reset-unboxed-gensym) + #'(let*-values (exp*.bindings ...) + (unsafe-make-flrectangular exp*.real-binding exp*.imag-binding)))) + + (pattern v:id + #:with unboxed-info (dict-ref unboxed-vars-table #'v #f) + #:when (syntax->datum #'unboxed-info) + #:when (subtypeof? #'v -FloatComplex) + #:with real-binding (car (syntax->list #'unboxed-info)) + #:with imag-binding (cadr (syntax->list #'unboxed-info)) + #:with (bindings ...) #'() + ;; unboxed variable used in a boxed fashion, we have to box + #:with opt + (begin (log-optimization "unboxed complex variable" #'v) + (reset-unboxed-gensym) + #'(unsafe-make-flrectangular real-binding imag-binding)))) + +;; takes as argument a structure describing which arguments will be unboxed +;; and the optimized version of the operator. operators are optimized elsewhere +;; to benefit from local information +(define-syntax-class (float-complex-call-site-opt-expr unboxed-info opt-operator) + #:commit + ;; call site of a function with unboxed parameters + ;; the calling convention is: real parts of unboxed, imag parts, boxed + (pattern (#%plain-app op:expr args:expr ...) + #:with ((to-unbox ...) (boxed ...)) unboxed-info + #:with opt + (let ((args (syntax->list #'(args ...))) + (unboxed (syntax->datum #'(to-unbox ...))) + (boxed (syntax->datum #'(boxed ...)))) + (define (get-arg i) (list-ref args i)) + (syntax-parse (map get-arg unboxed) + [(e:unboxed-float-complex-opt-expr ...) + (log-optimization "unboxed call site" #'op) + (reset-unboxed-gensym) + #`(let*-values (e.bindings ... ...) + (#%plain-app #,opt-operator + e.real-binding ... + e.imag-binding ... + #,@(map (lambda (i) ((optimize) (get-arg i))) + boxed)))])))) ; boxed params diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt index 549cc493..058ec28b 100644 --- a/collects/typed-scheme/optimizer/float.rkt +++ b/collects/typed-scheme/optimizer/float.rkt @@ -1,13 +1,13 @@ #lang scheme/base (require syntax/parse - syntax/id-table racket/dict - (for-template scheme/base scheme/flonum scheme/unsafe/ops) + racket/dict racket/flonum + (for-template scheme/base racket/flonum scheme/unsafe/ops) "../utils/utils.rkt" - (types abbrev type-table utils subtype) + (types abbrev) (optimizer utils fixnum)) -(provide float-opt-expr float-expr int-expr) +(provide float-opt-expr float-coerce-expr) (define (mk-float-tbl generic) @@ -28,24 +28,48 @@ #'sqrt #'round #'floor #'ceiling #'truncate))) (define-syntax-class (float-op tbl) + #:commit (pattern i:id #:when (dict-ref tbl #'i #f) #:with unsafe (dict-ref tbl #'i))) (define-syntax-class float-expr + #:commit (pattern e:expr #:when (subtypeof? #'e -Flonum) #:with opt ((optimize) #'e))) (define-syntax-class int-expr + #:commit (pattern e:expr #:when (subtypeof? #'e -Integer) #:with opt ((optimize) #'e))) +(define-syntax-class real-expr + #:commit + (pattern e:expr + #:when (subtypeof? #'e -Real) + #:with opt ((optimize) #'e))) + + +;; generates coercions to floats +(define-syntax-class float-coerce-expr + #:commit + (pattern e:float-arg-expr + #:with opt #'e.opt) + (pattern e:real-expr + #:with opt #'(exact->inexact e.opt))) + ;; if the result of an operation is of type float, its non float arguments ;; can be promoted, and we can use unsafe float operations ;; 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 + #:commit + ;; 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 @@ -54,35 +78,50 @@ #:with opt #'e.opt)) (define-syntax-class float-opt-expr - (pattern (~and res (#%plain-app (~var op (float-op unary-float-ops)) f:float-expr)) - #:when (subtypeof? #'res -Flonum) + #:commit + (pattern (#%plain-app (~var op (float-op unary-float-ops)) f:float-expr) + #:when (subtypeof? this-syntax -Flonum) #:with opt (begin (log-optimization "unary float" #'op) #'(op.unsafe f.opt))) - (pattern (~and res (#%plain-app (~var op (float-op binary-float-ops)) - f1:float-arg-expr - f2:float-arg-expr - fs:float-arg-expr ...)) + (pattern (#%plain-app (~var op (float-op binary-float-ops)) + f1:float-arg-expr + f2:float-arg-expr + fs:float-arg-expr ...) ;; if the result is a float, we can coerce integers to floats and optimize - #:when (subtypeof? #'res -Flonum) + #:when (subtypeof? this-syntax -Flonum) #: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) #:with opt (begin (log-optimization "int to float" #'op) #'(->fl n.opt))) - ;; we can get rid of it altogether if we're giving it an inexact number + ;; we can get rid of it altogether if we're giving it a float (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)))) diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt deleted file mode 100644 index 99ec1c38..00000000 --- a/collects/typed-scheme/optimizer/inexact-complex.rkt +++ /dev/null @@ -1,246 +0,0 @@ -#lang scheme/base - -(require syntax/parse - "../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) - - -;; 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 -;; 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 - cs:unboxed-inexact-complex-opt-expr ...) - #:with real-part (unboxed-gensym) - #:with imag-part (unboxed-gensym) - #:with (bindings ...) - (begin (log-optimization "unboxed binary inexact complex" #'op) - #`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...)) - (list #`(real-part #,(for/fold ((o #'c1.real-part)) - ((e (syntax->list #'(c2.real-part cs.real-part ...)))) - #`(unsafe-fl+ #,o #,e))) - ;; we can skip the imaginary parts of reals (#f) - #`(imag-part - #,(let ((l (filter syntax->datum - (syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...))))) - (case (length l) - ((0) #'0.0) - ((1) (car l)) - (else - (for/fold ((o (car l))) - ((e (cdr l))) - #`(unsafe-fl+ #,o #,e))))))))))) - (pattern (#%plain-app (~and op (~literal -)) - c1:unboxed-inexact-complex-opt-expr - c2:unboxed-inexact-complex-opt-expr - cs:unboxed-inexact-complex-opt-expr ...) - #:with real-part (unboxed-gensym) - #:with imag-part (unboxed-gensym) - #:with (bindings ...) - (begin (log-optimization "unboxed binary inexact complex" #'op) - #`(#,@(append (syntax->list #'(c1.bindings ... c2.bindings ... cs.bindings ... ...)) - (list #`(real-part #,(for/fold ((o #'c1.real-part)) - ((e (syntax->list #'(c2.real-part cs.real-part ...)))) - #`(unsafe-fl- #,o #,e))) - ;; unlike addition, we simply can't skip imaginary parts of reals - #`(imag-part - #,(let* ((l1 (map (lambda (x) (if (syntax->datum x) x #'0.0)) - (syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...)))) - ;; but we can skip all but the first 0 - (l2 (filter (lambda (x) (not (equal? (syntax->datum x) 0.0))) - (cdr l1)))) - (case (length l2) - ((0) (car l1)) - (else - (for/fold ((o (car l1))) - ((e l2)) - #`(unsafe-fl- #,o #,e))))))))))) - (pattern (#%plain-app (~and op (~literal *)) - c1:unboxed-inexact-complex-opt-expr - c2:unboxed-inexact-complex-opt-expr - cs:unboxed-inexact-complex-opt-expr ...) - #:with real-part (unboxed-gensym) - #:with imag-part (unboxed-gensym) - #:with (bindings ...) - (begin (log-optimization "unboxed binary inexact complex" #'op) - #`(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)] - [rs (append (map (lambda (x) (unboxed-gensym)) - (syntax->list #'(cs.real-part ...))) - (list #'real-part))] - [is (append (map (lambda (x) (unboxed-gensym)) - (syntax->list #'(cs.imag-part ...))) - (list #'imag-part))] - [res '()]) - (if (null? e1) - (reverse res) - (loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is) - ;; complex multiplication, imag part, then real part (reverse) - ;; we eliminate operations on the imaginary parts of reals - (let ((o-real? (equal? (syntax->datum o2) 0.0)) - (e-real? (equal? (syntax->datum (car e2)) 0.0))) - (list* #`(#,(car is) - #,(cond ((and o-real? e-real?) #'0.0) - (o-real? #`(unsafe-fl* #,o1 #,(car e2))) - (e-real? #`(unsafe-fl* #,o2 #,(car e1))) - (else - #`(unsafe-fl+ (unsafe-fl* #,o2 #,(car e1)) - (unsafe-fl* #,o1 #,(car e2)))))) - #`(#,(car rs) - #,(cond ((or o-real? e-real?) - #`(unsafe-fl* #,o1 #,(car e1))) - (else - #`(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 imags (map (lambda (x) (if (syntax->datum x) x #'0.0)) - (syntax->list #'(c1.imag-part c2.imag-part cs.imag-part ...))) - #:with (bindings ...) - (begin (log-optimization "unboxed binary inexact complex" #'op) - #`(c1.bindings ... c2.bindings ... cs.bindings ... ... - ;; we want to bind the intermediate results to reuse them - ;; the final results are bound to real-part and imag-part - #,@(let loop ([o1 (car (syntax->list #'reals))] - [o2 (car (syntax->list #'imags))] - [e1 (cdr (syntax->list #'reals))] - [e2 (cdr (syntax->list #'imags))] - [rs (append (map (lambda (x) (unboxed-gensym)) - (syntax->list #'(cs.real-part ...))) - (list #'real-part))] - [is (append (map (lambda (x) (unboxed-gensym)) - (syntax->list #'(cs.imag-part ...))) - (list #'imag-part))] - [ds (map (lambda (x) (unboxed-gensym)) - (syntax->list #'(c2.real-part cs.real-part ...)))] - [res '()]) - (if (null? e1) - (reverse res) - (loop (car rs) (car is) (cdr e1) (cdr e2) (cdr rs) (cdr is) (cdr ds) - ;; complex division, imag part, real part, then denominator (reverse) - (let ((o-real? (equal? (syntax->datum o2) 0.0)) - (e-real? (equal? (syntax->datum (car e2)) 0.0))) - (cond [(and o-real? e-real?) - (list* - #`(#,(car is) 0.0) ; currently not propagated - #`(#,(car rs) (unsafe-fl/ #,o1 #,(car e1))) - res)] - [o-real? - (list* - #`(#,(car is) - (unsafe-fl/ (unsafe-fl- 0.0 - (unsafe-fl* #,o1 #,(car e2))) - #,(car ds))) - #`(#,(car rs) (unsafe-fl/ (unsafe-fl* #,o1 #,(car e1)) - #,(car ds))) - #`(#,(car ds) (unsafe-fl+ (unsafe-fl* #,(car e1) #,(car e1)) - (unsafe-fl* #,(car e2) #,(car e2)))) - res)] - [e-real? - (list* - #`(#,(car is) (unsafe-fl/ #,o2 #,(car e1))) - #`(#,(car rs) (unsafe-fl/ #,o1 #,(car e1))) - res)] - [else - (list* - #`(#,(car is) - (unsafe-fl/ (unsafe-fl- (unsafe-fl* #,o2 #,(car e1)) - (unsafe-fl* #,o1 #,(car e2))) - #,(car ds))) - #`(#,(car rs) - (unsafe-fl/ (unsafe-fl+ (unsafe-fl* #,o1 #,(car e1)) - (unsafe-fl* #,o2 #,(car e2))) - #,(car ds))) - #`(#,(car ds) - (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) - #:with (bindings ...) - (begin (log-optimization "unboxed unary inexact complex" #'op) - #`(#,@(append (syntax->list #'(c.bindings ...)) - (list #'(imag-part (unsafe-fl- 0.0 c.imag-part))))))) - (pattern e:expr - #:when (isoftype? #'e -InexactComplex) - #:with e* (unboxed-gensym) - #:with real-part (unboxed-gensym) - #:with imag-part (unboxed-gensym) - #:with (bindings ...) - #`((e* #,((optimize) #'e)) - (real-part (unsafe-flreal-part e*)) - (imag-part (unsafe-flimag-part e*)))) - ;; special handling of reals - (pattern e:float-expr - #:with real-part (unboxed-gensym) - #:with imag-part #f - #:with (bindings ...) - #`((real-part #,((optimize) #'e)))) - (pattern e:fixnum-expr - #:with real-part (unboxed-gensym) - #:with imag-part #f - #:with (bindings ...) - #`((real-part (unsafe-fx->fl #,((optimize) #'e))))) - (pattern e:int-expr - #:with real-part (unboxed-gensym) - #:with imag-part #f - #:with (bindings ...) - #`((real-part (->fl #,((optimize) #'e))))) - (pattern e:expr - #:when (isoftype? #'e -Real) - #:with real-part (unboxed-gensym) - #:with imag-part #f - #:with (bindings ...) - #`((real-part (exact->inexact #,((optimize) #'e))))) - (pattern e:expr - #:with (bindings ...) - (error "non exhaustive pattern match") - #:with real-part #f - #:with imag-part #f)) - -(define-syntax-class inexact-complex-unary-op - (pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part) - (pattern (~or (~literal imag-part) (~literal flimag-part)) #:with unsafe #'unsafe-flimag-part)) - -(define-syntax-class inexact-complex-binary-op - (pattern (~or (~literal +) (~literal -) (~literal *) (~literal /) (~literal conjugate)))) - -(define-syntax-class inexact-complex-expr - (pattern e:expr - #:when (isoftype? #'e -InexactComplex) - #:with opt ((optimize) #'e))) - -(define-syntax-class inexact-complex-opt-expr - (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 ...)) - #:when (isoftype? #'exp -InexactComplex) - #:with exp*:unboxed-inexact-complex-opt-expr #'exp - #:with opt - (begin (log-optimization "unboxed inexact complex" #'exp) - (reset-unboxed-gensym) - #'(let* (exp*.bindings ...) - (unsafe-make-flrectangular exp*.real-part exp*.imag-part))))) diff --git a/collects/typed-scheme/optimizer/number.rkt b/collects/typed-scheme/optimizer/number.rkt new file mode 100644 index 00000000..310eec3b --- /dev/null +++ b/collects/typed-scheme/optimizer/number.rkt @@ -0,0 +1,17 @@ +#lang scheme/base + +(require syntax/parse + (for-template scheme/base) + "../utils/utils.rkt" + (optimizer utils)) + +(provide number-opt-expr) + +(define-syntax-class number-opt-expr + #:commit + ;; 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 730d6680..04bc1c79 100644 --- a/collects/typed-scheme/optimizer/optimizer.rkt +++ b/collects/typed-scheme/optimizer/optimizer.rkt @@ -1,52 +1,77 @@ #lang scheme/base -(require syntax/parse - syntax/id-table racket/dict - (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for) +(require syntax/parse unstable/syntax + racket/pretty + (for-template scheme/base) "../utils/utils.rkt" - (types abbrev type-table utils subtype) - (optimizer utils fixnum float inexact-complex vector pair sequence struct dead-code)) + (optimizer utils number fixnum float float-complex vector string + pair sequence box struct dead-code apply unboxed-let)) (provide optimize-top) (define-syntax-class opt-expr + #:commit (pattern e:opt-expr* #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f))) (define-syntax-class opt-expr* + #:commit #:literal-sets (kernel-literals) ;; interesting cases, where something is optimized + (pattern e:dead-code-opt-expr #:with opt #'e.opt) + (pattern e:unboxed-let-opt-expr #:with opt #'e.opt) + (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) - (pattern e:inexact-complex-opt-expr #:with opt #'e.opt) + (pattern e:float-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) (pattern e:struct-opt-expr #:with opt #'e.opt) - (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 (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 #%plain-lambda) (~literal define-values))) + formals e:expr ...) + #:with opt #`(op formals #,@(syntax-map (optimize) #'(e ...)))) + (pattern (case-lambda [formals e:expr ...] ...) + ;; optimize all the bodies + #:with (opt-parts ...) + (syntax-map (lambda (part) + (let ((l (syntax->list part))) + (cons (car l) + (map (optimize) (cdr l))))) + #'([formals e ...] ...)) + #:with opt #'(case-lambda opt-parts ...)) + (pattern ((~and op (~or (~literal let-values) (~literal letrec-values))) + ([ids e-rhs:expr] ...) e-body:expr ...) + #:with (opt-rhs ...) (syntax-map (optimize) #'(e-rhs ...)) + #:with opt #`(op ([ids opt-rhs] ...) + #,@(syntax-map (optimize) #'(e-body ...)))) + (pattern (letrec-syntaxes+values stx-bindings + ([(ids ...) e-rhs:expr] ...) + e-body:expr ...) + ;; optimize all the rhss + #:with (opt-clauses ...) + (syntax-map (lambda (clause) + (let ((l (syntax->list clause))) + (list (car l) ((optimize) (cadr l))))) + #'([(ids ...) e-rhs] ...)) + #:with opt #`(letrec-syntaxes+values + stx-bindings + (opt-clauses ...) + #,@(syntax-map (optimize) #'(e-body ...)))) (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 ...)) + #:with opt #`(kw #,@(syntax-map (optimize) #'(expr ...)))) (pattern other:expr #:with opt #'other)) @@ -58,12 +83,18 @@ (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) stx)) - (if (and *log-optimizations?* - *log-optimizatons-to-log-file?*) - (close-output-port port) - #t)))) + [optimize (syntax-parser + [e:expr + #:when (and (not (syntax-property #'e 'typechecker:ignore)) + (not (syntax-property #'e 'typechecker:ignore-some)) + (not (syntax-property #'e 'typechecker:with-handlers))) + #:with e*:opt-expr #'e + #'e*.opt] + [e:expr #'e])]) + (let ((result ((optimize) stx))) + (when *show-optimized-code* + (pretty-print (syntax->datum result))) + result)) + (when (and *log-optimizations?* + *log-optimizatons-to-log-file?*) + (close-output-port port))))) diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt index 145d31bc..fa90529e 100644 --- a/collects/typed-scheme/optimizer/pair.rkt +++ b/collects/typed-scheme/optimizer/pair.rkt @@ -1,21 +1,23 @@ #lang scheme/base -(require syntax/parse - syntax/id-table racket/dict - unstable/match scheme/match +(require syntax/parse unstable/syntax + racket/match (for-template scheme/base scheme/unsafe/ops) "../utils/utils.rkt" (rep type-rep) - (types abbrev type-table utils subtype) + (types type-table utils) + (typecheck typechecker) (optimizer utils)) (provide pair-opt-expr) -(define-syntax-class pair-unary-op +(define-syntax-class pair-op + #:commit (pattern (~literal car) #:with unsafe #'unsafe-car) (pattern (~literal cdr) #:with unsafe #'unsafe-cdr)) (define-syntax-class mpair-op + #:commit (pattern (~literal mcar) #:with unsafe #'unsafe-mcar) (pattern (~literal mcdr) #:with unsafe #'unsafe-mcdr) (pattern (~literal set-mcar!) #:with unsafe #'unsafe-set-mcar!) @@ -23,12 +25,14 @@ (define-syntax-class pair-expr + #:commit (pattern e:expr #:when (match (type-of #'e) ; type of the operand [(tc-result1: (Pair: _ _)) #t] [_ #f]) #:with opt ((optimize) #'e))) (define-syntax-class mpair-expr + #:commit (pattern e:expr #:when (match (type-of #'e) ; type of the operand [(tc-result1: (MPair: _ _)) #t] @@ -36,11 +40,90 @@ #:with opt ((optimize) #'e))) (define-syntax-class pair-opt-expr - (pattern (#%plain-app op:pair-unary-op p:pair-expr) + #:commit + (pattern e:pair-derived-opt-expr #:with opt - (begin (log-optimization "unary pair" #'op) + (begin (log-optimization "derived pair" #'e) + #'e.opt)) + (pattern (#%plain-app op:pair-op p:pair-expr) + #:with opt + (begin (log-optimization "pair" #'op) #'(op.unsafe p.opt))) (pattern (#%plain-app op:mpair-op p:mpair-expr e:expr ...) #:with opt (begin (log-optimization "mutable pair" #'op) - #`(op.unsafe p.opt #,@(map (optimize) (syntax->list #'(e ...))))))) + #`(op.unsafe p.opt #,@(syntax-map (optimize) #'(e ...)))))) + + +;; if the equivalent sequence of cars and cdrs is guaranteed not to fail, +;; we can optimize + +;; accessors is a list of syntax objects, all #'car or #'cdr +(define (gen-alt accessors stx) + (syntax-parse stx + [(#%plain-app op arg) + (define (gen-alt-helper accessors) + (if (null? accessors) + #'arg + (quasisyntax/loc stx + (#%plain-app #,(car accessors) + #,(gen-alt-helper (cdr accessors)))))) + (let ((ty (type-of stx)) + (obj (gen-alt-helper accessors))) + ;; we're calling the typechecker, but this is just a shortcut, we're + ;; still conceptually single pass (we're not iterating). we could get + ;; the same result by statically destructing the types. + (tc-expr/check obj ty) + obj)])) + +(define-syntax-rule (gen-pair-derived-expr name (orig seq ...) ...) + (define-syntax-class name + #:commit + (pattern (#%plain-app (~literal orig) x) + #:with alt (gen-alt (list seq ...) this-syntax)) + ...)) +(gen-pair-derived-expr pair-derived-expr + (caar #'car #'car) + (cadr #'car #'cdr) + (cdar #'cdr #'car) + (cddr #'cdr #'cdr) + (caaar #'car #'car #'car) + (caadr #'car #'car #'cdr) + (cadar #'car #'cdr #'car) + (caddr #'car #'cdr #'cdr) + (cdaar #'cdr #'car #'car) + (cdadr #'cdr #'car #'cdr) + (cddar #'cdr #'cdr #'car) + (cdddr #'cdr #'cdr #'cdr) + (caaaar #'car #'car #'car #'car) + (caaadr #'car #'car #'car #'cdr) + (caadar #'car #'car #'cdr #'car) + (caaddr #'car #'car #'cdr #'cdr) + (cadaar #'car #'cdr #'car #'car) + (cadadr #'car #'cdr #'car #'cdr) + (caddar #'car #'cdr #'cdr #'car) + (cadddr #'car #'cdr #'cdr #'cdr) + (cdaaar #'cdr #'car #'car #'car) + (cdaadr #'cdr #'car #'car #'cdr) + (cdadar #'cdr #'car #'cdr #'car) + (cdaddr #'cdr #'car #'cdr #'cdr) + (cddaar #'cdr #'cdr #'car #'car) + (cddadr #'cdr #'cdr #'car #'cdr) + (cdddar #'cdr #'cdr #'cdr #'car) + (cddddr #'cdr #'cdr #'cdr #'cdr) + (first #'car) + (second #'car #'cdr) + (third #'car #'cdr #'cdr) + (fourth #'car #'cdr #'cdr #'cdr) + (fifth #'car #'cdr #'cdr #'cdr #'cdr) + (sixth #'car #'cdr #'cdr #'cdr #'cdr #'cdr) + (seventh #'car #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr) + (eighth #'car #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr) + (ninth #'car #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr) + (tenth #'car #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr #'cdr)) + +(define-syntax-class pair-derived-opt-expr + #:commit + (pattern e:pair-derived-expr + #:with e*:pair-opt-expr #'e.alt + #:with opt #'e*.opt)) diff --git a/collects/typed-scheme/optimizer/sequence.rkt b/collects/typed-scheme/optimizer/sequence.rkt index c1713099..2ca95990 100644 --- a/collects/typed-scheme/optimizer/sequence.rkt +++ b/collects/typed-scheme/optimizer/sequence.rkt @@ -1,18 +1,18 @@ #lang scheme/base (require syntax/parse - syntax/id-table racket/dict - unstable/match scheme/match + racket/match (for-template scheme/base scheme/unsafe/ops) "../utils/utils.rkt" "../utils/tc-utils.rkt" (rep type-rep) - (types abbrev type-table utils subtype) - (optimizer utils)) + (types abbrev type-table utils) + (optimizer utils string)) (provide sequence-opt-expr) (define-syntax-class list-expr + #:commit (pattern e:expr #:when (match (type-of #'e) [(tc-result1: (Listof: _)) #t] @@ -22,6 +22,7 @@ ;; unlike other vector optimizations, this works on unknown-length vectors (define-syntax-class vector-expr + #:commit (pattern e:expr #:when (match (type-of #'e) [(tc-result1: (Vector: _)) #t] @@ -29,16 +30,8 @@ [_ #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 + #:commit ;; 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 (pattern (#%plain-app op:id _ l) @@ -58,8 +51,8 @@ #:with opt (begin (log-optimization "in-vector" #'op) #'(let* ((i v*.opt) - (len (unsafe-vector*-length i))) - (values (lambda (x) (unsafe-vector*-ref i x)) + (len (unsafe-vector-length i))) + (values (lambda (x) (unsafe-vector-ref i x)) (lambda (x) (unsafe-fx+ 1 x)) 0 (lambda (x) (unsafe-fx< x len)) diff --git a/collects/typed-scheme/optimizer/string.rkt b/collects/typed-scheme/optimizer/string.rkt new file mode 100644 index 00000000..66ac4b6f --- /dev/null +++ b/collects/typed-scheme/optimizer/string.rkt @@ -0,0 +1,31 @@ +#lang scheme/base + +(require syntax/parse + (for-template scheme/base scheme/unsafe/ops) + "../utils/utils.rkt" + (types abbrev) + (optimizer utils)) + +(provide string-opt-expr string-expr bytes-expr) + +(define-syntax-class string-expr + #:commit + (pattern e:expr + #:when (isoftype? #'e -String) + #:with opt ((optimize) #'e))) +(define-syntax-class bytes-expr + #:commit + (pattern e:expr + #:when (isoftype? #'e -Bytes) + #:with opt ((optimize) #'e))) + +(define-syntax-class string-opt-expr + #:commit + (pattern (#%plain-app (~literal string-length) s:string-expr) + #:with opt + (begin (log-optimization "string-length" #'op) + #'(unsafe-string-length s.opt))) + (pattern (#%plain-app (~literal bytes-length) s:bytes-expr) + #:with opt + (begin (log-optimization "bytes-length" #'op) + #'(unsafe-bytes-length s.opt)))) diff --git a/collects/typed-scheme/optimizer/struct.rkt b/collects/typed-scheme/optimizer/struct.rkt index 575b985e..3271b18b 100644 --- a/collects/typed-scheme/optimizer/struct.rkt +++ b/collects/typed-scheme/optimizer/struct.rkt @@ -1,17 +1,15 @@ #lang scheme/base -(require syntax/parse - syntax/id-table racket/dict - unstable/match scheme/match +(require syntax/parse unstable/syntax (for-template scheme/base scheme/unsafe/ops) "../utils/utils.rkt" - (rep type-rep) - (types abbrev type-table utils subtype) + (types type-table) (optimizer utils)) (provide struct-opt-expr) (define-syntax-class struct-opt-expr + #:commit ;; we can always optimize struct accessors and mutators ;; if they typecheck, they're safe (pattern (#%plain-app op:id s:expr v:expr ...) @@ -23,4 +21,4 @@ #`(unsafe-struct-ref #,((optimize) #'s) #,idx)) (begin (log-optimization "struct set" #'op) #`(unsafe-struct-set! #,((optimize) #'s) #,idx - #,@(map (optimize) (syntax->list #'(v ...))))))))) + #,@(syntax-map (optimize) #'(v ...)))))))) diff --git a/collects/typed-scheme/optimizer/unboxed-let.rkt b/collects/typed-scheme/optimizer/unboxed-let.rkt new file mode 100644 index 00000000..6d9c1f0d --- /dev/null +++ b/collects/typed-scheme/optimizer/unboxed-let.rkt @@ -0,0 +1,327 @@ +#lang scheme/base + +(require syntax/parse unstable/syntax + scheme/list scheme/dict racket/match + "../utils/utils.rkt" + "../utils/tc-utils.rkt" + (for-template scheme/base) + (types abbrev utils type-table) + (rep type-rep) + (optimizer utils float-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 + #:commit + (pattern e:app-of-unboxed-let-opt-expr + #:with opt #'e.opt) + (pattern (~var e (unboxed-let-opt-expr-internal #f)) + #:with opt #'e.opt)) + +;; let loops expand to an application of a letrec-values +;; thus, the loop function technically escapes from the letrec, but it +;; escapes in the operator position of a call site we control (here) +;; we can extend unboxing +(define-syntax-class app-of-unboxed-let-opt-expr + #:commit + #:literal-sets (kernel-literals) + (pattern (#%plain-app + (~and let-e ((~literal letrec-values) + bindings + loop-fun:id)) ; sole element of the body + args:expr ...) + #:with (~var operator (unboxed-let-opt-expr-internal #t)) #'let-e + #:with unboxed-info (dict-ref unboxed-funs-table #'loop-fun #f) + #:when (syntax->datum #'unboxed-info) + #:with (~var e* (float-complex-call-site-opt-expr + #'unboxed-info #'operator.opt)) + this-syntax + #:with opt + (begin (log-optimization "unboxed let loop" #'loop-fun) + #'e*.opt))) + +;; does the bulk of the work +;; detects which let bindings can be unboxed, same for arguments of let-bound +;; functions +(define-syntax-class (unboxed-let-opt-expr-internal let-loop?) + #:commit + #:literal-sets (kernel-literals) + (pattern (letk:let-like-keyword ((~and clause (lhs rhs ...)) ...) + 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 ...) (function-candidates ...) (others ...)) + (let*-values + (((candidates rest) + ;; clauses of form ((v) rhs), currently only supports 1 lhs var + (partition + (lambda (p) + (and (isoftype? (cadr p) -FloatComplex) + (could-be-unboxed-in? (car (syntax-e (car p))) + #'(begin body ...)))) + (syntax-map syntax->list #'(clause ...)))) + ((function-candidates others) + ;; extract function bindings that have float-complex arguments + ;; we may be able to pass arguments unboxed + ;; this covers loop variables + (partition + (lambda (p) + (and + ;; typed racket introduces let-values that bind no values + ;; we can't optimize these + (not (null? (syntax-e (car p)))) + (let ((fun-name (car (syntax-e (car p))))) + (and + ;; if the function escapes, we can't change it's interface + (not (is-var-mutated? fun-name)) + (not (escapes? fun-name #'(begin rhs ... ...) #f)) + (not (escapes? fun-name #'(begin body ...) let-loop?)) + (match (type-of (cadr p)) ; rhs, we want a lambda + [(tc-result1: (Function: (list (arr: doms rngs + (and rests #f) + (and drests #f) + (and kws '()))))) + ;; at least 1 argument has to be of type float-complex + ;; and can be unboxed + (syntax-parse (cadr p) + [((~literal #%plain-lambda) params body ...) + ;; keep track of the param # of each param that can be unboxed + (let loop ((unboxed '()) + (boxed '()) + (i 0) + (params (syntax->list #'params)) + (doms doms)) + (cond [(null? params) + ;; done. can we unbox anything? + (and (> (length unboxed) 0) + ;; if so, add to the table of functions with + ;; unboxed params, so we can modify its call + ;; sites, it's body and its header + (begin (log-optimization + "unboxed function -> table" + fun-name) + #t) + (dict-set! unboxed-funs-table fun-name + (list (reverse unboxed) + (reverse boxed))))] + [(and (equal? (car doms) -FloatComplex) + (could-be-unboxed-in? + (car params) #'(begin body ...))) + ;; we can unbox + (log-optimization "unboxed var -> table" + (car params)) + (loop (cons i unboxed) boxed + (add1 i) (cdr params) (cdr doms))] + [else ; can't unbox + (loop unboxed (cons i boxed) + (add1 i) (cdr params) (cdr doms))]))] + [_ #f])] + [_ #f]))))) + rest))) + (list candidates function-candidates others)) + #:with (opt-candidates:unboxed-let-clause ...) #'(candidates ...) + #:with (opt-functions:unboxed-fun-clause ...) #'(function-candidates ...) + #:with (opt-others:opt-let-clause ...) #'(others ...) + #:with opt + (begin (when (not (null? (syntax->list #'(opt-candidates.id ...)))) + ;; only log when we actually optimize + (log-optimization "unboxed let bindings" this-syntax)) + ;; 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-binding ...)))) + (i (in-list (syntax->list #'(opt-candidates.imag-binding ...))))) + (dict-set! unboxed-vars-table v (list r i))) + ;; in the case where no bindings are unboxed, we create a let + ;; that is equivalent to the original, but with all parts + ;; optimized + #`(letk.key ... + (opt-candidates.bindings ... ... + opt-functions.res ... + opt-others.res ...) + #,@(syntax-map (optimize) #'(body ...)))))) + +(define-splicing-syntax-class let-like-keyword + #:commit + #:literal-sets (kernel-literals) + (pattern (~literal let-values) + #:with (key ...) #'(let*-values)) + (pattern (~literal letrec-values) + #:with (key ...) #'(letrec-values)) + (pattern (~seq (~literal letrec-syntaxes+values) stx-bindings) + #:with (key ...) #'(letrec-syntaxes+values stx-bindings))) + + +(define (direct-child-of? v exp) + (ormap (lambda (x) (and (identifier? x) (free-identifier=? x v))) + (syntax->list exp))) + +;; if a variable is used at least once in complex arithmetic operations, +;; it's worth unboxing +(define (could-be-unboxed-in? v 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) + (ormap rec (syntax->list exp))) + + (define (rec exp) + (syntax-parse exp + #:literal-sets (kernel-literals) + + ;; can be used in a complex arithmetic expr, can be a direct child + [exp:float-complex-arith-opt-expr + #:when (not (identifier? #'exp)) + (or (direct-child-of? v #'exp) + (ormap rec (syntax->list #'exp)))] + ;; if the variable gets rebound to something else, we look for unboxing + ;; opportunities for the new variable too + ;; this case happens in the expansion of the for macros, so we care + [(l:let-like-keyword + ([ids e-rhs:expr] ...) e-body:expr ...) + #:with rebindings + (filter (lambda (x) x) + (syntax-map (syntax-parser + [((id) rhs) + #:when (and (identifier? #'rhs) + (free-identifier=? v #'rhs)) + #'id] + [_ #f]) + #'((ids e-rhs) ...))) + (or (look-at #'(e-rhs ... e-body ...)) + (ormap (lambda (x) (could-be-unboxed-in? x exp)) + (syntax->list #'rebindings)))] + + ;; 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 ... ...))] + [(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, not worth unboxing + [_ #f])) + + ;; of course, if the var is mutated, we can't do anything + (and (not (is-var-mutated? v)) + (rec exp))) + +;; very simple escape analysis for functions +;; if a function is ever used in a non-operator position, we consider it escapes +;; if it doesn't escape, we may be able to pass its float complex args unboxed +;; if we are in a let loop, don't consider functions that escape by being the +;; sole thing in the let's body as escaping, since they would only escape to +;; a call site that we control, which is fine +(define (escapes? v exp let-loop?) + + (define (look-at exp) + (or (direct-child-of? v exp) + (ormap rec (syntax->list exp)))) + + (define (rec exp) + (syntax-parse exp + #:literal-sets (kernel-literals) + + [((~or (~literal #%plain-app) (~literal #%app)) + rator:expr rands:expr ...) + (or (direct-child-of? v #'(rands ...)) ; used as an argument, escapes + (ormap rec (syntax->list #'(rator rands ...))))] + + [((~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 ...))] + + ;; does not escape + [_ #f])) + + ;; if the given var is the _only_ element of the body and we're in a + ;; let loop, we let it slide + (and (not (and let-loop? + (syntax-parse exp + #:literal-sets (kernel-literals) + ;; the body gets wrapped in a begin before it's sent here + [(begin i:identifier) + (free-identifier=? #'i v)] + [_ #f]))) + (rec exp))) + +;; let clause whose rhs is going to be unboxed (turned into multiple bindings) +(define-syntax-class unboxed-let-clause + #:commit + (pattern ((v:id) rhs:unboxed-float-complex-opt-expr) + #:with id #'v + #:with real-binding #'rhs.real-binding + #:with imag-binding #'rhs.imag-binding + #:with (bindings ...) #'(rhs.bindings ...))) + +;; let clause whose rhs is a function with some float complex arguments +;; these arguments may be unboxed +;; the new function will have all the unboxed arguments first, then all the boxed +(define-syntax-class unboxed-fun-clause + #:commit + (pattern ((v:id) (#%plain-lambda params body:expr ...)) + #:with id #'v + #:with unboxed-info (dict-ref unboxed-funs-table #'v #f) + #:when (syntax->datum #'unboxed-info) + ;; partition of the arguments + #:with ((to-unbox ...) (boxed ...)) #'unboxed-info + #:with (real-params ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-real-")) + #'(to-unbox ...)) + #:with (imag-params ...) (syntax-map (lambda (x) (unboxed-gensym "unboxed-imag-")) + #'(to-unbox ...)) + #:with res + (begin + (log-optimization "fun -> unboxed fun" #'v) + ;; add unboxed parameters to the unboxed vars table + (let ((to-unbox (syntax-map syntax->datum #'(to-unbox ...)))) + (let loop ((params (syntax->list #'params)) + (i 0) + (real-parts (syntax->list #'(real-params ...))) + (imag-parts (syntax->list #'(imag-params ...))) + (boxed '())) + (cond [(null? params) ; done, create the new clause + ;; real parts of unboxed parameters go first, then all imag + ;; parts, then boxed occurrences of unboxed parameters will + ;; be inserted when optimizing the body + #`((v) (#%plain-lambda + (real-params ... imag-params ... #,@(reverse boxed)) + #,@(syntax-map (optimize) #'(body ...))))] + + [(memq i to-unbox) ; we unbox the current param, add to the table + (dict-set! unboxed-vars-table (car params) + (list (car real-parts) (car imag-parts))) + (loop (cdr params) (add1 i) + (cdr real-parts) (cdr imag-parts) + boxed)] + [else ; that param stays boxed, keep going + (loop (cdr params) (add1 i) + real-parts imag-parts + (cons (car params) boxed))])))))) + +(define-syntax-class opt-let-clause + #:commit + (pattern (vs rhs:expr) + #:with res #`(vs #,((optimize) #'rhs)))) diff --git a/collects/typed-scheme/optimizer/utils.rkt b/collects/typed-scheme/optimizer/utils.rkt index 912b0184..2fa5ba4c 100644 --- a/collects/typed-scheme/optimizer/utils.rkt +++ b/collects/typed-scheme/optimizer/utils.rkt @@ -1,30 +1,35 @@ #lang scheme/base -(require unstable/match scheme/match +(require unstable/match racket/match racket/dict syntax/id-table unstable/syntax - (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops) "../utils/utils.rkt" - (types abbrev type-table utils subtype) + (for-template scheme/base) + (types type-table utils subtype) (rep type-rep)) -(provide log-optimization *log-optimizations?* *log-optimizatons-to-log-file?* *optimization-log-file* +(provide log-optimization *log-optimizations?* *log-optimizatons-to-log-file?* + *optimization-log-file* *show-optimized-code* subtypeof? isoftype? mk-unsafe-tbl n-ary->binary unboxed-gensym reset-unboxed-gensym optimize) - -(define *log-optimizations?* #f) +(define *log-optimizations?* + (member "--log-optimizations" + (vector->list (current-command-line-arguments)))) (define *log-optimizatons-to-log-file?* #f) (define *optimization-log-file* "opt-log") (define (log-optimization kind stx) (if *log-optimizations?* (printf "~a line ~a col ~a - ~a - ~a\n" - (syntax-source stx) (syntax-line stx) (syntax-column stx) + (syntax-source-file-name stx) + (syntax-line stx) (syntax-column stx) (syntax->datum stx) kind) #t)) +;; if set to #t, the optimizer will dump its result to stdout before compilation +(define *show-optimized-code* #f) ;; is the syntax object s's type a subtype of t? (define (subtypeof? s t) @@ -49,12 +54,10 @@ ;; to generate temporary symbols in a predictable manner ;; these identifiers are unique within a sequence of unboxed operations -;; 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)) diff --git a/collects/typed-scheme/optimizer/vector.rkt b/collects/typed-scheme/optimizer/vector.rkt index 10144147..69c1841b 100644 --- a/collects/typed-scheme/optimizer/vector.rkt +++ b/collects/typed-scheme/optimizer/vector.rkt @@ -1,22 +1,24 @@ #lang scheme/base -(require syntax/parse - unstable/match scheme/match - (for-template scheme/base scheme/flonum scheme/unsafe/ops) +(require syntax/parse unstable/syntax + racket/match + (for-template scheme/base racket/flonum scheme/unsafe/ops) "../utils/utils.rkt" (rep type-rep) - (types abbrev type-table utils subtype) + (types type-table utils) (optimizer utils)) (provide vector-opt-expr) (define-syntax-class vector-op + #:commit ;; we need the * versions of these unsafe operations to be chaperone-safe - (pattern (~literal vector-ref) #:with unsafe #'unsafe-vector*-ref) - (pattern (~literal vector-set!) #:with unsafe #'unsafe-vector*-set!)) + (pattern (~literal vector-ref) #:with unsafe #'unsafe-vector-ref) + (pattern (~literal vector-set!) #:with unsafe #'unsafe-vector-set!)) (define-syntax-class vector-expr + #:commit (pattern e:expr #:when (match (type-of #'e) [(tc-result1: (HeterogenousVector: _)) #t] @@ -24,13 +26,14 @@ #:with opt ((optimize) #'e))) (define-syntax-class vector-opt-expr + #:commit ;; vector-length of a known-length vector (pattern (#%plain-app (~and op (~or (~literal vector-length) (~literal unsafe-vector-length) (~literal unsafe-vector*-length))) v:vector-expr) #:with opt - (begin (log-optimization "known-length vector" #'op) + (begin (log-optimization "known-length vector-length" #'op) (match (type-of #'v) [(tc-result1: (HeterogenousVector: es)) #`(begin v.opt #,(length es))]))) ; v may have side effects @@ -39,12 +42,12 @@ ;; we can optimize no matter what. (pattern (#%plain-app (~and op (~literal vector-length)) v:expr) #:with opt - (begin (log-optimization "vector" #'op) - #`(unsafe-vector*-length #,((optimize) #'v)))) + (begin (log-optimization "vector-length" #'op) + #`(unsafe-vector-length #,((optimize) #'v)))) ;; same for flvector-length (pattern (#%plain-app (~and op (~literal flvector-length)) v:expr) #:with opt - (begin (log-optimization "flvector" #'op) + (begin (log-optimization "flvector-length" #'op) #`(unsafe-flvector-length #,((optimize) #'v)))) ;; we can optimize vector ref and set! on vectors of known length if we know ;; the index is within bounds (for now, literal or singleton type) @@ -60,4 +63,4 @@ #:with opt (begin (log-optimization "vector" #'op) #`(op.unsafe v.opt #,((optimize) #'i) - #,@(map (optimize) (syntax->list #'(new ...))))))) + #,@(syntax-map (optimize) #'(new ...)))))) diff --git a/collects/typed-scheme/private/annotate-classes.rkt b/collects/typed-scheme/private/annotate-classes.rkt index e9d65a81..78af9997 100644 --- a/collects/typed-scheme/private/annotate-classes.rkt +++ b/collects/typed-scheme/private/annotate-classes.rkt @@ -14,6 +14,17 @@ #:with ty (syntax-property #'name 'type-label) #:with ann-name #'name)) +(define-splicing-syntax-class optionally-annotated-name + #:attributes (name ann-name) + #:description "optionally type-annotated identifier" + #:literals (:) + (pattern n:annotated-name + #:with name #'n.name + #:with ann-name #'n.ann-name) + (pattern n:id + #:with name #'n + #:with ann-name #'n)) + (define-splicing-syntax-class (param-annotated-name trans) #:attributes (name ty ann-name) #:description "type-annotated identifier" @@ -26,11 +37,37 @@ (pattern (~and whole [:annotated-name rhs:expr]) #:with binding (syntax/loc #'whole [ann-name rhs]))) +(define-syntax-class optionally-annotated-binding + #:attributes (name ann-name binding rhs) + #:description "optionally type-annotated binding" + #:literals (:) + (pattern b:annotated-binding + #:with name #'b.name + #:with ann-name #'b.ann-name + #:with binding #'b.binding + #:with rhs #'b.rhs) + (pattern (~and whole [n:id rhs:expr]) + #:with name #'n + #:with ann-name #'n + #:with binding #'whole)) + (define-syntax-class annotated-values-binding #:attributes ((name 1) (ty 1) (ann-name 1) binding rhs) (pattern (~and whole [(~describe "sequence of type-annotated identifiers" ([:annotated-name] ...)) rhs:expr]) #:with binding (syntax/loc #'whole [(ann-name ...) rhs]))) +(define-syntax-class optionally-annotated-values-binding + #:attributes ((name 1) (ann-name 1) binding rhs) + (pattern b:annotated-values-binding + #:with (name ...) #'(b.name ...) + #:with (ann-name ...) #'(b.ann-name ...) + #:with binding #'b.binding + #:with rhs #'b.rhs) + (pattern (~and whole [(~describe "sequence of optionally type-annotated identifiers" (n:optionally-annotated-formal ...)) rhs:expr]) + #:with (name ...) #'(n.name ...) + #:with (ann-name ...) #'(n.ann-name ...) + #:with binding #'whole)) + (define-splicing-syntax-class annotated-star-rest #:attributes (name ann-name ty formal-ty) #:literals (:) @@ -53,6 +90,17 @@ #:attributes (name ty ann-name) (pattern [:annotated-name])) +(define-syntax-class optionally-annotated-formal + #:description "optionally annotated variable of the form [x : T] or just x" + #:opaque + #:attributes (name ann-name) + (pattern f:annotated-formal + #:with name #'f.name + #:with ann-name #'f.ann-name) + (pattern f:id + #:with name #'f + #:with ann-name #'f)) + (define-syntax-class annotated-formals #:attributes (ann-formals (arg-ty 1)) #:literals (:) @@ -63,3 +111,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/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index a2525f1d..48150e6d 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -1,18 +1,19 @@ #lang racket (require - "../utils/utils.rkt" - racket/tcp - (only-in rnrs/lists-6 fold-left) - '#%paramz - "extra-procs.rkt" - (utils tc-utils ) - (types union convenience) - (only-in '#%kernel [apply kernel:apply]) - racket/promise racket/system - (only-in string-constants/private/only-once maybe-print-message) - (only-in racket/match/runtime match:error matchable? match-equality-test) - (for-template racket racket/unsafe/ops) + "../utils/utils.rkt" + (for-template '#%paramz racket/base racket/list + racket/tcp + (only-in rnrs/lists-6 fold-left) + '#%paramz + "extra-procs.rkt" + (only-in '#%kernel [apply kernel:apply]) + racket/promise racket/system + (only-in string-constants/private/only-once maybe-print-message) + (only-in racket/match/runtime match:error matchable? match-equality-test) + racket/unsafe/ops) + (utils tc-utils) + (types union convenience) (rename-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym])) (provide indexing) @@ -137,7 +138,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)] @@ -172,9 +173,9 @@ [random (cl-> [(index-type) -Nat] [() -Real])] [raise-type-error - (cl-> - [(Sym -String Univ) (Un)] - [(Sym -String index-type (-lst Univ)) (Un)])] + (cl->* + [-> Sym -String Univ (Un)] + [->* (list Sym -String index-type) Univ (Un)])] )) diff --git a/collects/typed-scheme/private/base-env-indexing.rkt b/collects/typed-scheme/private/base-env-indexing.rkt index 23b72c05..04035590 100644 --- a/collects/typed-scheme/private/base-env-indexing.rkt +++ b/collects/typed-scheme/private/base-env-indexing.rkt @@ -1,11 +1,12 @@ -#lang scheme +#lang racket/base (require (rename-in "../utils/utils.rkt" [infer r:infer]) - (for-syntax (types abbrev) (env init-envs) (r:infer infer-dummy infer) - "base-env-indexing-abs.rkt")) + (types abbrev) (env init-envs) (r:infer infer-dummy infer) + "base-env-indexing-abs.rkt") -(define-for-syntax e (parameterize ([infer-param infer]) (indexing -Integer))) -(begin-for-syntax (initialize-type-env e)) +(define e (parameterize ([infer-param infer]) (indexing -Integer))) +(define (initialize-indexing) (initialize-type-env e)) +(provide initialize-indexing) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index b709fbb7..111e2484 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -2,24 +2,15 @@ (begin (require - scheme/tcp - scheme scheme/flonum scheme/fixnum - scheme/unsafe/ops - (only-in rnrs/lists-6 fold-left) - '#%paramz - "extra-procs.rkt" - (only-in '#%kernel [apply kernel:apply]) - scheme/promise scheme/system - (only-in string-constants/private/only-once maybe-print-message) - (only-in racket/match/runtime match:error matchable? match-equality-test) - (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym] [-Real R] [-ExactPositiveInteger -Pos]))) + (for-template racket/flonum racket/fixnum racket/math racket/unsafe/ops racket/base) + (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym] [-Real R] [-ExactPositiveInteger -Pos])) - (define-for-syntax all-num-types (list -Pos -Nat -Integer -ExactRational -Flonum -Real N)) + (define all-num-types (list -Pos -Nat -Integer -ExactRational -Flonum -InexactReal -Real N)) - (define-for-syntax binop + (define binop (lambda (t [r t]) (t t . -> . r))) - (define-for-syntax rounder + (define rounder (cl->* (-> -PositiveFixnum -PositiveFixnum) (-> -NonnegativeFixnum -NonnegativeFixnum) (-> -Fixnum -Fixnum) @@ -28,39 +19,40 @@ (-> -ExactRational -Integer) (-> -NonnegativeFlonum -NonnegativeFlonum) (-> -Flonum -Flonum) + (-> -InexactReal -InexactReal) (-> -Real -Real))) - (define-for-syntax (unop t) (-> t t)) + (define (unop t) (-> t t)) - (define-for-syntax fl-comp (binop -Flonum B)) - (define-for-syntax fl-op (binop -Flonum)) - (define-for-syntax fl-unop (unop -Flonum)) - (define-for-syntax fl-rounder + (define fl-comp (binop -Flonum B)) + (define fl-op (binop -Flonum)) + (define fl-unop (unop -Flonum)) + (define fl-rounder (cl->* (-> -NonnegativeFlonum -NonnegativeFlonum) (-> -Flonum -Flonum))) - (define-for-syntax int-op (binop -Integer)) - (define-for-syntax nat-op (binop -Nat)) + (define int-op (binop -Integer)) + (define nat-op (binop -Nat)) - (define-for-syntax fx-comp (binop -Integer B)) - (define-for-syntax fx-op (cl->* (-Pos -Pos . -> . -PositiveFixnum) + (define fx-comp (binop -Integer B)) + (define fx-op (cl->* (-Pos -Pos . -> . -PositiveFixnum) (-Nat -Nat . -> . -NonnegativeFixnum) (-Integer -Integer . -> . -Fixnum))) - (define-for-syntax fx-natop (cl->* (-Nat -Nat . -> . -NonnegativeFixnum) + (define fx-natop (cl->* (-Nat -Nat . -> . -NonnegativeFixnum) (-Integer -Integer . -> . -Fixnum))) - (define-for-syntax fx-unop (-Integer . -> . -Fixnum)) + (define fx-unop (-Integer . -> . -Fixnum)) - (define-for-syntax real-comp (->* (list R R) R B)) + (define real-comp (->* (list R R) R B)) ;; types for specific operations, to avoid repetition between safe and unsafe versions - (define-for-syntax fx+-type + (define fx+-type (cl->* (-Pos -Nat . -> . -PositiveFixnum) (-Nat -Pos . -> . -PositiveFixnum) (-Nat -Nat . -> . -NonnegativeFixnum) (-Integer -Integer . -> . -Fixnum))) - (define-for-syntax fx--type + (define fx--type (-Integer -Integer . -> . -Fixnum)) - (define-for-syntax fx=-type + (define fx=-type (cl->* (-> -Integer (-val 0) B : (-FS (-filter (-val 0) 0) -top)) (-> (-val 0) -Integer B : (-FS (-filter (-val 0) 1) -top)) @@ -71,40 +63,40 @@ (-> -Integer -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top)) (-> -NegativeFixnum -Integer B : (-FS (-filter -NegativeFixnum 1) -top)) fx-comp)) - (define-for-syntax fx<-type + (define fx<-type (cl->* (-> -Integer (-val 0) B : (-FS (-filter -NegativeFixnum 0) (-filter -NonnegativeFixnum 0))) (-> -Integer -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top)) (-> -Nat -Integer B : (-FS (-filter -PositiveFixnum 1) -top)) fx-comp)) - (define-for-syntax fx>-type + (define fx>-type (cl->* (-> -Integer (-val 0) B : (-FS (-filter -PositiveFixnum 0) -top)) (-> -NegativeFixnum -Integer B : (-FS (-filter -NegativeFixnum 1) -top)) (-> -Integer -Nat B : (-FS (-filter -PositiveFixnum 0) -top)) fx-comp)) - (define-for-syntax fx<=-type + (define fx<=-type (cl->* (-> -Integer (-val 0) B : (-FS -top (-filter -PositiveFixnum 0))) (-> -Integer -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top)) (-> -Pos -Integer B : (-FS (-filter -Pos 1) -top)) (-> -Nat -Integer B : (-FS (-filter -Nat 1) -top)) fx-comp)) - (define-for-syntax fx>=-type + (define fx>=-type (cl->* (-> -Integer (-val 0) B : (-FS (-filter -NonnegativeFixnum 0) -top)) (-> -NegativeFixnum -Integer B : (-FS (-filter -NegativeFixnum 1) -top)) (-> -Integer -Pos B : (-FS (-filter -Pos 0) -top)) (-> -Integer -Nat B : (-FS (-filter -Nat 0) -top)) fx-comp)) - (define-for-syntax fxmin-type + (define fxmin-type (cl->* (-> -NegativeFixnum -Integer -NegativeFixnum) (-> -Integer -NegativeFixnum -NegativeFixnum) (-> -Pos -Pos -PositiveFixnum) (-> -Nat -Nat -NonnegativeFixnum) (-> -Integer -Integer -Fixnum))) - (define-for-syntax fxmax-type + (define fxmax-type (cl->* (-> -NegativeFixnum -NegativeFixnum -NegativeFixnum) (-> -Pos -Integer -PositiveFixnum) @@ -113,26 +105,26 @@ (-> -Integer -Nat -NonnegativeFixnum) (-> -Integer -Integer -Fixnum))) - (define-for-syntax fl+*-type + (define fl+*-type (cl->* (-NonnegativeFlonum -NonnegativeFlonum . -> . -NonnegativeFlonum) (-Flonum -Flonum . -> . -Flonum))) - (define-for-syntax fl=-type + (define fl=-type (cl->* (-> -Flonum -NonnegativeFlonum B : (-FS (-filter -NonnegativeFlonum 0) -top)) (-> -NonnegativeFlonum -Flonum B : (-FS (-filter -NonnegativeFlonum 1) -top)) fl-comp)) - (define-for-syntax fl<-type + (define fl<-type (cl->* (-> -NonnegativeFlonum -Flonum B : (-FS (-filter -NonnegativeFlonum 1) -top)) fl-comp)) - (define-for-syntax fl>-type + (define fl>-type (cl->* (-> -Flonum -NonnegativeFlonum B : (-FS (-filter -NonnegativeFlonum 0) -top)) fl-comp)) - (define-for-syntax flmin-type + (define flmin-type (cl->* (-> -NonnegativeFlonum -NonnegativeFlonum -NonnegativeFlonum) (-> -Flonum -Flonum -Flonum))) - (define-for-syntax flmax-type + (define flmax-type (cl->* (-> -NonnegativeFlonum -Flonum -NonnegativeFlonum) (-> -Flonum -NonnegativeFlonum -NonnegativeFlonum) (-> -Flonum -Flonum -Flonum))) @@ -146,11 +138,12 @@ (-not-filter -Integer 0)))] [exact-integer? (make-pred-ty -Integer)] [real? (make-pred-ty -Real)] -[inexact-real? (make-pred-ty -Flonum)] +[flonum? (make-pred-ty -Flonum)] +[inexact-real? (make-pred-ty -InexactReal)] [complex? (make-pred-ty N)] [rational? (make-pred-ty -Real)] [exact? (asym-pred N B (-FS -top (-not-filter -ExactRational 0)))] -[inexact? (asym-pred N B (-FS -top (-not-filter (Un -Flonum -InexactComplex) 0)))] +[inexact? (asym-pred N B (-FS -top (-not-filter (Un -InexactReal -FloatComplex) 0)))] [fixnum? (make-pred-ty -Fixnum)] [positive? (cl->* (-> -Fixnum B : (-FS (-filter -PositiveFixnum 0) -top)) (-> -Integer B : (-FS (-filter -ExactPositiveInteger 0) -top)) @@ -235,27 +228,28 @@ [* (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 -Flonum) (Un -InexactReal -Flonum) -Flonum)) + (list (->* (list -InexactReal -Flonum) (Un -InexactReal -Flonum) -Flonum)) + (list (->* (list) -InexactReal -InexactReal)) (list (->* (list) -Real -Real)) - (list (->* (list) -InexactComplex -InexactComplex)) + (list (->* (list) (Un -FloatComplex -Flonum) -FloatComplex)) (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 (* 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) -InexactReal -InexactReal)) (list (->* (list) -Real -Real)) - (list (->* (list -Real) -InexactComplex -InexactComplex)) - (list (->* (list -InexactComplex) -Real -InexactComplex)) - (list (->* (list) -InexactComplex -InexactComplex)) + (list (->* (list) (Un -Real -FloatComplex) -FloatComplex)) + (list (->* (list -FloatComplex) N -FloatComplex)) + (list (->* (list N -FloatComplex) N -FloatComplex)) (list (->* (list) N N))))] [- (apply cl->* @@ -263,10 +257,11 @@ (->* (list t) t t)) (list (->* (list -Flonum) -Real -Flonum)) (list (->* (list -Real -Flonum) -Real -Flonum)) + (list (->* (list -InexactReal) -InexactReal -InexactReal)) (list (->* (list -Real) -Real -Real)) - (list (->* (list -Real) -InexactComplex -InexactComplex)) - (list (->* (list -InexactComplex) -Real -InexactComplex)) - (list (->* (list -InexactComplex) -InexactComplex -InexactComplex)) + (list (->* (list (Un -Real -FloatComplex)) (Un -Real -FloatComplex) -FloatComplex)) + (list (->* (list -FloatComplex) N -FloatComplex)) + (list (->* (list N -FloatComplex) N -FloatComplex)) (list (->* (list N) N N))))] [/ (apply cl->* (append (list (->* (list -Integer) -Integer -ExactRational)) @@ -274,8 +269,11 @@ (->* (list t) t t)) ;; 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 -InexactReal -Flonum) -InexactReal -Flonum)) + (list (->* (list -InexactReal) -InexactReal -InexactReal)) (list (->* (list -Real) -Real -Real)) - (list (->* (list -InexactComplex) -InexactComplex -InexactComplex)) + (list (->* (list (Un -Flonum -FloatComplex)) (Un -Real -FloatComplex) -FloatComplex)) + (list (->* (list -FloatComplex) -FloatComplex -FloatComplex)) (list (->* (list N) N N))))] [max (cl->* (->* (list -PositiveFixnum) -Fixnum -PositiveFixnum) @@ -288,6 +286,7 @@ (->* (list -ExactRational) -ExactRational -ExactRational) (->* (list -NonnegativeFlonum) -Flonum -NonnegativeFlonum) (->* (list -Flonum) -Flonum -Flonum) + (->* (list -InexactReal) -InexactReal -InexactReal) (->* (list -Real) -Real -Real))] [min (cl->* (->* (list -PositiveFixnum) -PositiveFixnum -PositiveFixnum) (->* (list -NonnegativeFixnum) -NonnegativeFixnum -NonnegativeFixnum) @@ -300,6 +299,7 @@ (->* (list -ExactRational) -ExactRational -ExactRational) (->* (list -NonnegativeFlonum) -NonnegativeFlonum -NonnegativeFlonum) (->* (list -Flonum) -Flonum -Flonum) + (->* (list -InexactReal) -InexactReal -InexactReal) (->* (list -Real) -Real -Real))] @@ -309,16 +309,18 @@ (-> -ExactRational -ExactRational) (-> -NonnegativeFlonum -NonnegativeFlonum) (-> -Flonum -Flonum) + (-> -InexactReal -InexactReal) (-> -Real -Real) - (-> -InexactComplex -InexactComplex) + (-> -FloatComplex -FloatComplex) (-> N N))] [sub1 (cl->* (-> -Pos -Nat) (-> -Integer -Integer) (-> -ExactRational -ExactRational) (-> -Flonum -Flonum) + (-> -InexactReal -InexactReal) (-> -Real -Real) - (-> -InexactComplex -InexactComplex) + (-> -FloatComplex -FloatComplex) (-> N N))] [quotient (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . -NonnegativeFixnum) @@ -336,11 +338,16 @@ (-Nat -Nat . -> . (-values (list -Nat -Nat))) (-Integer -Integer . -> . (-values (list -Integer -Integer))))] -[arithmetic-shift (cl->* (-Fixnum (Un -NegativeFixnum (-val 0)) . -> . -Fixnum) - (-Nat -Nat . -> . -Nat) +[arithmetic-shift (cl->* ((-val 0) (Un -NegativeFixnum (-val 0)) . -> . (-val 0)) + (-NonnegativeFixnum (Un -NegativeFixnum (-val 0)) . -> . -NonnegativeFixnum) + (-Fixnum (Un -NegativeFixnum (-val 0)) . -> . -Fixnum) + (-Nat -Integer . -> . -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) @@ -361,87 +368,109 @@ (-Fixnum . -> . -NonnegativeFixnum) (-Pos . -> . -Pos) (-Integer . -> . -Nat) + (-ExactRational . -> . -ExactRational) (-Flonum . -> . -NonnegativeFlonum) + (-InexactReal . -> . -InexactReal) (-Real . -> . -Real))] ;; exactness -[exact->inexact (cl->* +[exact->inexact (cl->* + (-Flonum . -> . -Flonum) ; no conversion + (-InexactReal . -> . -InexactReal) ; no conversion (-Real . -> . -Flonum) - (N . -> . -InexactComplex))] + (N . -> . -FloatComplex))] [inexact->exact (cl->* (-Real . -> . -ExactRational) (N . -> . N))] +[fl->exact-integer (cl->* + (-NonnegativeFlonum . -> . -Nat) + (-Flonum . -> . -Integer))] [floor rounder] [ceiling rounder] [truncate rounder] [round rounder] -[make-rectangular (cl->* (-Flonum -Flonum . -> . -InexactComplex) +[make-rectangular (cl->* (-Flonum -Flonum . -> . -FloatComplex) (-Real -Real . -> . N))] -[make-polar (cl->* (-Flonum -Flonum . -> . -InexactComplex) +[make-polar (cl->* (-Flonum -Flonum . -> . -FloatComplex) (-Real -Real . -> . N))] -[real-part (cl->* (-InexactComplex . -> . -Flonum) +[real-part (cl->* (-FloatComplex . -> . -Flonum) (N . -> . -Real))] -[imag-part (cl->* (-InexactComplex . -> . -Flonum) +[imag-part (cl->* (-FloatComplex . -> . -Flonum) (N . -> . -Real))] -[magnitude (cl->* (-InexactComplex . -> . -Flonum) +[magnitude (cl->* (-FloatComplex . -> . -Flonum) (N . -> . -Real))] -[angle (cl->* (-InexactComplex . -> . -Flonum) +[angle (cl->* (-FloatComplex . -> . -Flonum) (N . -> . -Real))] [numerator (cl->* (-ExactRational . -> . -Integer) (-Real . -> . -Real))] [denominator (cl->* (-ExactRational . -> . -Integer) (-Real . -> . -Real))] [rationalize (cl->* (-ExactRational -ExactRational . -> . -ExactRational) - (-Flonum . -> . -Flonum) - (-Real -Real . -> . N))] + (-Flonum -Flonum . -> . -Flonum) + (-InexactReal -InexactReal . -> . -InexactReal) + (-Real -Real . -> . -Real))] [expt (cl->* (-Nat -Nat . -> . -Nat) (-Integer -Nat . -> . -Integer) + (-Integer -Integer . -> . -ExactRational) (-Real -Integer . -> . -Real) - (-InexactComplex -InexactComplex . -> . -InexactComplex) + (-FloatComplex -FloatComplex . -> . -FloatComplex) (N N . -> . N))] [sqrt (cl->* (-Nat . -> . -Real) (-NonnegativeFlonum . -> . -NonnegativeFlonum) - (-InexactComplex . -> . -InexactComplex) + (-FloatComplex . -> . -FloatComplex) (N . -> . N))] +[integer-sqrt (cl->* + (-Zero . -> . -Zero) + (-NonnegativeFixnum . -> . -NonnegativeFixnum) + (-Nat . -> . -Nat) + (-NonnegativeFlonum . -> . -NonnegativeFlonum) + (-Real . -> . N))] [log (cl->* (-Pos . -> . -Real) - (-InexactComplex . -> . -InexactComplex) + (-FloatComplex . -> . -FloatComplex) (N . -> . N))] [exp (cl->* (-Flonum . -> . -Flonum) + (-InexactReal . -> . -InexactReal) (-Real . -> . -Real) - (-InexactComplex . -> . -InexactComplex) + (-FloatComplex . -> . -FloatComplex) (N . -> . N))] -[cos (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))] -[sin (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))] -[tan (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))] -[acos (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))] -[asin (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))] -[atan (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N) (-Real -Real . -> . N))] +[cos (cl->* (-Flonum . -> . -Flonum) (-InexactReal . -> . -InexactReal) (-Real . -> . -Real) (-FloatComplex . -> . -FloatComplex) (N . -> . N))] +[sin (cl->* (-Flonum . -> . -Flonum) (-InexactReal . -> . -InexactReal) (-Real . -> . -Real) (-FloatComplex . -> . -FloatComplex) (N . -> . N))] +[tan (cl->* (-Flonum . -> . -Flonum) (-InexactReal . -> . -InexactReal) (-Real . -> . -Real) (-FloatComplex . -> . -FloatComplex) (N . -> . N))] +[acos (cl->* (-Flonum . -> . -Flonum) (-InexactReal . -> . -InexactReal) (-Real . -> . -Real) (-FloatComplex . -> . -FloatComplex) (N . -> . N))] +[asin (cl->* (-Flonum . -> . -Flonum) (-InexactReal . -> . -InexactReal) (-Real . -> . -Real) (-FloatComplex . -> . -FloatComplex) (N . -> . N))] +[atan (cl->* (-Flonum . -> . -Flonum) (-InexactReal . -> . -InexactReal) (-Real . -> . -Real) (-FloatComplex . -> . -FloatComplex) (N . -> . N) (-Real -Real . -> . N))] [gcd (cl->* (null -Fixnum . ->* . -Fixnum) (null -Integer . ->* . -Integer))] [lcm (null -Integer . ->* . -Integer)] ;; scheme/math -[sgn (-Real . -> . -Real)] +[sgn (cl->* (-Zero . -> . -Zero) + (-ExactPositiveInteger . -> . -PositiveFixnum) + (-ExactNonnegativeInteger . -> . -NonnegativeFixnum) + (-ExactRational . -> . -Fixnum) + (-Flonum . -> . -Flonum) + (-InexactReal . -> . -InexactReal) + (-Real . -> . -Real))] + [pi -NonnegativeFlonum] [sqr (cl->* (-> -Pos -Pos) - (-> -Nat -Nat) - (-> -Integer -Integer) + (-> -Integer -Nat) (-> -ExactRational -ExactRational) - (-> -NonnegativeFlonum -NonnegativeFlonum) - (-> -Flonum -Flonum) + (-> -Flonum -NonnegativeFlonum) + (-> -InexactReal -InexactReal) (-> -Real -Real) - (-> -InexactComplex -InexactComplex) + (-> -FloatComplex -FloatComplex) (-> N N))] -[conjugate (cl->* (-InexactComplex . -> . -InexactComplex) +[conjugate (cl->* (-FloatComplex . -> . -FloatComplex) (N . -> . N))] -[sinh (cl->* (-InexactComplex . -> . -InexactComplex) +[sinh (cl->* (-FloatComplex . -> . -FloatComplex) (N . -> . N))] -[cosh (cl->* (-InexactComplex . -> . -InexactComplex) +[cosh (cl->* (-FloatComplex . -> . -FloatComplex) (N . -> . N))] -[tanh (cl->* (-InexactComplex . -> . -InexactComplex) +[tanh (cl->* (-FloatComplex . -> . -FloatComplex) (N . -> . N))] ;; unsafe numeric ops @@ -471,9 +500,9 @@ [unsafe-flexp fl-rounder] [unsafe-flsqrt fl-rounder] [unsafe-fx->fl (cl->* (-Nat . -> . -NonnegativeFlonum) (-Integer . -> . -Flonum))] -[unsafe-make-flrectangular (-Flonum -Flonum . -> . -InexactComplex)] -[unsafe-flreal-part (-InexactComplex . -> . -Flonum)] -[unsafe-flimag-part (-InexactComplex . -> . -Flonum)] +[unsafe-make-flrectangular (-Flonum -Flonum . -> . -FloatComplex)] +[unsafe-flreal-part (-FloatComplex . -> . -Flonum)] +[unsafe-flimag-part (-FloatComplex . -> . -Flonum)] [unsafe-fx+ fx+-type] [unsafe-fx- fx--type] @@ -551,9 +580,9 @@ [flexp fl-unop] [flsqrt fl-unop] [->fl (-Integer . -> . -Flonum)] -[make-flrectangular (-Flonum -Flonum . -> . -InexactComplex)] -[flreal-part (-InexactComplex . -> . -Flonum)] -[flimag-part (-InexactComplex . -> . -Flonum)] +[make-flrectangular (-Flonum -Flonum . -> . -FloatComplex)] +[flreal-part (-FloatComplex . -> . -Flonum)] +[flimag-part (-FloatComplex . -> . -Flonum)] ;; safe flvector ops diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 7f865c7a..4eccedf0 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -1,24 +1,31 @@ #lang s-exp "env-lang.rkt" (require - racket/tcp - racket - racket/unsafe/ops - racket/fixnum - (only-in rnrs/lists-6 fold-left) - '#%paramz - "extra-procs.rkt" - (only-in '#%kernel [apply kernel:apply]) + + + (for-template + (except-in racket -> ->* one-of/c) + racket/unsafe/ops + racket/tcp + racket/fixnum + racket/future + (only-in rnrs/lists-6 fold-left) + '#%paramz + "extra-procs.rkt" + (only-in '#%kernel [apply kernel:apply]) + (only-in racket/private/pre-base new-apply-proc) + scheme/promise scheme/system + racket/function + racket/mpair + racket/base + (only-in string-constants/private/only-once maybe-print-message) + (only-in mzscheme make-namespace) + (only-in racket/match/runtime match:error matchable? match-equality-test)) (only-in racket/private/pre-base new-apply-proc) - (for-syntax (only-in racket/private/pre-base new-apply-proc) - #;racket/string) - scheme/promise scheme/system - racket/mpair - (only-in string-constants/private/only-once maybe-print-message) - (only-in mzscheme make-namespace) - (only-in racket/match/runtime match:error matchable? match-equality-test) - (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym]) - (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-ChannelTop make-VectorTop))) + (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym]) + (only-in (rep type-rep) make-HashtableTop make-MPairTop + make-BoxTop make-ChannelTop make-VectorTop + make-HeterogenousVector)) [raise (Univ . -> . (Un))] [raise-syntax-error (cl->* @@ -179,6 +186,7 @@ [assert (-poly (a b) (cl->* (Univ (make-pred-ty (list a) Univ b) . -> . b) (-> (Un a (-val #f)) a)))] +[defined? (->* (list Univ) -Boolean : (-FS (-not-filter -Undefined 0 null) (-filter -Undefined 0 null)))] [gensym (->opt [Sym] Sym)] [string-append (->* null -String -String)] [open-input-string (-> -String -Input-Port)] @@ -200,10 +208,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))] @@ -301,6 +317,9 @@ [thread-try-receive (-> Univ)] [thread-rewind-receive (-> (-lst Univ) -Void)] +[future (-poly (A) ((-> A) . -> . (-future A)))] +[touch (-poly (A) ((-future A) . -> . A))] + [reverse (-poly (a) (-> (-lst a) (-lst a)))] [append (-poly (a) (->* (list) (-lst a) (-lst a)))] [length (-poly (a) (-> (-lst a) -NonnegativeFixnum))] @@ -368,7 +387,7 @@ [string-copy (-> -String -String)] [string->immutable-string (-> -String -String)] [string->path (-> -String -Path)] -[file-exists? (-> -Pathlike B)] + [build-path ((list -Pathlike*) -Pathlike* . ->* . -Path)] [with-input-from-file @@ -472,7 +491,6 @@ [match:error ((list) Univ . ->* . (Un))] -[file-exists? (-Pathlike . -> . B)] [string->symbol (-String . -> . Sym)] [symbol->string (Sym . -> . -String)] [string->keyword (-String . -> . -Keyword)] @@ -516,17 +534,27 @@ [file-exists? (-> -Pathlike B)] [directory-list (cl-> [() (-lst -Path)] [(-Path) (-lst -Path)])] +[file-or-directory-modify-seconds + (cl->* (-Pathlike . -> . -Nat) + (-Pathlike (-val #f) . -> . -Nat) + (-Pathlike -Nat . -> . -Void) + (-Pathlike (-opt -Nat) (-> Univ) . -> . Univ))] + +[file-or-directory-permissions (-> -Pathlike (-lst (Un (-val 'read) (-val 'write) (-val 'execute))))] +[file-or-directory-identity (->opt -Pathlike (Univ) -Nat)] +[file-size (-> -Pathlike -Nat)] + [hash? (make-pred-ty (make-HashtableTop))] [hash-eq? (-> (make-HashtableTop) B)] [hash-eqv? (-> (make-HashtableTop) B)] [hash-weak? (-> (make-HashtableTop) B)] -[make-hash (-poly (a b) (-> (-HT a b)))] -[make-hasheq (-poly (a b) (-> (-HT a b)))] -[make-hasheqv (-poly (a b) (-> (-HT a b)))] -[make-weak-hash (-poly (a b) (-> (-HT a b)))] -[make-weak-hasheq (-poly (a b) (-> (-HT a b)))] -[make-weak-hasheqv (-poly (a b) (-> (-HT a b)))] +[make-hash (-poly (a b) (->opt [(-lst (-pair a b))] (-HT a b)))] +[make-hasheq (-poly (a b) (->opt [(-lst (-pair a b))] (-HT a b)))] +[make-hasheqv (-poly (a b) (->opt [(-lst (-pair a b))] (-HT a b)))] +[make-weak-hash (-poly (a b) (->opt [(-lst (-pair a b))] (-HT a b)))] +[make-weak-hasheq (-poly (a b) (->opt [(-lst (-pair a b))] (-HT a b)))] +[make-weak-hasheqv (-poly (a b) (->opt [(-lst (-pair a b))] (-HT a b)))] [make-immutable-hash (-poly (a b) (-> (-lst (-pair a b)) (-HT a b)))] [make-immutable-hasheq (-poly (a b) (-> (-lst (-pair a b)) (-HT a b)))] [make-immutable-hasheqv (-poly (a b) (-> (-lst (-pair a b)) (-HT a b)))] @@ -552,6 +580,10 @@ [hash-map (-poly (a b c) ((-HT a b) (a b . -> . c) . -> . (-lst c)))] [hash-for-each (-poly (a b c) (-> (-HT a b) (-> a b c) -Void))] [hash-count (-poly (a b) (-> (-HT a b) -NonnegativeFixnum))] +[hash-keys (-poly (a b) ((-HT a b) . -> . (-lst a)))] +[hash-values (-poly (a b) ((-HT a b) . -> . (-lst b)))] +[hash->list (-poly (a b) ((-HT a b) . -> . (-lst (-pair a b))))] + [hash-copy (-poly (a b) (-> (-HT a b) (-HT a b)))] [eq-hash-code (-poly (a) (-> a -Integer))] [eqv-hash-code (-poly (a) (-> a -Integer))] @@ -591,7 +623,8 @@ [flush-output (->opt [-Output-Port] -Void)] [file-stream-buffer-mode (cl-> [(-Port) (Un (-val 'none) (-val 'line) (-val 'block) (-val #f))] [(-Port (Un (-val 'none) (-val 'line) (-val 'block))) -Void])] -[file-position (-> -Port -Nat)] +[file-position (cl-> [(-Port) -Nat] + [(-Port -Integer) -Void])] [force (-poly (a) (-> (-Promise a) a))] [regexp-replace* @@ -625,6 +658,8 @@ [exit (-> (Un))] [collect-garbage (-> -Void)] +[current-memory-use (-> -Nat)] +[dump-memory-stats (-> Univ)] [module->namespace (-> (-mu x (-lst (Un -Symbol -String -Nat x (-val #f)))) -Namespace)] [current-namespace (-Param -Namespace -Namespace)] @@ -925,3 +960,71 @@ [mlength (-poly (a) (-> (-mlst a) -NonnegativeFixnum))] [mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))] [mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))] + +;; module names and loading +[resolved-module-path? (make-pred-ty -Resolved-Module-Path)] +[make-resolved-module-path (-> (Un -Symbol -Path) -Resolved-Module-Path)] +[resolved-module-path-name (-> -Resolved-Module-Path (Un -Path -Symbol))] +[module-path? (make-pred-ty -Module-Path)] +[current-module-name-resolver (-Param (cl->* (-Resolved-Module-Path . -> . Univ) + ((Un -Module-Path -Path) + (-opt -Resolved-Module-Path) + (-opt (-Syntax Univ)) + -Boolean + . -> . -Resolved-Module-Path)) + (cl->* (-Resolved-Module-Path . -> . Univ) + ((Un -Module-Path -Path) + (-opt -Resolved-Module-Path) + (-opt (-Syntax Univ)) + -Boolean + . -> . -Resolved-Module-Path)))] +[current-module-declare-name (-Param (-opt -Resolved-Module-Path) + (-opt -Resolved-Module-Path))] +[current-module-declare-source (-Param (-opt (Un -Symbol -Path)) + (-opt (Un -Symbol -Path)))] +[module-path-index? (make-pred-ty -Module-Path-Index)] +[module-path-index-resolve (-> -Module-Path-Index -Resolved-Module-Path)] +[module-path-index-split (-> -Module-Path-Index + (-values + (list (-opt -Module-Path) + (-opt (Un -Module-Path-Index + -Resolved-Module-Path)))))] +[module-path-index-join (-> (-opt -Module-Path) + (-opt (Un -Module-Path-Index -Resolved-Module-Path)) + -Module-Path-Index)] +[compiled-module-expression? (make-pred-ty -Compiled-Module-Expression)] +[module-compiled-name (-> -Compiled-Module-Expression -Symbol)] +[module-compiled-imports (-> -Compiled-Module-Expression + (-lst (-pair (-opt -Integer) + (-lst -Module-Path-Index))))] +[module-compiled-exports + (-> -Compiled-Module-Expression + (-values + (list + (-lst (-pair (-opt -Integer) + (-lst (-pair -Symbol + (-pair + (-lst + (Un -Module-Path-Index + (-pair -Module-Path-Index + (-pair (-opt -Integer) + (-pair -Symbol + (-pair (-opt -Integer) + (-val null))))))) + (-val null)))))) + (-lst (-pair (-opt -Integer) + (-lst (-pair -Symbol + (-pair + (-lst + (Un -Module-Path-Index + (-pair -Module-Path-Index + (-pair (-opt -Integer) + (-pair -Symbol + (-pair (-opt -Integer) + (-val null))))))) + (-val null)))))))))] +[module-compiled-language-info + (-> -Compiled-Module-Expression + (-opt (make-HeterogenousVector (list -Module-Path -Symbol Univ))))] + +[compose (-poly (a b c) (-> (-> b c) (-> a b) (-> a c)))] \ No newline at end of file diff --git a/collects/typed-scheme/private/base-special-env.rkt b/collects/typed-scheme/private/base-special-env.rkt index 02c33f62..2c9c5a7f 100644 --- a/collects/typed-scheme/private/base-special-env.rkt +++ b/collects/typed-scheme/private/base-special-env.rkt @@ -1,177 +1,70 @@ #lang racket/base -;; these are libraries providing functions we add types to that are not in scheme/base +;; this file cheats to define types for unexported variables that are expanded into by Racket macros (require - "extra-procs.rkt" "../utils/utils.rkt" - (only-in scheme/list cons? take drop add-between last filter-map) - (only-in rnrs/lists-6 fold-left) - '#%paramz - (only-in racket/match/runtime match:error) - scheme/promise - string-constants/string-constant - ;(prefix-in ce: test-engine/scheme-tests) - (for-syntax - scheme/base syntax/parse - (only-in unstable/syntax syntax-local-eval) - (utils tc-utils) - (env init-envs) - (except-in (rep filter-rep object-rep type-rep) make-arr) - (types convenience union) - (only-in (types convenience) [make-arr* make-arr]) - (typecheck tc-structs)) - (for-meta 2 scheme/base syntax/parse)) - - -(define-for-syntax (initialize-others) - - (define-syntax define-hierarchy - (syntax-rules (define-hierarchy) - [(_ parent ([name : type] ...) - (define-hierarchy child (spec ...) grand ...) - ...) - (begin - (d-s parent ([name : type] ...)) - (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...) - ...)])) - - (define-syntax define-sub-hierarchy - (syntax-rules (define-hierarchy) - [(_ [child parent] (inheritance ...) ([name : type] ...) - (define-hierarchy grandchild (spec ...) great ...) - ...) - (begin - (d-s [child parent] ([name : type] ...) (inheritance ...)) - (define-sub-hierarchy [grandchild child] - (inheritance ... type ...) (spec ...) - great - ...) - ...)])) - - (define-hierarchy srcloc - ([source : Univ] - [line : (*Un -Integer (-val #f))] - [column : (*Un -Integer (-val #f))] - [position : (*Un -Integer (-val #f))] - [span : (*Un -Integer (-val #f))])) - - (define-hierarchy date - ([second : -Number] - [minute : -Number] - [hour : -Number] - [day : -Number] - [month : -Number] - [year : -Number] - [weekday : -Number] - [year-day : -Number] - [dst? : -Boolean] - [time-zone-offset : -Number])) - - (define-hierarchy arity-at-least - ([value : -Nat])) - - (define-hierarchy exn - ([message : -String] [continuation-marks : -Cont-Mark-Set]) - - (define-hierarchy exn:break ([continuation : top-func])) - - (define-hierarchy exn:fail () - - (define-hierarchy exn:fail:contract () - (define-hierarchy exn:fail:contract:arity ()) - (define-hierarchy exn:fail:contract:divide-by-zero ()) - (define-hierarchy exn:fail:contract:non-fixnum-result ()) - (define-hierarchy exn:fail:contract:continuation ()) - (define-hierarchy exn:fail:contract:variable ())) - - (define-hierarchy exn:fail:syntax ([exprs : (-lst (-Syntax Univ))])) - - (define-hierarchy exn:fail:read - ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc - (define-hierarchy exn:fail:read:eof ()) - (define-hierarchy exn:fail:read:non-char ())) - - (define-hierarchy exn:fail:filesystem () - (define-hierarchy exn:fail:filesystem:exists ()) - (define-hierarchy exn:fail:filesystem:version ())) - - (define-hierarchy exn:fail:network ()) - - (define-hierarchy exn:fail:out-of-memory ()) - - (define-hierarchy exn:fail:unsupported ()) - - (define-hierarchy exn:fail:user ()))) - - ;; cce: adding exn:break would require a generic type for continuations - - ) - -(provide (for-syntax initial-env/special-case initialize-others initialize-type-env) - define-initial-env) + racket/promise + string-constants/string-constant + (for-syntax racket/base syntax/parse (only-in unstable/syntax syntax-local-eval) + (utils tc-utils) + (env init-envs) + (except-in (rep filter-rep object-rep type-rep) make-arr) + (types convenience union) + (only-in (types convenience) [make-arr* make-arr]))) (define-syntax (define-initial-env stx) - (syntax-case stx () - [(_ initial-env make-promise-ty language-ty qq-append-ty - [id-expr ty] ...) - (with-syntax ([(_ make-promise . _) - (local-expand #'(delay 3) - 'expression - null)] - [language - (local-expand #'(this-language) - 'expression - null)] - [(_ qq-append . _) - (local-expand #'`(,@'() 1) - 'expression - null)] - [(id ...) - (for/list ([expr (syntax->list #'(id-expr ...))]) - (syntax-local-eval expr))]) - #`(define-for-syntax initial-env + (syntax-parse stx + [(_ initialize-env [id-expr ty] ...) + (with-syntax ([(id ...) + (for/list ([expr (syntax->list #'(id-expr ...))]) + (syntax-local-eval expr))]) + #`(begin + (define-for-syntax initial-env (make-env - [make-promise make-promise-ty] - [language language-ty] - [qq-append qq-append-ty] - [id ty] ...)))])) + [id ty] ...)) + (define-for-syntax (initialize-env) + (initialize-type-env initial-env)) + (provide (for-syntax initialize-env))))])) - - -(define-initial-env initial-env/special-case +(define-initial-env initialize-special ;; make-promise - (-poly (a) (-> (-> a) (-Promise a))) + [(syntax-parse (local-expand #'(delay 3) 'expression null) + #:context #'make-promise + [(_ mp . _) #'mp]) + (-poly (a) (-> (-> a) (-Promise a)))] ;; language - -Symbol + [(syntax-parse (local-expand #'(this-language) 'expression null) + #:context #'language + [lang #'lang]) + -Symbol] ;; qq-append - (-poly (a b) + [(syntax-parse (local-expand #'`(,@'() 1) 'expression null) + #:context #'qq-append + [(_ qqa . _) #'qqa]) + (-poly (a b) (cl->* (-> (-lst a) (-val '()) (-lst a)) - (-> (-lst a) (-lst b) (-lst (*Un a b))))) + (-> (-lst a) (-lst b) (-lst (*Un a b)))))] ;; make-sequence [(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f) #:context #'make-sequence #:literals (let-values quote) [(let-values ([_ (m-s '(_) '())]) . _) #'m-s]) - (-poly (a) + (-poly (a b) (let ([seq-vals - (lambda ([a a]) + (lambda (a) (-values (list - (-> Univ a) + (-> Univ (-values a)) (-> Univ Univ) Univ (-> Univ Univ) - (-> a Univ) - (-> Univ a Univ))))]) - (-> Univ (-seq a) (seq-vals)) - #; - (cl->* (-> Univ (-lst a) (seq-vals)) - (-> Univ (-vec a) (seq-vals)) - (-> Univ -String (seq-vals -Char)) - (-> Univ -Bytes (seq-vals -Nat)) - (-> Univ -Input-Port (seq-vals -Nat)))))] + (->* a Univ) + (->* (cons Univ a) Univ))))]) + (cl->* + (-> Univ (-seq a) (seq-vals (list a))) + (-> Univ (-seq a b) (seq-vals (list a b))))))] ;; in-range [(syntax-parse (local-expand #'(in-range 1) 'expression #f) [(i-n _ ...) @@ -234,12 +127,3 @@ #'i-n]) (->opt [-Input-Port -Symbol] (-seq -Bytes))]) - - - -(begin-for-syntax - (initialize-type-env initial-env/special-case) - (initialize-others)) - - - diff --git a/collects/typed-scheme/private/base-structs.rkt b/collects/typed-scheme/private/base-structs.rkt new file mode 100644 index 00000000..2fe17fe9 --- /dev/null +++ b/collects/typed-scheme/private/base-structs.rkt @@ -0,0 +1,99 @@ +#lang racket/base + +(require + "../utils/utils.rkt" + (utils tc-utils) + (env init-envs) + (except-in (rep filter-rep object-rep type-rep) make-arr) + (types convenience union) + (only-in (types convenience) [make-arr* make-arr]) + (typecheck tc-structs)) + +(require (for-template racket/base)) + +(provide initialize-structs) + +(define-syntax define-hierarchy + (syntax-rules (define-hierarchy) + [(_ parent ([name : type] ...) + (define-hierarchy child (spec ...) grand ...) + ...) + (begin + (d-s parent ([name : type] ...)) + (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...) + ...)])) + +(define-syntax define-sub-hierarchy + (syntax-rules (define-hierarchy) + [(_ [child parent] (inheritance ...) ([name : type] ...) + (define-hierarchy grandchild (spec ...) great ...) + ...) + (begin + (d-s [child parent] ([name : type] ...) (inheritance ...)) + (define-sub-hierarchy [grandchild child] + (inheritance ... type ...) (spec ...) + great + ...) + ...)])) + + +(define (initialize-structs) + + + (define-hierarchy srcloc + ([source : Univ] + [line : (*Un -Integer (-val #f))] + [column : (*Un -Integer (-val #f))] + [position : (*Un -Integer (-val #f))] + [span : (*Un -Integer (-val #f))])) + + (define-hierarchy date + ([second : -Number] + [minute : -Number] + [hour : -Number] + [day : -Number] + [month : -Number] + [year : -Number] + [weekday : -Number] + [year-day : -Number] + [dst? : -Boolean] + [time-zone-offset : -Number])) + + (define-hierarchy arity-at-least + ([value : -Nat])) + + (define-hierarchy exn + ([message : -String] [continuation-marks : -Cont-Mark-Set]) + + (define-hierarchy exn:break ([continuation : top-func])) + + (define-hierarchy exn:fail () + + (define-hierarchy exn:fail:contract () + (define-hierarchy exn:fail:contract:arity ()) + (define-hierarchy exn:fail:contract:divide-by-zero ()) + (define-hierarchy exn:fail:contract:non-fixnum-result ()) + (define-hierarchy exn:fail:contract:continuation ()) + (define-hierarchy exn:fail:contract:variable ())) + + (define-hierarchy exn:fail:syntax ([exprs : (-lst (-Syntax Univ))])) + + (define-hierarchy exn:fail:read + ([srclocs : (-lst Univ)]) ;; cce: Univ here should be srcloc + (define-hierarchy exn:fail:read:eof ()) + (define-hierarchy exn:fail:read:non-char ())) + + (define-hierarchy exn:fail:filesystem () + (define-hierarchy exn:fail:filesystem:exists ()) + (define-hierarchy exn:fail:filesystem:version ())) + + (define-hierarchy exn:fail:network ()) + + (define-hierarchy exn:fail:out-of-memory ()) + + (define-hierarchy exn:fail:unsupported ()) + + (define-hierarchy exn:fail:user ()))) + + ;; cce: adding exn:break would require a generic type for continuations + (void)) diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index 5b51c829..8d3e658a 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -1,13 +1,16 @@ #lang s-exp "type-env-lang.rkt" [Complex -Number] -[Inexact-Complex -InexactComplex] +[Float-Complex -FloatComplex] ; for consistency with float vs inexact-real +[Inexact-Complex -FloatComplex] ; for backward compatiblity [Number -Number] [Integer -Integer] [Real -Real] [Exact-Rational -ExactRational] -[Float -Flonum] -[Nonnegative-Float -NonnegativeFlonum] +[Float -Flonum] ;; these 2 are the default, 64-bit floats, can be optimized +[Nonnegative-Float -NonnegativeFlonum] ;; associated test is: flonum? +[Inexact-Real -InexactReal] ;; any inexact real. could be 32- or 64-bit float + ;; associated test is: inexact-real? [Exact-Positive-Integer -ExactPositiveInteger] [Exact-Nonnegative-Integer -ExactNonnegativeInteger] [Positive-Fixnum -PositiveFixnum] @@ -17,6 +20,7 @@ [Zero (-val 0)] [Void -Void] +[Undefined -Undefined] ; initial value of letrec bindings [Boolean -Boolean] [Symbol -Symbol] [String -String] @@ -44,6 +48,10 @@ [Procedure top-func] [Keyword -Keyword] [Thread -Thread] +[Resolved-Module-Path -Resolved-Module-Path] +[Module-Path -Module-Path] +[Module-Path-Index -Module-Path-Index] +[Compiled-Module-Expression -Compiled-Module-Expression] [Listof -Listof] [Vectorof (-poly (a) (make-Vector a))] [FlVector -FlVector] @@ -58,6 +66,7 @@ [True (-val #t)] [Null (-val null)] [Nothing (Un)] +[Futureof (-poly (a) (-future a))] [Pairof (-poly (a b) (-pair a b))] [MPairof (-poly (a b) (-mpair a b))] [MListof (-poly (a) (-mlst a))] diff --git a/collects/typed-scheme/private/colon.rkt b/collects/typed-scheme/private/colon.rkt index fb84c179..58152646 100644 --- a/collects/typed-scheme/private/colon.rkt +++ b/collects/typed-scheme/private/colon.rkt @@ -12,11 +12,11 @@ (define-syntax-class arr (pattern x:id #:fail-unless (eq? (syntax-e #'x) '->) #f - #:fail-unless (printf "id: ~a ~a~n" + #:fail-unless (printf "id: ~a ~a\n" (identifier-binding #'All-kw) (identifier-transformer-binding #'All-kw)) #f - #:fail-unless (printf "kw: ~a ~a~n" + #:fail-unless (printf "kw: ~a ~a\n" (identifier-binding #'t:All) (identifier-transformer-binding #'t:All)) #f diff --git a/collects/typed-scheme/private/env-lang.rkt b/collects/typed-scheme/private/env-lang.rkt index 1f306b17..eb5ff44b 100644 --- a/collects/typed-scheme/private/env-lang.rkt +++ b/collects/typed-scheme/private/env-lang.rkt @@ -2,14 +2,14 @@ (require (rename-in "../utils/utils.rkt" [infer r:infer])) -(require (for-syntax (utils tc-utils) - (env init-envs) - scheme/base syntax/parse - (r:infer infer) - (only-in (r:infer infer-dummy) infer-param) - (except-in (rep object-rep filter-rep type-rep) make-arr) - (types convenience union) - (only-in (types convenience) [make-arr* make-arr]))) +(require (for-syntax scheme/base syntax/parse) + (utils tc-utils) + (env init-envs) + (r:infer infer) + (only-in (r:infer infer-dummy) infer-param) + (except-in (rep object-rep filter-rep type-rep) make-arr) + (types convenience union) + (only-in (types convenience) [make-arr* make-arr])) (define-syntax (-#%module-begin stx) (define-syntax-class clause @@ -21,18 +21,17 @@ #'(#%plain-module-begin (begin extra - (define-for-syntax e + (define e (parameterize ([infer-param infer]) (make-env [id ty] ...))) - (begin-for-syntax - (initialize-type-env e))))] + (define (init) + (initialize-type-env e)) + (provide init)))] [(mb . rest) #'(mb (begin) . rest)])) (provide (rename-out [-#%module-begin #%module-begin]) require (except-out (all-from-out scheme/base) #%module-begin) - types rep private utils - (for-syntax - (types-out convenience union) - (all-from-out scheme/base))) + types rep private utils + (types-out convenience union)) diff --git a/collects/typed-scheme/private/extra-procs.rkt b/collects/typed-scheme/private/extra-procs.rkt index b4a74b03..5b90512b 100644 --- a/collects/typed-scheme/private/extra-procs.rkt +++ b/collects/typed-scheme/private/extra-procs.rkt @@ -1,5 +1,5 @@ #lang scheme/base -(provide assert) +(provide assert defined?) (define-syntax assert (syntax-rules () @@ -8,3 +8,6 @@ ((assert v pred) (let ((val v)) (if (pred val) val (error "Assertion failed")))))) + +(define (defined? v) + (not (equal? v (letrec ([x x]) x)))) \ No newline at end of file diff --git a/collects/typed-scheme/private/for-clauses.rkt b/collects/typed-scheme/private/for-clauses.rkt index 3d9bea9b..3d146868 100644 --- a/collects/typed-scheme/private/for-clauses.rkt +++ b/collects/typed-scheme/private/for-clauses.rkt @@ -9,13 +9,13 @@ (define-splicing-syntax-class for-clause ;; single-valued seq-expr - (pattern (~and c (var:annotated-name seq-expr:expr)) + (pattern (~and c (var:optionally-annotated-name seq-expr:expr)) #:with (expand ...) (list (syntax/loc #'c (var.ann-name seq-expr)))) ;; multi-valued seq-expr ;; currently disabled because it triggers an internal error in the typechecker - #;(pattern (~and c (((v:annotated-name) ...) seq-expr:expr)) + #;(pattern (~and c (((v:optionally-annotated-name) ...) seq-expr:expr)) #:with (expand ...) (list (syntax/loc #'c ((v.ann-name ...) seq-expr)))) @@ -26,14 +26,14 @@ ;; intersperses "#:when #t" clauses to emulate the for* variants' semantics (define-splicing-syntax-class for*-clause ;; single-valued seq-expr - (pattern (~and c (var:annotated-name seq-expr:expr)) + (pattern (~and c (var:optionally-annotated-name seq-expr:expr)) #:with (expand ...) (list (syntax/loc #'c (var.ann-name seq-expr)) #'#:when #'#t)) ;; multi-valued seq-expr ;; currently disabled because it triggers an internal error in the typechecker - #;(pattern (~and c (((v:annotated-name) ...) seq-expr:expr)) + #;(pattern (~and c (((v:optionally-annotated-name) ...) seq-expr:expr)) #:with (expand ...) (list (quasisyntax/loc #'c ((v.ann-name ...) seq-expr)) diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index 23285bcd..6e59d204 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -2,12 +2,12 @@ (require "../utils/utils.rkt" (except-in (rep type-rep) make-arr) - (rename-in (types convenience union utils) [make-arr* make-arr]) + (rename-in (types convenience union utils printer filter-ops) [make-arr* make-arr]) (utils tc-utils stxclass-util) syntax/stx (prefix-in c: scheme/contract) syntax/parse (env type-env-structs tvar-env type-name-env type-alias-env lexical-env index-env) - scheme/match unstable/debug + racket/match unstable/debug (for-template scheme/base "colon.ss") ;; needed at this phase for tests (combine-in (prefix-in t: "base-types-extra.ss") "colon.ss") @@ -22,9 +22,10 @@ (provide star ddd/bound) (define enable-mu-parsing (make-parameter #t)) +(print-complex-filters? #t) (define ((parse/id p) loc datum) - #;(printf "parse-type/id id : ~a~n ty: ~a~n" (syntax-object->datum loc) (syntax-object->datum stx)) + #;(printf "parse-type/id id : ~a\n ty: ~a\n" (syntax-object->datum loc) (syntax-object->datum stx)) (let* ([stx* (datum->syntax loc datum loc loc)]) (p stx*))) @@ -65,7 +66,7 @@ (parse-type s)])) (define (parse-all-type stx parse-type) - ;(printf "parse-all-type: ~a ~n" (syntax->datum stx)) + ;(printf "parse-all-type: ~a \n" (syntax->datum stx)) (syntax-parse stx #:literals (t:All) [((~and kw t:All) (vars:id ... v:id dd:ddd) . t) (let* ([vars (map syntax-e (syntax->list #'(vars ...)))] @@ -88,6 +89,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) @@ -96,7 +104,7 @@ (pattern cdr #:attr pe (make-CdrPE))) -(define-splicing-syntax-class latent-filter +(define-splicing-syntax-class simple-latent-filter #:description "latent filter" (pattern (~seq t:expr (~describe "@" (~datum @)) pe:path-elem ...) #:attr type (parse-type #'t) @@ -105,6 +113,41 @@ #:attr type (parse-type #'t) #:attr path '())) +(define-syntax-class prop + #:attributes (prop) + (pattern (~literal Top) #:attr prop -top) + (pattern (~literal Bot) #:attr prop -bot) + (pattern (t:expr (~describe "@" (~datum @)) pe:path-elem ... i:nat) + #:attr prop (-filter (parse-type #'t) (syntax-e #'i) (attribute pe.pe))) + (pattern ((~datum !) t:expr (~describe "@" (~datum @)) pe:path-elem ... i:nat) + #:attr prop (-not-filter (parse-type #'t) (syntax-e #'i) (attribute pe.pe))) + (pattern ((~literal and) p:prop ...) + #:attr prop (apply -and (attribute p.prop))) + (pattern ((~literal or) p:prop ...) + #:attr prop (apply -or (attribute p.prop))) + (pattern ((~literal implies) p1:prop p2:prop) + #:attr prop (-imp (attribute p1.prop) (attribute p2.prop)))) + +(define-syntax-class object + #:attributes (object) + (pattern e:expr + #:attr object -no-obj)) + +(define-splicing-syntax-class full-latent + #:description "latent propositions and object" + (pattern (~seq (~optional (~seq #:+ p+:prop ...)) + (~optional (~seq #:- p-:prop ...)) + (~optional (~seq #:object o:object))) + #:attr positive (if (attribute p+.prop) + (apply -and (attribute p+.prop)) + -top) + #:attr negative (if (attribute p-.prop) + (apply -and (attribute p-.prop)) + -top) + #:attr object (if (attribute o.object) + (attribute o.object) + -no-obj))) + (define (parse-type stx) (parameterize ([current-orig-stx stx]) (syntax-parse @@ -203,18 +246,29 @@ [((~and kw t:Parameter) t1 t2) (add-type-name-reference #'kw) (-Param (parse-type #'t1) (parse-type #'t2))] - ;; function types - ;; handle this error first: - [((~or dom (~between (~and kw t:->) 2 +inf.0)) ...) - (for ([k (syntax->list #'(kw ...))]) (add-type-name-reference k)) - (tc-error/stx (syntax->list #'(kw ...)) - "The -> type constructor may be used only once in a form") - Err] - [(dom (~and kw t:->) rng : ~! latent:latent-filter) + ;; curried function notation + [((~and dom:non-keyword-ty (~not t:->)) ... + (~and kw t:->) + (~and (~seq rest-dom ...) (~seq (~or _ (~between t:-> 1 +inf.0)) ...))) + (add-type-name-reference #'kw) + (let ([doms (for/list ([d (syntax->list #'(dom ...))]) + (parse-type d))]) + (make-Function + (list (make-arr + doms + (parse-type (syntax/loc stx (rest-dom ...)))))))] + [(dom ... (~and kw t:->) rng : latent:full-latent) + (add-type-name-reference #'kw) + ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty + (->* (map parse-type (syntax->list #'(dom ...))) + (parse-type #'rng) + : (-FS (attribute latent.positive) (attribute latent.negative)) + : (attribute latent.object))] + [(dom (~and kw t:->) rng : ~! latent:simple-latent-filter) (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 +276,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 +290,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 +305,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))]) @@ -275,13 +329,13 @@ [(lookup-type-alias #'id parse-type (lambda () #f)) => (lambda (t) - ;(printf "found a type alias ~a~n" #'id) + ;(printf "found a type alias ~a\n" #'id) (add-type-name-reference #'id) t)] ;; if it's a type name, we just use the name [(lookup-type-name #'id (lambda () #f)) (add-type-name-reference #'id) - ;(printf "found a type name ~a~n" #'id) + ;(printf "found a type name ~a\n" #'id) (make-Name #'id)] [(free-identifier=? #'id #'t:->) (tc-error/delayed "Incorrect use of -> type constructor") @@ -311,7 +365,8 @@ [(Name: n) (when (and (current-poly-struct) (free-identifier=? n (poly-name (current-poly-struct))) - (not (andmap type-equal? args (poly-vars (current-poly-struct))))) + (not (or (ormap Error? args) + (andmap type-equal? args (poly-vars (current-poly-struct)))))) (tc-error "Structure type constructor ~a applied to non-regular arguments ~a" rator args)) (make-App rator args stx)] [(Poly: ns _) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index cef82b22..46475ac2 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -1,8 +1,8 @@ -#lang scheme/base +#lang racket/base #| -This file defines two sorts of primitives. All of them are provided into any module using the typed scheme language. +This file defines two sorts of primitives. All of them are provided into any module using the typed racket language. 1. macros for defining type annotated code. this includes: lambda:, define:, etc @@ -23,35 +23,33 @@ This file defines two sorts of primitives. All of them are provided into any mod : (rename-out [define-typed-struct define-struct:] [lambda: λ:] - [define-typed-struct/exec define-struct/exec:])) + [define-typed-struct/exec define-struct/exec:] + [for/annotation for] + [for*/annotation for*])) -(require "../utils/utils.rkt" - racket/base - (for-syntax +(require "../utils/require-contract.rkt" + "colon.rkt" + "../typecheck/internal-forms.rkt" + (rename-in racket/contract [-> c->]) + "base-types.rkt" + "base-types-extra.rkt" + racket/flonum ; for for/flvector and for*/flvector + mzlib/etc + (for-syntax syntax/parse syntax/private/util - scheme/base - (rep type-rep) - mzlib/match - "parse-type.rkt" "annotate-classes.rkt" + racket/base + racket/struct-info syntax/struct - syntax/stx - scheme/struct-info - (private internal) - (except-in (utils utils tc-utils)) - (env type-name-env) + "../rep/type-rep.rkt" + "parse-type.rkt" + "annotate-classes.rkt" + "internal.rkt" + "../utils/tc-utils.rkt" + "../env/type-name-env.rkt" "type-contract.rkt" "for-clauses.rkt")) -(require (utils require-contract) - "colon.rkt" - (typecheck internal-forms) - (except-in mzlib/contract ->) - (only-in mzlib/contract [-> c->]) - mzlib/struct - "base-types.rkt" - "base-types-extra.rkt") - (define-for-syntax (ignore stx) (syntax-property stx 'typechecker:ignore #t)) @@ -86,9 +84,13 @@ This file defines two sorts of primitives. All of them are provided into any mod (raise-syntax-error #f "at least one specification is required" stx)) #'(begin (require/opaque-type oc.ty oc.pred lib . oc.opt) ... - (require/typed sc.nm sc.ty lib) ... + (require/typed #:internal sc.nm sc.ty lib) ... (require-typed-struct strc.nm (strc.body ...) lib) ...)] [(_ nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) + #`(require/typed #:internal nm ty lib #,@(if (attribute parent) + #'(#:struct-maker parent) + #'()))] + [(_ #:internal nm:opt-rename ty lib (~optional [~seq #:struct-maker parent]) ...) (with-syntax ([cnt* (generate-temporary #'nm.nm)] [sm (if (attribute parent) #'(#:struct-maker parent) @@ -173,6 +175,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,11 +234,16 @@ 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) (syntax-parse stx - [(_ (bs:annotated-binding ...) . body) + [(_ (bs:optionally-annotated-binding ...) . body) (quasisyntax/loc stx (#,form (bs.binding ...) . body))])))]) (values (mk #'let) (mk #'let*) (mk #'letrec)))) @@ -235,7 +251,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (let ([mk (lambda (form) (lambda (stx) (syntax-parse stx - [(_ (bs:annotated-values-binding ...) . body) + [(_ (bs:optionally-annotated-values-binding ...) . body) (quasisyntax/loc stx (#,form (bs.binding ...) . body))])))]) (values (mk #'let-values) (mk #'let*-values) (mk #'letrec-values)))) @@ -257,11 +273,11 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (define-typed-struct/exec stx) (syntax-parse stx #:literals (:) - [(_ nm ((~describe "field specification" [fld:annotated-name]) ...) [proc : proc-ty]) + [(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty]) (with-syntax* ([proc* (syntax-property #'(ann proc : proc-ty) 'typechecker:with-type #t)] - [d-s (syntax-property (syntax/loc stx (define-struct/properties nm (fld.name ...) - ([prop:procedure proc*]))) + [d-s (syntax-property (syntax/loc stx (define-struct nm (fld.name ...) + #:property prop:procedure proc*)) 'typechecker:ignore-some #t)] [dtsi (internal (syntax/loc stx (define-typed-struct/exec-internal nm (fld ...) proc-ty)))]) #'(begin d-s dtsi))])) @@ -330,10 +346,11 @@ This file defines two sorts of primitives. All of them are provided into any mod [dtsi (quasisyntax/loc stx (dtsi* () nm (fs ...) #,@mutable))]) #'(begin d-s dtsi)))] [(_ (vars:id ...) nm:struct-name (fs:fld-spec ...) . opts) - (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) - 'typechecker:ignore #t)] - [dtsi (syntax/loc stx (dtsi* (vars ...) nm (fs ...)))]) - #'(begin d-s dtsi))])) + (let ([mutable (mutable? #'opts)]) + (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) + 'typechecker:ignore #t)] + [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm (fs ...) #,@mutable))]) + #'(begin d-s dtsi)))])) (lambda (stx) (syntax-parse stx [(_ nm:struct-name/new (fs:fld-spec ...) . opts) @@ -347,13 +364,14 @@ This file defines two sorts of primitives. All of them are provided into any mod [dtsi (quasisyntax/loc stx (dtsi* () nm.old-spec (fs ...) #:maker #,cname #,@mutable))]) #'(begin d-s dtsi)))] [(_ (vars:id ...) nm:struct-name/new (fs:fld-spec ...) . opts) - (let ([cname (datum->syntax #f (syntax-e #'nm.name))]) + (let ([cname (datum->syntax #f (syntax-e #'nm.name))] + [mutable (mutable? #'opts)]) (with-syntax ([d-s (syntax-property (quasisyntax/loc stx (struct #,@(attribute nm.new-spec) (fs.fld ...) #:extra-constructor-name #,cname . opts)) 'typechecker:ignore #t)] - [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname))]) + [dtsi (quasisyntax/loc stx (dtsi* (vars ...) nm.old-spec (fs ...) #:maker #,cname #,@mutable))]) #'(begin d-s dtsi)))]))))) (define-syntax (require-typed-struct stx) @@ -402,7 +420,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (do: stx) (syntax-parse stx #:literals (:) [(_ : ty - ((var:annotated-name rest ...) ...) + ((var:optionally-annotated-name rest ...) ...) (stop?:expr ret ...) c:expr ...) (syntax/loc @@ -412,6 +430,18 @@ This file defines two sorts of primitives. All of them are provided into any mod c ...) ty))])) +;; wrap the original for with a type annotation +(define-syntax (for/annotation stx) + (syntax-parse stx + [(_ x ...) + (syntax/loc stx + (ann (for x ...) Void))])) +(define-syntax (for*/annotation stx) + (syntax-parse stx + [(_ x ...) + (syntax/loc stx + (ann (for* x ...) Void))])) + ;; we need handle #:when clauses manually because we need to annotate ;; the type of each nested for (define-syntax (for: stx) @@ -427,16 +457,16 @@ This file defines two sorts of primitives. All of them are provided into any mod ;; single-valued seq-expr ;; unlike the definitions in for-clauses.rkt, this does not include ;; #:when clauses, which are handled separately here - (pattern (var:annotated-name seq-expr:expr) + (pattern (var:optionally-annotated-name seq-expr:expr) #:with expand #'(var.ann-name seq-expr)) ;; multi-valued seq-expr ;; currently disabled because it triggers an internal error in the typechecker - #;(pattern ((v:annotated-name ...) seq-expr:expr) + #;(pattern ((v:optionally-annotated-name ...) seq-expr:expr) #:with expand #'((v.ann-name ...) seq-expr))) (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 ...)))) @@ -444,18 +474,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 ...))))])))])) @@ -487,8 +517,8 @@ This file defines two sorts of primitives. All of them are provided into any mod (quasisyntax/loc stx (begin (define-syntax name (define-for-variant #'untyped-name)) ...))])) -;; for/hash{,eq,eqv}:, for/and:, for/first: and for/last:'s expansions -;; can't currently be handled by the typechecker. +;; for/hash{,eq,eqv}:, for/vector:, for/flvector:, for/and:, for/first: and +;; for/last:'s expansions can't currently be handled by the typechecker. ;; They have been left out of the documentation. (define-for-variants (for/list: for/list) @@ -498,14 +528,16 @@ This file defines two sorts of primitives. All of them are provided into any mod (for/and: for/and) (for/or: for/or) (for/first: for/first) - (for/last: for/last)) + (for/last: for/last) + (for/vector: for/vector) + (for/flvector: for/flvector)) ;; Unlike with the above, the inferencer can handle any number of #:when ;; clauses with these 2. (define-syntax (for/lists: stx) (syntax-parse stx #:literals (:) [(_ : ty - ((var:annotated-name) ...) + ((var:optionally-annotated-name) ...) (clause:for-clause ...) c:expr ...) (syntax-property @@ -518,7 +550,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (for/fold: stx) (syntax-parse stx #:literals (:) [(_ : ty - ((var:annotated-name init:expr) ...) + ((var:optionally-annotated-name init:expr) ...) (clause:for-clause ...) c:expr ...) (syntax-property @@ -571,7 +603,9 @@ This file defines two sorts of primitives. All of them are provided into any mod (for*/and: for*/and) (for*/or: for*/or) (for*/first: for*/first) - (for*/last: for*/last)) + (for*/last: for*/last) + (for*/vector: for*/vector) + (for*/flvector: for*/flvector)) (define-for-syntax (define-for*-folding-variant name) (lambda (stx) @@ -609,3 +643,22 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ (~var k (param-annotated-name (lambda (s) #`(#,s -> (U))))) . body) (quasisyntax/loc stx (#,l/c k.ann-name . body))])) (values (mk #'let/cc) (mk #'let/ec)))) + +(define-syntax (with-asserts stx) + (define-syntax-class with-asserts-clause + [pattern [x:id] + #:with cond-clause + (syntax/loc #'x + [(not x) + (error "Assertion failed")])] + [pattern [x:id pred] + #:with cond-clause + (syntax/loc #'x + [(not (pred x)) + (error "Assertion failed")])]) + (syntax-parse stx + [(_ (c:with-asserts-clause ...) body:expr ...+) + (syntax/loc stx + (cond c.cond-clause + ... + [else body ...]))])) diff --git a/collects/typed-scheme/private/type-annotation.rkt b/collects/typed-scheme/private/type-annotation.rkt index 75c4db9a..6889c650 100644 --- a/collects/typed-scheme/private/type-annotation.rkt +++ b/collects/typed-scheme/private/type-annotation.rkt @@ -7,7 +7,7 @@ (except-in (types subtype union convenience resolve utils) -> ->*) (private parse-type) (only-in scheme/contract listof ->) - scheme/match mzlib/trace) + racket/match mzlib/trace) (provide type-annotation get-type get-types @@ -27,10 +27,10 @@ (define (print-size stx) (syntax-case stx () [(a . b) (begin - (printf/log "Annotation Sexp Pair ~n") + (printf/log "Annotation Sexp Pair \n") (print-size #'a) (print-size #'b))] - [_ (printf/log "Annotation Sexp ~n" )])) + [_ (printf/log "Annotation Sexp \n")])) ;; get the type annotation of this syntax ;; syntax -> Maybe[Type] @@ -46,7 +46,7 @@ (parse-type prop) (parse-type/id stx prop))) ;(unless let-binding (error 'ohno)) - ;(printf "in type-annotation:~a~n" (syntax->datum stx)) + ;(printf "in type-annotation:~a\n" (syntax->datum stx)) (cond [(syntax-property stx type-label-symbol) => pt] [(syntax-property stx type-ascrip-symbol) => pt] @@ -62,7 +62,6 @@ (define (type-ascription stx) (define (pt prop) - #;(print-size prop) (if (syntax? prop) (parse-tc-results prop) (parse-tc-results/id stx prop))) @@ -72,7 +71,7 @@ (lambda (prop) (if (pair? prop) (pt (car prop)) - (pt prop)))] + (pt prop)))] [else #f])) (define (remove-ascription stx) @@ -87,11 +86,11 @@ [else #f]))) (define (log/ann stx ty) - (printf/log "Required Annotated Variable: ~a ~a~n" (syntax-e stx) ty)) + (printf/log "Required Annotated Variable: ~a ~a\n" (syntax-e stx) ty)) (define (log/extra stx ty ty2) - (printf/log "Extra Annotated Variable: ~a ~a ~a~n" (syntax-e stx) ty ty2)) + (printf/log "Extra Annotated Variable: ~a ~a ~a\n" (syntax-e stx) ty ty2)) (define (log/noann stx ty) - (printf/log "Unannotated Variable: ~a ~a~n" (syntax-e stx) ty)) + (printf/log "Unannotated Variable: ~a ~a\n" (syntax-e stx) ty)) ;; get the type annotation of this identifier, otherwise error ;; if #:default is provided, return that instead of error @@ -146,7 +145,7 @@ (parameterize ([current-orig-stx stx]) (unless (subtype e-type ty) ;(printf "orig-stx: ~a" (syntax->datum stx*)) - (tc-error "Body had type:~n~a~nVariable had type:~n~a~n" e-type ty)))) + (tc-error "Body had type:\n~a\nVariable had type:\n~a\n" e-type ty)))) (define (dotted? stx) (cond [(syntax-property stx type-dotted-symbol) => syntax-e] diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt index 4d8d6bf8..e8eacaf4 100644 --- a/collects/typed-scheme/private/type-contract.rkt +++ b/collects/typed-scheme/private/type-contract.rkt @@ -12,7 +12,7 @@ (types resolve utils) (prefix-in t: (types convenience)) (private parse-type) - scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list + racket/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c) (for-template scheme/base scheme/contract unstable/poly-c (utils any-wrap) (only-in scheme/class object% is-a?/c subclass?/c object-contract class/c init object/c class?))) @@ -55,9 +55,11 @@ (define (type->contract ty fail #:out [out? #f] #:typed-side [from-typed? #t] #:flat [flat? #f]) (define vars (make-parameter '())) (let/ec exit - (let loop ([ty ty] [pos? #t] [from-typed? from-typed?] [structs-seen null]) - (define (t->c t #:seen [structs-seen structs-seen]) (loop t pos? from-typed? structs-seen)) - (define (t->c/neg t #:seen [structs-seen structs-seen]) (loop t (not pos?) (not from-typed?) structs-seen)) + (let loop ([ty ty] [pos? #t] [from-typed? from-typed?] [structs-seen null] [flat? flat?]) + (define (t->c t #:seen [structs-seen structs-seen] #:flat [flat? flat?]) + (loop t pos? from-typed? structs-seen flat?)) + (define (t->c/neg t #:seen [structs-seen structs-seen] #:flat [flat? flat?]) + (loop t (not pos?) (not from-typed?) structs-seen flat?)) (define (t->c/fun f #:method [method? #f]) (match f [(Function: (list (top-arr:))) #'procedure?] @@ -115,7 +117,9 @@ [(Univ:) (if from-typed? #'any-wrap/c #'any/c)] ;; we special-case lists: [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) - #`(listof #,(t->c elem-ty))] + (if (and (not from-typed?) (type-equal? elem-ty t:Univ)) + #'list? + #`(listof #,(t->c elem-ty)))] [(? (lambda (e) (eq? t:Any-Syntax e))) #'syntax?] [(Base: sym cnt) #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt))] [(Refinement: par p? cert) @@ -128,27 +132,35 @@ #'(or/c . cnts)))] [(and t (Function: _)) (t->c/fun t)] [(Vector: t) - #`(vectorof #,(t->c t))] + (if flat? + #`(vectorof #,(t->c t #:flat #t) #:flat? #t) + #`(vectorof #,(t->c t)))] [(Box: t) - #`(box/c #,(t->c t))] + (if flat? + #`(box/c #,(t->c t #:flat #t) #:flat? #t) + #`(box/c #,(t->c t)))] [(Pair: t1 t2) #`(cons/c #,(t->c t1) #,(t->c t2))] [(Opaque: p? cert) #`(flat-named-contract (quote #,(syntax-e p?)) #,(cert p?))] [(F: v) (cond [(assoc v (vars)) => second] [else (int-err "unknown var: ~a" v)])] - [(Poly: vs (and b (Function: _))) - (when flat? (exit (fail))) - (match-let ([(Poly-names: vs-nm _) ty]) - (with-syntax ([(v ...) (generate-temporaries vs-nm)]) - (parameterize ([vars (append (map list vs (syntax->list #'(v ...))) - (vars))]) - #`(parametric/c (v ...) #,(t->c b)))))] + [(Poly: vs b) + (if from-typed? + ;; in positive position, no checking needed for the variables + (parameterize ([vars (append (for/list ([v vs]) (list v #'any/c)))]) + (t->c b)) + ;; in negative position, use `parameteric/c' + (match-let ([(Poly-names: vs-nm _) ty]) + (with-syntax ([(v ...) (generate-temporaries vs-nm)]) + (parameterize ([vars (append (map list vs (syntax->list #'(v ...))) + (vars))]) + #`(parametric/c (v ...) #,(t->c b))))))] [(Mu: n b) (match-let ([(Mu-name: n-nm _) ty]) (with-syntax ([(n*) (generate-temporaries (list n-nm))]) (parameterize ([vars (cons (list n #'n* #'n*) (vars))]) - #`(flat-rec-contract n* #,(t->c b)))))] + #`(flat-rec-contract n* #,(t->c b #:flat #t)))))] [(Value: #f) #'false/c] [(Instance: (Class: _ _ (list (list name fcn) ...))) (when flat? (exit (fail))) @@ -162,7 +174,6 @@ [(name ...) name] [(by-name-cnt ...) (for/list ([t by-name-init-ty]) (t->c/neg t))] [(by-name-init ...) by-name-init]) - #;#'class? #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))] [(Value: '()) #'null?] [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? cert maker-id) @@ -177,26 +188,32 @@ [cnt-name nm] [(fld-cnts ...) (for/list ([fty flds] - [f-acc acc-ids]) - #`(((contract-projection - #,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen))) - blame) - (#,f-acc val)))]) - #`(letrec ([rec - (make-contract - #:name 'cnt-name - #:first-order #,pred? - #:projection - (lambda (blame) - (lambda (val) - (maker fld-cnts ...))))]) - rec))] + [f-acc acc-ids] + [m? mut?]) + #`(((contract-projection + #,(t->c fty #:seen (cons (cons ty #'(recursive-contract rec)) structs-seen))) + blame) + (#,f-acc val)))]) + #`(letrec ([rec + (make-contract + #:name 'cnt-name + #:first-order #,pred? + #:projection + (lambda (blame) + (lambda (val) + (unless (#,pred? val) + (raise-blame-error blame val "expected ~a value, got ~v" 'cnt-name val)) + (maker fld-cnts ...))))]) + rec))] [else #`(flat-named-contract '#,(syntax-e pred?) #,(cert pred?))])] [(Syntax: (Base: 'Symbol _)) #'identifier?] [(Syntax: t) #`(syntax/c #,(t->c t))] [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))] [(Param: in out) #`(parameter/c #,(t->c out))] - [(Hashtable: k v) #`(hash/c #,(t->c k) #,(t->c v) #:immutable 'dont-care)] + [(Hashtable: k v) + (if flat? + #`(hash/c #,(t->c k #:flat #t) #,(t->c v #:flat #t) #:flat? #t #:immutable 'dont-care) + #`(hash/c #,(t->c k) #,(t->c v) #:immutable 'dont-care))] [else (exit (fail))])))) diff --git a/collects/typed-scheme/private/type-env-lang.rkt b/collects/typed-scheme/private/type-env-lang.rkt index 3892a583..dd017394 100644 --- a/collects/typed-scheme/private/type-env-lang.rkt +++ b/collects/typed-scheme/private/type-env-lang.rkt @@ -21,7 +21,7 @@ ;(define-syntax provider (lambda (stx) #'(begin (provide nm) ...))) ;(provide provider) (begin-for-syntax - ;(printf "running base-types~n") + ;(printf "running base-types\n") (initialize-type-name-env (list (list #'nm ty) ...))))))] [(mb . rest) diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-scheme/private/with-types.rkt index 601bdb38..2733010b 100644 --- a/collects/typed-scheme/private/with-types.rkt +++ b/collects/typed-scheme/private/with-types.rkt @@ -1,11 +1,13 @@ #lang racket/base -(require racket/require racket/contract/regions racket/contract/base - "base-env.rkt" "base-special-env.rkt" "base-env-numeric.rkt" - "base-env-indexing.rkt" "extra-procs.rkt" "prims.rkt" - (for-syntax - scheme/base syntax/parse racket/block racket/match - unstable/sequence unstable/debug "base-types-extra.rkt" +(require racket/require + (for-template + (except-in racket/base for for*) + "prims.rkt" + (prefix-in c: (combine-in racket/contract/regions racket/contract/base))) + "extra-procs.rkt" "prims.rkt" + syntax/parse racket/block racket/match + unstable/sequence unstable/debug "base-types-extra.rkt" (except-in (path-up "env/type-name-env.rkt" "env/type-alias-env.rkt" "infer/infer-dummy.rkt" @@ -21,98 +23,97 @@ "types/convenience.rkt" "types/abbrev.rkt") ->) - (except-in (path-up "utils/utils.rkt") infer))) + (except-in (path-up "utils/utils.rkt") infer)) -(provide with-type) +(provide wt-core) -(define-for-syntax (with-type-helper stx body fvids fvtys exids extys resty expr? ctx) - (block - (define old-context (unbox typed-context?)) - (define ((no-contract t [stx stx])) - (tc-error/stx stx "Type ~a could not be converted to a contract." t)) - (set-box! typed-context? #t) - (define fv-types (for/list ([t (in-list (syntax->list fvtys))]) - (parse-type t))) - (define fv-cnts (for/list ([t (in-list fv-types)] - [stx (in-list (syntax->list fvtys))]) - (type->contract t #:typed-side #f (no-contract t)))) - (define ex-types (for/list ([t (syntax->list extys)]) - (parse-type t))) - (define ex-cnts (for/list ([t (in-list ex-types)] - [stx (in-list (syntax->list extys))]) - (type->contract t #:typed-side #t (no-contract t)))) - (define region-tc-result - (and expr? (parse-tc-results resty))) - (define region-cnts - (if region-tc-result - (match region-tc-result - [(tc-result1: t) - (list (type->contract t #:typed-side #t (no-contract t #'region-ty-stx)))] - [(tc-results: ts) - (for/list ([t (in-list ts)]) - (type->contract - t #:typed-side #t - (no-contract t #'region-ty-stx)))]) - null)) - (for ([i (in-list (syntax->list fvids))] - [ty (in-list fv-types)]) - (register-type i ty)) - (define expanded-body - (if expr? - (with-syntax ([body body]) - (local-expand #'(let () . body) ctx null)) - (with-syntax ([(body ...) body] - [(id ...) exids] - [(ty ...) extys]) - (local-expand #'(let () (begin (: id ty) ... body ... (values id ...))) ctx null)))) - (parameterize (;; disable fancy printing? - [custom-printer #t] - ;; a cheat to avoid units - [infer-param infer] - ;; do we report multiple errors - [delay-errors? #t] - ;; this parameter is just for printing types - ;; this is a parameter to avoid dependency issues - [current-type-names - (lambda () - (append - (type-name-env-map (lambda (id ty) - (cons (syntax-e id) ty))) - (type-alias-env-map (lambda (id ty) - (cons (syntax-e id) ty)))))] - ;; reinitialize seen type variables - [type-name-references null] - ;; for error reporting - [orig-module-stx stx] - [expanded-module-stx expanded-body]) - (tc-expr/check expanded-body (if expr? region-tc-result (ret ex-types)))) - (report-all-errors) - (set-box! typed-context? old-context) - ;; then clear the new entries from the env ht - (for ([i (in-list (syntax->list fvids))]) - (unregister-type i)) - (with-syntax ([(fv.id ...) fvids] - [(cnt ...) fv-cnts] - [(ex-id ...) exids] - [(ex-cnt ...) ex-cnts] - [(region-cnt ...) region-cnts] - [body expanded-body] - [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]) - (if expr? - (quasisyntax/loc stx - (begin check-syntax-help - (with-contract typed-region - #:results (region-cnt ...) - #:freevars ([fv.id cnt] ...) - body))) - (syntax/loc stx - (begin - (define-values () (begin check-syntax-help (values))) - (with-contract typed-region - ([ex-id ex-cnt] ...) - (define-values (ex-id ...) body)))))))) +(define (with-type-helper stx body fvids fvtys exids extys resty expr? ctx) + (define old-context (unbox typed-context?)) + (define ((no-contract t [stx stx])) + (tc-error/stx stx "Type ~a could not be converted to a contract." t)) + (set-box! typed-context? #t) + (define fv-types (for/list ([t (in-list (syntax->list fvtys))]) + (parse-type t))) + (define fv-cnts (for/list ([t (in-list fv-types)] + [stx (in-list (syntax->list fvtys))]) + (type->contract t #:typed-side #f (no-contract t)))) + (define ex-types (for/list ([t (syntax->list extys)]) + (parse-type t))) + (define ex-cnts (for/list ([t (in-list ex-types)] + [stx (in-list (syntax->list extys))]) + (type->contract t #:typed-side #t (no-contract t)))) + (define region-tc-result + (and expr? (parse-tc-results resty))) + (define region-cnts + (if region-tc-result + (match region-tc-result + [(tc-result1: t) + (list (type->contract t #:typed-side #t (no-contract t #'region-ty-stx)))] + [(tc-results: ts) + (for/list ([t (in-list ts)]) + (type->contract + t #:typed-side #t + (no-contract t #'region-ty-stx)))]) + null)) + (for ([i (in-list (syntax->list fvids))] + [ty (in-list fv-types)]) + (register-type i ty)) + (define expanded-body + (if expr? + (with-syntax ([body body]) + (local-expand #'(let () . body) ctx null)) + (with-syntax ([(body ...) body] + [(id ...) exids] + [(ty ...) extys]) + (local-expand #'(let () (begin (: id ty) ... body ... (values id ...))) ctx null)))) + (parameterize (;; disable fancy printing? + [custom-printer #t] + ;; a cheat to avoid units + [infer-param infer] + ;; do we report multiple errors + [delay-errors? #t] + ;; this parameter is just for printing types + ;; this is a parameter to avoid dependency issues + [current-type-names + (lambda () + (append + (type-name-env-map (lambda (id ty) + (cons (syntax-e id) ty))) + (type-alias-env-map (lambda (id ty) + (cons (syntax-e id) ty)))))] + ;; reinitialize seen type variables + [type-name-references null] + ;; for error reporting + [orig-module-stx stx] + [expanded-module-stx expanded-body]) + (tc-expr/check expanded-body (if expr? region-tc-result (ret ex-types)))) + (report-all-errors) + (set-box! typed-context? old-context) + ;; then clear the new entries from the env ht + (for ([i (in-list (syntax->list fvids))]) + (unregister-type i)) + (with-syntax ([(fv.id ...) fvids] + [(cnt ...) fv-cnts] + [(ex-id ...) exids] + [(ex-cnt ...) ex-cnts] + [(region-cnt ...) region-cnts] + [body expanded-body] + [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]) + (if expr? + (quasisyntax/loc stx + (begin check-syntax-help + (c:with-contract typed-region + #:results (region-cnt ...) + #:freevars ([fv.id cnt] ...) + body))) + (syntax/loc stx + (begin + (define-values () (begin check-syntax-help (values))) + (c:with-contract typed-region + ([ex-id ex-cnt] ...) + (define-values (ex-id ...) body))))))) -(define-syntax (with-type stx) +(define (wt-core stx) (define-syntax-class typed-id #:description "[id type]" [pattern (id ty)]) diff --git a/collects/typed-scheme/rep/filter-rep.rkt b/collects/typed-scheme/rep/filter-rep.rkt index 1fbd6952..430b7524 100644 --- a/collects/typed-scheme/rep/filter-rep.rkt +++ b/collects/typed-scheme/rep/filter-rep.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/match scheme/contract) +(require racket/match scheme/contract) (require "rep-utils.rkt" "free-variance.rkt") (define (Filter/c-predicate? e) @@ -15,7 +15,7 @@ (provide Filter/c FilterSet/c name-ref/c hash-name) (define name-ref/c (or/c identifier? integer?)) -(define (hash-name v) (if (identifier? v) (hash-id v) v)) +(define (hash-name v) (if (identifier? v) (hash-id v) (list v))) (df Bot () [#:fold-rhs #:base]) (df Top () [#:fold-rhs #:base]) @@ -46,10 +46,10 @@ (combine-frees (map free-idxs* fs))]) (df FilterSet (thn els) - [#:contract (->d ([t any/c] + [#:contract (->i ([t any/c] [e any/c]) (#:syntax [stx #f]) - #:pre-cond + #:pre (t e) (and (cond [(Bot? t) #t] [(Bot? e) (Top? t)] [else (Filter/c-predicate? t)]) diff --git a/collects/typed-scheme/rep/object-rep.rkt b/collects/typed-scheme/rep/object-rep.rkt index 3608a0e9..97b9a441 100644 --- a/collects/typed-scheme/rep/object-rep.rkt +++ b/collects/typed-scheme/rep/object-rep.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/match scheme/contract "rep-utils.rkt" "free-variance.rkt" "filter-rep.rkt") +(require racket/match scheme/contract "rep-utils.rkt" "free-variance.rkt" "filter-rep.rkt") (provide object-equal?) (dpe CarPE () [#:fold-rhs #:base]) diff --git a/collects/typed-scheme/rep/rep-utils.rkt b/collects/typed-scheme/rep/rep-utils.rkt index a52d800e..eccd1b6b 100644 --- a/collects/typed-scheme/rep/rep-utils.rkt +++ b/collects/typed-scheme/rep/rep-utils.rkt @@ -2,7 +2,7 @@ (require "../utils/utils.rkt") (require mzlib/struct mzlib/pconvert - scheme/match + racket/match syntax/boundmap "free-variance.rkt" "interning.rkt" @@ -12,7 +12,7 @@ (for-syntax scheme/list (only-in unstable/syntax generate-temporary) - scheme/match + racket/match (except-in syntax/parse id identifier keyword) scheme/base syntax/struct diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index f942dc8b..4cddd134 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -3,7 +3,7 @@ (require (utils tc-utils) "rep-utils.rkt" "object-rep.rkt" "filter-rep.rkt" "free-variance.rkt" - mzlib/trace scheme/match mzlib/etc + mzlib/trace racket/match mzlib/etc scheme/contract unstable/debug (for-syntax scheme/base syntax/parse)) @@ -149,8 +149,8 @@ ;; n is how many variables are bound here ;; body is a Scope (dt Poly (n body) #:no-provide - [#:contract (->d ([n natural-number/c] - [body (scope-depth n)]) + [#:contract (->i ([n natural-number/c] + [body (n) (scope-depth n)]) (#:syntax [stx (or/c #f syntax?)]) [result Poly?])] [#:frees (λ (f) (f body))] @@ -162,8 +162,8 @@ ;; there are n-1 'normal' vars and 1 ... var ;; body is a Scope (dt PolyDots (n body) #:no-provide - [#:contract (->d ([n natural-number/c] - [body (scope-depth n)]) + [#:contract (->i ([n natural-number/c] + [body (n) (scope-depth n)]) (#:syntax [stx (or/c #f syntax?)]) [result PolyDots?])] [#:key (Type-key body)] @@ -187,7 +187,6 @@ [#:frees (λ (frees) (combine-frees (map frees (list t f o))))] [#:fold-rhs (*Result (type-rec-id t) (filter-rec-id f) (object-rec-id o))]) -;; types : Listof[Type] (dt Values ([rs (listof Result?)]) [#:frees (λ (f) (combine-frees (map f rs)))] [#:fold-rhs (*Values (map type-rec-id rs))]) @@ -197,7 +196,8 @@ (hash-remove (combine-frees (map free-vars* (cons dty rs))) dbound) (combine-frees (map free-vars* (cons dty rs)))) (if (symbol? dbound) - (combine-frees (cons (make-immutable-hasheq (list (cons dbound Covariant))) (map free-idxs* (cons dty rs)))) + (combine-frees (cons (make-immutable-hasheq (list (cons dbound Covariant))) + (map free-idxs* (cons dty rs)))) (combine-frees (map free-idxs* (cons dty rs))))] [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)]) @@ -330,11 +330,14 @@ ;; in : Type ;; out : Type -(dt Param ([in Type/c] [out Type/c]) [#:key 'parameter]) +(dt Param ([in Type/c] [out Type/c]) + [#:key 'parameter] + [#:frees (λ (f) (combine-frees (list (f out) (flip-variances (f in)))))]) ;; key : Type ;; value : Type -(dt Hashtable ([key Type/c] [value Type/c]) [#:key 'hash]) +(dt Hashtable ([key Type/c] [value Type/c]) [#:key 'hash] + [#:frees (λ (f) (combine-frees (list (make-invariant (f key)) (make-invariant (f value)))))]) ;; parent : Type ;; pred : Identifier @@ -383,6 +386,8 @@ [#:frees (λ (f) (combine-frees (map f tys)))] [#:key #f] [#:fold-rhs (*Sequence (map type-rec-id tys))]) +(dt Future ([t Type/c]) [#:key 'future]) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Ugly hack - should use units diff --git a/collects/typed-scheme/scribblings/begin.scrbl b/collects/typed-scheme/scribblings/begin.scrbl index 137b8e29..5c68d127 100644 --- a/collects/typed-scheme/scribblings/begin.scrbl +++ b/collects/typed-scheme/scribblings/begin.scrbl @@ -23,7 +23,7 @@ are provided as well; for example, the @racketmodname[typed/racket/base] language corresponds to @racketmodname[racket/base]. -@racketblock[(define-struct: pt ([x : Real] [y : Real]))] +@racketblock[(struct: pt ([x : Real] [y : Real]))] @margin-note{Many forms in Typed Racket have the same name as the untyped forms, with a @racket[:] suffix.} @@ -31,10 +31,10 @@ This defines a new structure, name @racket[pt], with two fields, @racket[x] and @racket[y]. Both fields are specified to have the type @racket[Real], which corresponds to the @rtech{real numbers}. The -@racket[define-struct:] form corresponds to the @racket[define-struct] +@racket[struct:] form corresponds to the @racket[struct] form from @racketmodname[racket]---when porting a program from @racketmodname[racket] to @racketmodname[typed/racket], uses of -@racket[define-struct] should be changed to @racket[define-struct:]. +@racket[struct] should be changed to @racket[struct:]. @racketblock[(: mag (pt -> Number))] @@ -71,8 +71,8 @@ represent these using @italic{union types}, written @racket[(U t1 t2 ...)]. @racketmod[ typed/racket (define-type Tree (U leaf node)) -(define-struct: leaf ([val : Number])) -(define-struct: node ([left : Tree] [right : Tree])) +(struct: leaf ([val : Number])) +(struct: node ([left : Tree] [right : Tree])) (: tree-height (Tree -> Integer)) (define (tree-height t) diff --git a/collects/typed-scheme/scribblings/more.scrbl b/collects/typed-scheme/scribblings/more.scrbl index 9a6123f4..189e5506 100644 --- a/collects/typed-scheme/scribblings/more.scrbl +++ b/collects/typed-scheme/scribblings/more.scrbl @@ -44,7 +44,7 @@ in both top-level and internal contexts. @racketblock[ (define: x : Number 7) -(define: (id [z : Number]) z)] +(define: (id [z : Number]) : Number z)] Here, @racket[x] has the type @racket[Number], and @racket[id] has the type @racket[(Number -> Number)]. In the body of @racket[id], @@ -60,7 +60,8 @@ type @racket[(Number -> Number)]. In the body of @racket[id], The @racket[let:] form is exactly like @racket[let], but type annotations are provided for each variable bound. Here, @racket[x] is given the type @racket[Number]. The @racket[let*:] and -@racket[letrec:] are similar. +@racket[letrec:] are similar. Annotations are optional with +@racket[let:] and variants. @racketblock[ (let-values: ([([x : Number] [y : String]) (values 7 "hello")]) diff --git a/collects/typed-scheme/scribblings/optimization.scrbl b/collects/typed-scheme/scribblings/optimization.scrbl index e7d70054..dbe65aa7 100644 --- a/collects/typed-scheme/scribblings/optimization.scrbl +++ b/collects/typed-scheme/scribblings/optimization.scrbl @@ -12,10 +12,143 @@ 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} +@section{Turning the optimizer off} -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: +Typed Racket's optimizer is turned on by default. If you want to +deactivate it (for debugging, for instance), you must add the +@racket[#:no-optimize] keyword when specifying the language of your +program: -@racketmod[typed/racket #:optimize] +@racketmod[typed/racket #:no-optimize] + +@section{Getting the most out of the optimizer} +Typed Racket's optimizer can improve the performance of various common +Racket idioms. However, it does a better job on some idioms than on +others. By writing your programs using the right idioms, you can help +the optimizer help you. + +@subsection{Numeric types} +Being type-driven, the optimizer makes most of its decisions based on +the types you assigned to your data. As such, you can improve the +optimizer's usefulness by writing informative types. + +For example, the following programs both typecheck: +@racketblock[(define: (f (x : Real)) : Real (+ x 2.5)) + (f 3.5)] +@racketblock[(define: (f (x : Float)) : Float (+ x 2.5)) + (f 3.5)] + +However, the second one uses more informative types: the +@racket[Float] type includes only 64-bit floating-point numbers +whereas the +@racket[Real] type includes both exact and +@tech[#:doc '(lib "scribblings/reference/reference.scrbl") #:key +"inexact numbers"]{inexact} +@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{real numbers} +and the @racket[Inexact-Real] type includes both 32- and 64-bit +floating-point numbers. +Typed Racket's optimizer can optimize the latter program to use +@tech[#:doc '(lib "scribblings/reference/reference.scrbl") #:key +"inexact numbers"]{float} +-specific operations whereas it cannot do anything with the +former program. + +Thus, to get the most of Typed Racket's optimizer, you should use the +@racket[Float] type when possible. For similar reasons, you should use +floating-point literals instead of exact literals when doing +floating-point computations. + +When mixing floating-point numbers and exact reals in arithmetic +operations, the result is not necessarily a @racket[Float]. For +instance, the result of @racket[(* 2.0 0)] is @racket[0] which is not +a @racket[Float]. This can result in missed optimizations. To prevent +this, when mixing floating-point numbers and exact reals, coerce exact +reals to floating-point numbers using @racket[exact->inexact]. This is +not necessary when using @racket[+] or @racket[-]. When mixing +floating-point numbers of different precisions, results use the +highest precision possible. + +On a similar note, the @racket[Float-Complex] type is preferable to +the @racket[Complex] type for the same reason. Typed Racket can keep +@tech[#:doc '(lib "scribblings/reference/reference.scrbl") #:key +"inexact numbers"]{inexact} +@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{complex numbers} +unboxed; as such, programs using +@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{complex numbers} +can have better performance than equivalent programs that +represent +@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{complex numbers} +as two +@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{real numbers}. +As with floating-point literals, +@tech[#:doc '(lib "scribblings/reference/reference.scrbl") #:key +"inexact numbers"]{inexact} +@tech[#:doc '(lib "scribblings/reference/reference.scrbl") #:key +"complex numbers"]{complex} +literals (such as @racket[1.0+1.0i]) should be preferred over exact +@tech[#:doc '(lib "scribblings/reference/reference.scrbl") #:key +"complex numbers"]{complex} +literals (such as @racket[1+1i]). Note that both parts of a literal must be +present and +@tech[#:doc '(lib "scribblings/reference/reference.scrbl") #:key +"inexact numbers"]{inexact} +for the literal to be of type +@racket[Float-Complex]; @racket[0.0+1.0i] is of type +@racket[Float-Complex] but @racket[+1.0i] is not. +To get the most of +Typed Racket's optimizer, you should also favor rectangular +coordinates over polar coordinates. + +@subsection{Lists} +Typed Racket handles potentially empty lists and lists that are known +to be non-empty differently: when taking the @racket[car] or the +@racket[cdr] of a list Typed Racket knows is non-empty, it can skip +the check for the empty list that is usually done when calling +@racket[car] and @racket[cdr]. + +@racketblock[ +(define: (sum (l : (Listof Integer))) : Integer + (if (null? l) + 0 + (+ (car l) (sum (cdr l))))) +] + +In this example, Typed Racket knows that if we reach the else branch, +@racket[l] is not empty. The checks associated with @racket[car] and +@racket[cdr] would be redundant and are eliminated. + +In addition to explicitly checking for the empty list using +@racket[null?], you can inform Typed Racket that a list is non-empty +by using the known-length list type constructor; if your data is +stored in lists of fixed length, you can use the @racket[List] type +constructors. + +For instance, the type of a list of two @racket[Integer]s can be +written either as: +@racketblock[(define-type List-2-Ints (Listof Integer))] +or as the more precise: +@racketblock[(define-type List-2-Ints (List Integer Integer))] + +Using the second definition, all @racket[car] and @racket[cdr]-related +checks can be eliminated in this function: +@racketblock[ +(define: (sum2 (l : List-2-Ints) : Integer) + (+ (car l) (car (cdr l)))) +] + +@subsection{Vectors} + +In addition to known-length lists, Typed Racket supports known-length +vectors through the @racket[Vector] type constructor. Known-length +vector access using constant indices can be optimized in a similar +fashion as @racket[car] and @racket[cdr]. + +@#reader scribble/comment-reader (racketblock +;; #(name r g b) +(define-type Color (Vector String Integer Integer Integer)) +(define: x : Color (vector "red" 255 0 0)) +(vector-ref x 0) ; good +(define color-name 0) +(vector-ref x color-name) ; good +(vector-ref x (* 0 10)) ; bad +) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 4b546d66..84cb9545 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -1,8 +1,9 @@ #lang scribble/manual -@begin[(require "utils.rkt" scribble/eval +@begin[(require "utils.rkt" scribble/eval scriblib/footnote racket/sandbox) - (require (for-label (only-meta-in 0 typed/racket) + (require (for-label (only-meta-in 0 [except-in typed/racket for]) + (only-in racket/base for) racket/list srfi/14 version/check))] @@ -34,19 +35,27 @@ any expression of this type will not evaluate to a value.} @deftogether[( @defidform[Number] @defidform[Complex] -@defidform[Inexact-Complex] +@defidform[Float-Complex] @defidform[Real] @defidform[Float] @defidform[Nonnegative-Float] +@defidform[Inexact-Real] @defidform[Exact-Rational] @defidform[Integer] @defidform[Natural] @defidform[Exact-Nonnegative-Integer] @defidform[Exact-Positive-Integer] +@defidform[Fixnum] +@defidform[Nonnegative-Fixnum] +@defidform[Positive-Fixnum] @defidform[Zero] )]{These types represent the hierarchy of @rtech{numbers} of Racket. @racket[Integer] includes only @rtech{integers} that are @rtech{exact -numbers}, corresponding to the predicate @racket[exact-integer?]. +numbers}, corresponding to the predicate @racket[exact-integer?]. +@racket{Real} includes both exact and inexact reals. +An @racket{Inexact-Real} can be either 32- or 64-bit floating-point +numbers. @racket{Float} is restricted to 64-bit floats, which are the +default in Racket. @ex[ 7 @@ -207,7 +216,8 @@ by @racket[read].} @defform[(U t ...)]{is the union of the types @racket[t ...]. @ex[(λ: ([x : Real])(if (> 0 x) "yes" 'no))]} @defform[(case-lambda fun-ty ...)]{is a function that behaves like all of - the @racket[fun-ty]s. The @racket[fun-ty]s must all be function + the @racket[fun-ty]s, considered in order from first to last. + The @racket[fun-ty]s must all be function types constructed with @racket[->].} @defform/none[(t t1 t2 ...)]{is the instantiation of the parametric type @racket[t] at types @racket[t1 t2 ...]} @@ -231,16 +241,6 @@ recursive type in the body @racket[t]} @defform[(Option t)]{Either @racket[t] of @racket[#f]} -Other types cannot be written by the programmer, but are used -internally and may appear in error messages. - -@defform/none[(struct:n (t ...))]{is the type of structures named -@racket[n] with field types @racket[t]. There may be multiple such -types with the same printed representation.} -@defform/none[]{is the printed representation of a reference to the -type variable @racket[n]} - - @section[#:tag "special-forms"]{Special Form Reference} Typed Racket provides a variety of special forms above and beyond @@ -258,8 +258,8 @@ creating new types, and annotating expressions. Local bindings, like @racket[let], each with associated types. In the second form, @racket[_t0] is the type of the result of @racket[_loop] (and thus the result of the entire - expression as well as the final - expression in @racket[body]).} +expression as well as the final expression in @racket[body]). +Type annotations are optional.} @deftogether[[ @defform[(letrec: ([v : t e] ...) . body)] @defform[(let*: ([v : t e] ...) . body)] @@ -268,7 +268,8 @@ result of @racket[_loop] (and thus the result of the entire @defform[(let*-values: ([([v : t] ...) e] ...) . body)]]]{ Type-annotated versions of @racket[letrec], @racket[let*], @racket[let-values], - @racket[letrec-values], and @racket[let*-values].} +@racket[letrec-values], and @racket[let*-values]. As with +@racket[let:], type annotations are optional.} @deftogether[[ @defform[(let/cc: v : t . body)] @@ -303,11 +304,14 @@ A polymorphic function of multiple arities.} ([type-ann-maybe code:blank @code:line[: Void]] [for:-clause [id : t seq-expr] + [id seq-expr] @code:line[#:when guard]])]{ Like @racket[for], but each @racket[id] having the associated type @racket[t]. Since the return type is always @racket[Void], annotating the return type of a @racket[for] form is optional. Unlike @racket[for], multi-valued @racket[seq-expr]s are not supported. +Type annotations in clauses are optional for all @racket[for:] +variants. } @deftogether[[ @@ -315,6 +319,8 @@ the return type of a @racket[for] form is optional. Unlike @;@defform[(for/hash: : u (for:-clause ...) expr ...+)] @; the ones that are commented out don't currently work @;@defform[(for/hasheq: : u (for:-clause ...) expr ...+)] @;@defform[(for/hasheqv: : u (for:-clause ...) expr ...+)] +@;@defform[(for/vector: : u (for:-clause ...) expr ...+)] +@;@defform[(for/flvector: : u (for:-clause ...) expr ...+)] @;@defform[(for/and: : u (for:-clause ...) expr ...+)] @defform[(for/or: : u (for:-clause ...) expr ...+)] @;@defform[(for/first: : u (for:-clause ...) expr ...+)] @@ -355,7 +361,8 @@ These behave like their non-annotated counterparts. ([step-expr-maybe code:blank step-expr])]{ Like @racket[do], but each @racket[id] having the associated type @racket[t], and -the final body @racket[expr] having the type @racket[u]. +the final body @racket[expr] having the type @racket[u]. Type +annotations are optional. } @@ -397,7 +404,7 @@ corresponding to @racket[define-struct].} @defform/subs[ (define-struct/exec: name-spec ([f : t] ...) [e : proc-t]) ([name-spec name (name parent)])]{ - Like @racket[define-struct:], but defines an procedural structure. + Like @racket[define-struct:], but defines a procedural structure. The procdure @racket[e] is used as the value for @racket[prop:procedure], and must have type @racket[proc-t].} @subsection{Names for Types} @@ -539,6 +546,13 @@ y (assert y number?) (assert y boolean?)] +@defform*/subs[[(with-asserts ([id maybe-pred] ...) body ...+)] + ([maybe-pred code:blank + (code:line predicate)])]{ +Guard the body with assertions. If any of the assertions fail, the +program errors. These assertions behave like @racket[assert]. +} + @section{Typed Racket Syntax Without Type Checking} @@ -606,14 +620,37 @@ have the types ascribed to them; these types are converted to contracts and chec @section{Optimization in Typed Racket} +@note{ +See +@secref[#:doc '(lib "typed-scheme/scribblings/ts-guide.scrbl")]{optimization} +in the guide for tips to get the most out of the optimizer. +} + 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: +Typed Racket's optimizer is turned on by default. If you want to +deactivate it (for debugging, for instance), you must add the +@racket[#:no-optimize] keyword when specifying the language of your +program: -@racketmod[typed/racket #:optimize] +@racketmod[typed/racket #:no-optimize] + +@section{Legacy Forms} + +The following forms are provided by Typed Racket for backwards +compatibility. + +@defidform[define-type-alias]{Equivalent to @racket[define-type].} +@defidform[require/opaque-type]{Similar to using the @racket[opaque] +keyword with @racket[require/typed].} +@defidform[require-typed-struct]{Similar to using the @racket[struct] +keyword with @racket[require/typed].} + +@(defmodulelang* (typed-scheme) + #:use-sources (typed-scheme/typed-scheme + typed-scheme/private/prims)) +Equivalent to the @racketmod[typed/racket/base] language. } diff --git a/collects/typed-scheme/scribblings/types.scrbl b/collects/typed-scheme/scribblings/types.scrbl index 1d020b11..e766f023 100644 --- a/collects/typed-scheme/scribblings/types.scrbl +++ b/collects/typed-scheme/scribblings/types.scrbl @@ -102,12 +102,12 @@ refers to the whole binary tree type within the body of the @section{Structure Types} -Using @racket[define-struct:] introduces new types, distinct from any +Using @racket[struct:] introduces new types, distinct from any previous type. -@racketblock[(define-struct: point ([x : Real] [y : Real]))] +@racketblock[(struct: point ([x : Real] [y : Real]))] -Instances of this structure, such as @racket[(make-point 7 12)], have type @racket[point]. +Instances of this structure, such as @racket[(point 7 12)], have type @racket[point]. @section{Subtyping} @@ -172,30 +172,30 @@ an analog of the @tt{Maybe} type constructor from Haskell: @racketmod[ typed/racket -(define-struct: None ()) -(define-struct: (a) Some ([v : a])) +(struct: None ()) +(struct: (a) Some ([v : a])) (define-type (Opt a) (U None (Some a))) (: find (Number (Listof Number) -> (Opt Number))) (define (find v l) - (cond [(null? l) (make-None)] - [(= v (car l)) (make-Some v)] + (cond [(null? l) (None)] + [(= v (car l)) (Some v)] [else (find v (cdr l))])) ] -The first @racket[define-struct:] defines @racket[None] to be +The first @racket[struct:] defines @racket[None] to be a structure with no contents. The second definition @racketblock[ -(define-struct: (a) Some ([v : a])) +(struct: (a) Some ([v : a])) ] -creates a parameterized type, @racket[Just], which is a structure with +creates a parameterized type, @racket[Some], which is a structure with one element, whose type is that of the type argument to -@racket[Just]. Here the type parameters (only one, @racket[a], in +@racket[Some]. Here the type parameters (only one, @racket[a], in this case) are written before the type name, and can be referred to in the types of the fields. @@ -207,8 +207,8 @@ creates a parameterized type --- @racket[Opt] is a potential container for whatever type is supplied. The @racket[find] function takes a number @racket[v] and list, and -produces @racket[(make-Some v)] when the number is found in the list, -and @racket[(make-None)] otherwise. Therefore, it produces a +produces @racket[(Some v)] when the number is found in the list, +and @racket[(None)] otherwise. Therefore, it produces a @racket[(Opt Number)], just as the annotation specified. @subsection{Polymorphic Functions} 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/typecheck/check-below.rkt b/collects/typed-scheme/typecheck/check-below.rkt index 9f06b138..1a6d0fce 100644 --- a/collects/typed-scheme/typecheck/check-below.rkt +++ b/collects/typed-scheme/typecheck/check-below.rkt @@ -12,7 +12,7 @@ (only-in srfi/1 split-at)) (p/c - [check-below (->d ([s (or/c Type/c tc-results?)] [t (or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])]) + [check-below (-->d ([s (-or/c Type/c tc-results?)] [t (-or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])]) (define (print-object o) (match o diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.rkt b/collects/typed-scheme/typecheck/check-subforms-unit.rkt index 6196c0b9..83b34289 100644 --- a/collects/typed-scheme/typecheck/check-subforms-unit.rkt +++ b/collects/typed-scheme/typecheck/check-subforms-unit.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" syntax/kerncase syntax/parse - scheme/match unstable/debug + racket/match unstable/debug "signatures.rkt" "tc-metafunctions.rkt" (types utils convenience union subtype) (utils tc-utils) @@ -25,7 +25,7 @@ (Values: (list (Result: rngs _ _) ...)) _ _ (list (Keyword: _ _ #t) ...)))) (apply Un rngs)] - [_ (int-err "Internal error in get-result-ty: not a function type: ~n~a" t)])) + [_ (int-err "Internal error in get-result-ty: not a function type: \n~a" t)])) (let loop ([form form]) (parameterize ([current-orig-stx form]) (syntax-parse form @@ -44,7 +44,7 @@ (Function: (list (arr: (list _) _ _ _ (list (Keyword: _ _ #f) ...)) ...)))) (set! handler-tys (cons (get-result-ty t) handler-tys))] [(tc-results: t) - (tc-error "Exception handler must be a single-argument function, got ~n~a" t)]))] + (tc-error "Exception handler must be a single-argument function, got \n~a" t)]))] [stx ;; this is the body of the with-handlers #:when (syntax-property form 'typechecker:exn-body) diff --git a/collects/typed-scheme/typecheck/def-export.rkt b/collects/typed-scheme/typecheck/def-export.rkt index acf624d6..16b70823 100644 --- a/collects/typed-scheme/typecheck/def-export.rkt +++ b/collects/typed-scheme/typecheck/def-export.rkt @@ -1,16 +1,10 @@ #lang racket/base -(require racket/require - (for-syntax syntax/parse racket/base - (path-up "utils/tc-utils.rkt" "private/typed-renaming.rkt" "env/type-name-env.rkt"))) +(require racket/require (for-template "renamer.rkt") "renamer.rkt" + (for-syntax syntax/parse racket/base "renamer.rkt" + (path-up "utils/tc-utils.rkt" "env/type-name-env.rkt"))) (provide def-export) - -(define-for-syntax (renamer id #:alt [alt #f]) - (if alt - (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) - (make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) - (define-syntax (def-export stx) (syntax-parse stx [(def-export export-id:identifier id:identifier cnt-id:identifier) diff --git a/collects/typed-scheme/typecheck/find-annotation.rkt b/collects/typed-scheme/typecheck/find-annotation.rkt index 48b5612f..c03d4184 100644 --- a/collects/typed-scheme/typecheck/find-annotation.rkt +++ b/collects/typed-scheme/typecheck/find-annotation.rkt @@ -72,5 +72,5 @@ [e:core-expr (ormap find (syntax->list #'(e.expr ...)))])) -; (require scheme/trace) +; (require racket/trace) ; (trace find-annotation) diff --git a/collects/typed-scheme/typecheck/provide-handling.rkt b/collects/typed-scheme/typecheck/provide-handling.rkt index 48734be0..c84890ba 100644 --- a/collects/typed-scheme/typecheck/provide-handling.rkt +++ b/collects/typed-scheme/typecheck/provide-handling.rkt @@ -12,7 +12,7 @@ (for-syntax syntax/parse racket/base) racket/contract/private/provide unstable/list unstable/debug syntax/id-table racket/dict - unstable/syntax scheme/struct-info scheme/match + unstable/syntax scheme/struct-info racket/match "def-binding.rkt" syntax/parse (for-template scheme/base "def-export.rkt" scheme/contract)) @@ -90,7 +90,7 @@ (make-provide/contract-transformer (quote-syntax the-contract) (quote-syntax id) - (quote-syntax out-id) + (quote-syntax export-id) (quote-syntax module-source))) (def-export export-id id cnt-id))) new-id)] diff --git a/collects/typed-scheme/typecheck/renamer.rkt b/collects/typed-scheme/typecheck/renamer.rkt new file mode 100644 index 00000000..a1f19cff --- /dev/null +++ b/collects/typed-scheme/typecheck/renamer.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(require "../private/typed-renaming.rkt") +(provide renamer) + +(define (renamer id #:alt [alt #f]) + (if alt + (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) + (make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app-helper.rkt b/collects/typed-scheme/typecheck/tc-app-helper.rkt index d829d632..9d68edc3 100644 --- a/collects/typed-scheme/typecheck/tc-app-helper.rkt +++ b/collects/typed-scheme/typecheck/tc-app-helper.rkt @@ -1,10 +1,54 @@ #lang scheme/base -(require "../utils/utils.rkt" scheme/match unstable/list - (utils tc-utils) (rep type-rep) (types utils union abbrev)) +(require "../utils/utils.rkt" racket/match unstable/list unstable/sequence + (only-in srfi/1 unzip4) (only-in racket/list make-list) + (prefix-in c: racket/contract) + "check-below.rkt" "tc-subst.rkt" + (utils tc-utils) + (rep type-rep object-rep) + (types utils union abbrev subtype)) (provide (all-defined-out)) + +;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? +(d/c (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) + ((syntax? syntax? arr? (c:listof tc-results?) (c:or/c #f tc-results?)) (#:check boolean?) . c:->* . tc-results?) + (match* (ftype0 argtys) + ;; we check that all kw args are optional + [((arr: dom (Values: (and results (list (Result: t-r f-r o-r) ...))) rest #f (and kws (list (Keyword: _ _ #f) ...))) + (list (tc-result1: t-a phi-a o-a) ...)) + (when check? + (cond [(and (not rest) (not (= (length dom) (length t-a)))) + (tc-error/expr #:return (ret t-r) + "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))] + [(and rest (< (length t-a) (length dom))) + (tc-error/expr #:return (ret t-r) + "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))]) + (for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] + [a (in-list (syntax->list args-stx))] + [arg-t (in-list t-a)]) + (parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) + (let* ([dom-count (length dom)] + [arg-count (+ dom-count (if rest 1 0) (length kws))]) + (let-values + ([(o-a t-a) (for/lists (os ts) + ([nm (in-range arg-count)] + [oa (in-sequence-forever (in-list o-a) (make-Empty))] + [ta (in-sequence-forever (in-list t-a) (Un))]) + (values (if (>= nm dom-count) (make-Empty) oa) + ta))]) + (define-values (t-r f-r o-r) + (for/lists (t-r f-r o-r) + ([r (in-list results)]) + (open-Result r o-a t-a))) + (ret t-r f-r o-r)))] + [((arr: _ _ _ drest '()) _) + (int-err "funapp with drest args ~a ~a NYI" drest argtys)] + [((arr: _ _ _ _ kws) _) + (int-err "funapp with keyword args ~a NYI" kws)])) + + (define (make-printable t) (match t [(tc-result1: t) t] @@ -20,8 +64,17 @@ (format "~a~a *~a" doms-string rst rng-string)] [else (string-append (stringify (map make-printable dom)) rng-string)]))) -(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound - #:expected [expected #f]) +;; Generates error messages when operand types don't match operator domains. +(d/c (domain-mismatches f-stx args-stx ty doms rests drests rngs arg-tys tail-ty tail-bound + #:expected [expected #f] #:return [return (make-Union null)] + #:msg-thunk [msg-thunk (lambda (dom) dom)]) + ((syntax? syntax? Type/c (c:listof (c:listof Type/c)) (c:listof (c:or/c #f Type/c)) + (c:listof (c:or/c #f (c:cons/c Type/c (c:or/c c:natural-number/c symbol?)))) + (c:listof (c:or/c Values? ValuesDots?)) (c:listof tc-results?) (c:or/c #f Type/c) c:any/c) + (#:expected (c:or/c #f tc-results?) #:return tc-results? + #:msg-thunk (c:-> string? string?)) + . c:->* . tc-results?) + (define arguments-str (stringify-domain arg-tys (if (not tail-bound) tail-ty #f) @@ -30,51 +83,196 @@ [(null? doms) (int-err "How could doms be null: ~a ~a" ty)] [(and (= 1 (length doms)) (not (car rests)) (not (car drests)) (not tail-ty) (not tail-bound)) - (apply string-append - (if (not (= (length (car doms)) (length arg-tys))) - (format "Wrong number of arguments - Expected ~a, but got ~a\n\n" (length (car doms)) (length arg-tys)) - "") - (append - (for/list ([dom-t (in-list (extend arg-tys (car doms) #f))] - [arg-t (in-list (extend (car doms) arg-tys #f))] - [i (in-naturals 1)]) - (let ([dom-t (or dom-t "-none-")] - [arg-t (or arg-t "-none-")]) - (format "Argument ~a:\n Expected: ~a\n Given: ~a\n" i (make-printable dom-t) (make-printable arg-t)))) - (list - (if expected - (format "\nResult type: ~a\nExpected result: ~a\n" - (car rngs) (make-printable expected)) - ""))))] + (tc-error/expr + #:return return + (msg-thunk + (apply string-append + (if (not (= (length (car doms)) (length arg-tys))) + (format "Wrong number of arguments - Expected ~a, but got ~a\n\n" (length (car doms)) (length arg-tys)) + "") + (append + (for/list ([dom-t (in-list (extend arg-tys (car doms) #f))] + [arg-t (in-list (extend (car doms) arg-tys #f))] + [i (in-naturals 1)]) + (let ([dom-t (or dom-t "-none-")] + [arg-t (or arg-t "-none-")]) + (format "Argument ~a:\n Expected: ~a\n Given: ~a\n" i (make-printable dom-t) (make-printable arg-t)))) + (list + (if expected + (format "\nResult type: ~a\nExpected result: ~a\n" + (car rngs) (make-printable expected)) + ""))))))] [(= 1 (length doms)) - (string-append - "Domain: " - (stringify-domain (car doms) (car rests) (car drests)) - "\nArguments: " - arguments-str - "\n" - (if expected - (format "Result type: ~a\nExpected result: ~a\n" - (car rngs) (make-printable expected)) - ""))] - [else - (let ([label (if expected "Types: " "Domains: ")] - [nl+spc (if expected "\n " "\n ")] - [pdoms (map make-printable doms)]) + (tc-error/expr + #:return return + (msg-thunk (string-append - label - (stringify (if expected - (map stringify-domain pdoms rests drests rngs) - (map stringify-domain pdoms rests drests)) - nl+spc) + "Domain: " + (stringify-domain (car doms) (car rests) (car drests)) "\nArguments: " arguments-str "\n" (if expected - (format "Expected result: ~a\n" (make-printable expected)) - "")))])) + (format "Result type: ~a\nExpected result: ~a\n" + (car rngs) (make-printable expected)) + ""))))] + [else + (let ([label (if expected "Types: " "Domains: ")] + [nl+spc (if expected "\n " "\n ")]) + ;; we restrict the domains shown in the error messages to those that + ;; are useful + (let-values ([(pdoms rngs rests drests) (possible-domains doms rests drests rngs expected)]) + (if (= (length pdoms) 1) + ;; if we narrowed down the possible cases to a single one, have + ;; tc/funapp1 generate a better error message + (begin (tc/funapp1 f-stx args-stx + (make-arr (car pdoms) (car rngs) + (car rests) (car drests) null) + arg-tys expected) + return) + ;; if not, print the message as usual + (let* ([pdoms (map make-printable pdoms)] + [err-doms + (string-append + label + (stringify (if expected + (map stringify-domain pdoms rests drests rngs) + (map stringify-domain pdoms rests drests)) + nl+spc) + "\nArguments: " + arguments-str + "\n" + (if expected + (format "Expected result: ~a\n" (make-printable expected)) + ""))]) + (tc-error/expr + #:return return + (msg-thunk err-doms))))))])) ; generate message -(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f]) + +;; to avoid long and confusing error messages, in the case of functions with +;; multiple similar domains (<, >, +, -, etc.), we show only the domains that +;; are relevant to this specific error +;; this is done in several ways: +;; - if a case-lambda case is subsumed by another, we don't need to show it +;; (subsumed cases may be useful for their filter information, but this is +;; unrelated to error reporting) +;; - if we have an expected type, we don't need to show the domains for which +;; the result type is not a subtype of the expected type +;; - we can disregard domains that are more restricted than required to get +;; the expected type (or all but the most liberal domain when no type is +;; expected) +;; ex: if we have the 2 following possible domains for an operator: +;; Fixnum -> Fixnum +;; Integer -> Integer +;; and an expected type of Integer for the result of the application, +;; we can disregard the Fixnum domain since it imposes a restriction that +;; is not necessary to get the expected type +(define (possible-domains doms rests drests rngs expected) + + ;; is fun-ty subsumed by a function type in others? + (define (is-subsumed-in? fun-ty others) + ;; assumption: domains go from more specific to less specific + ;; thus, a domain can only be subsumed by another that is further down + ;; the list. + ;; this is reasonable because a more specific domain coming after a more + ;; general domain would never be matched + ;; a case subsumes another if the first one is a subtype of the other + (ormap (lambda (x) (subtype x fun-ty)) + others)) + + (define expected-ty (and expected (match expected [(tc-result1: t) t]))) + (define (returns-subtype-of-expected? fun-ty) + (or (not expected) + (match fun-ty + [(Function: (list (arr: _ rng _ _ _))) + (let ([rng (match rng + [(Values: (list (Result: t _ _))) + t] + [(ValuesDots: (list (Result: t _ _)) _ _) + t])]) + (subtype rng expected-ty))]))) + + ;; original info that the error message would have used + ;; kept in case we discard all the cases + (define orig (map list doms rngs rests drests)) + + ;; iterate in lock step over the function types we analyze and the parts + ;; that we will need to print the error message, to make sure we throw + ;; away cases consistently + (let loop ([cases (map (compose make-Function list make-arr) + doms + (map (match-lambda ; strip filters + [(Values: (list (Result: t _ _) ...)) + (-values t)] + [(ValuesDots: (list (Result: t _ _) ...) _ _) + (-values t)]) + rngs) + rests drests (make-list (length doms) null))] + ;; the parts we'll need to print the error message + [parts orig] + ;; accumulators + [candidates '()] ; from cases + [parts-acc '()]) ; from parts + + ;; discard subsumed cases (supertype modulo filters) + (if (not (null? cases)) + (let ([head (car cases)] [tail (cdr cases)]) + (if (is-subsumed-in? head tail) + (loop tail (cdr parts) + candidates parts-acc) ; we discard this one + (loop tail (cdr parts) + (cons head candidates) ; we keep this one + (cons (car parts) parts-acc)))) + + ;; keep only the domains for which the associated function type + ;; is consistent with the expected type + (let loop ([cases candidates] + [parts parts-acc] + ;; accumulators + [candidates '()] + [parts-acc '()]) + (if (not (null? cases)) + (if (returns-subtype-of-expected? (car cases)) + (loop (cdr cases) (cdr parts) + (cons (car cases) candidates) ; we keep this one + (cons (car parts) parts-acc)) + (loop (cdr cases) (cdr parts) + candidates parts-acc)) ; we discard this one + + ;; among the domains that fit with the expected type, we only + ;; need to keep the most liberal + ;; since we only care about permissiveness of domains, we + ;; reconstruct function types with a return type of any then test + ;; for subtyping + (let ([fun-tys-ret-any + (map (match-lambda + [(Function: (list (arr: dom _ rest drest _))) + (make-Function (list (make-arr dom (-values (list Univ)) + rest drest null)))]) + candidates)]) + (let loop ([cases fun-tys-ret-any] + [parts parts-acc] + ;; accumulators + ;; final pass, we only need the parts to print the + ;; error message + [parts-acc '()]) + (if (not (null? cases)) + ;; if a case is a supertype of another, we discard it + (let ([head (car cases)]) + (if (is-subsumed-in? head (remove head fun-tys-ret-any)) + (loop (cdr cases) (cdr parts) + parts-acc) ; we discard this one + (loop (cdr cases) (cdr parts) + (cons (car parts) parts-acc)))) ; we keep this one + + ;; if we somehow eliminate all the cases (bogus expected + ;; type) fall back to the showing extra cases + (unzip4 (if (null? parts-acc) + orig + (reverse parts-acc))))))))))) + +(define (poly-fail f-stx args-stx t argtypes #:name [name #f] #:expected [expected #f]) (match t [(or (Poly-names: msg-vars @@ -92,13 +290,16 @@ "Could not infer types for applying polymorphic " fcn-string "\n")) - (tc-error/expr #:return (ret (Un)) - (string-append - "Polymorphic " fcn-string " could not be applied to arguments:~n" - (domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) - (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) - (string-append "Type Variables: " (stringify msg-vars) "\n") - "")))))] + (domain-mismatches f-stx args-stx t msg-doms msg-rests msg-drests + msg-rngs argtypes #f #f #:expected expected + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Polymorphic " fcn-string " could not be applied to arguments:\n" + dom + (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) + (string-append "Type Variables: " (stringify msg-vars) "\n") + ""))))))] [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...))) (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...)))) (let ([fcn-string (if name @@ -111,10 +312,13 @@ "Could not infer types for applying polymorphic " fcn-string "\n")) - (tc-error/expr #:return (ret (Un)) - (string-append - "Polymorphic " fcn-string " could not be applied to arguments:~n" - (domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected) - (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) - (string-append "Type Variables: " (stringify msg-vars) "\n") - "")))))])) + (domain-mismatches f-stx args-stx t msg-doms msg-rests msg-drests + msg-rngs argtypes #f #f #:expected expected + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Polymorphic " fcn-string " could not be applied to arguments:\n" + dom + (if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars))) + (string-append "Type Variables: " (stringify msg-vars) "\n") + ""))))))])) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 8102b6c1..a2a6b1df 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -5,7 +5,7 @@ "tc-app-helper.rkt" "find-annotation.rkt" "tc-funapp.rkt" "tc-subst.rkt" (prefix-in c: racket/contract) syntax/parse racket/match racket/trace scheme/list - unstable/sequence unstable/debug + unstable/sequence unstable/debug unstable/list ;; fixme - don't need to be bound in this phase - only to make tests work scheme/bool racket/unsafe/ops @@ -137,13 +137,19 @@ (match a [(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))]) (if (null? new-arities) - (tc-error/expr + (domain-mismatches + (car (syntax-e form)) (cdr (syntax-e form)) + arities doms rests drests rngs + (map tc-expr (syntax->list pos-args)) + #f #f #:expected expected #:return (or expected (ret (Un))) - (string-append "No function domains matched in function application:\n" - (domain-mismatches arities doms rests drests rngs (map tc-expr (syntax->list pos-args)) #f #f))) - (tc/funapp (car (syntax-e form)) kw-args - (ret (make-Function new-arities)) - (map tc-expr (syntax->list pos-args)) expected)))])) + #:msg-thunk + (lambda (dom) + (string-append "No function domains matched in function application:\n" + dom))) + (tc/funapp (car (syntax-e form)) kw-args + (ret (make-Function new-arities)) + (map tc-expr (syntax->list pos-args)) expected)))])) (define (type->list t) (match t @@ -173,7 +179,7 @@ (for ([n names] #:when (not (memq n tnames))) (tc-error/delayed - "unknown named argument ~a for class~nlegal named arguments are ~a" + "unknown named argument ~a for class\nlegal named arguments are ~a" n (stringify tnames))) (for-each (match-lambda [(list tname tfty opt?) @@ -195,7 +201,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; let loop -(define (let-loop-check form lp actuals args body expected) +(define (let-loop-check form lam lp actuals args body expected) (syntax-parse #`(#,args #,body #,actuals) #:literals (#%plain-app if null? pair? null) [((val acc ...) @@ -216,7 +222,7 @@ [t ann-ts]) (tc-expr/check a (ret t))) ;; then check that the function typechecks with the inferred types - (tc/rec-lambda/check form args body lp ts expected) + (add-typeof-expr lam (tc/rec-lambda/check form args body lp ts expected)) expected)] ;; special case `for/list' [((val acc ...) @@ -234,7 +240,7 @@ [(tc-result1: (and t (Listof: _))) t] [_ #f]) (generalize (-val '())))]) - (tc/rec-lambda/check form args body lp (cons acc-ty ts) expected) + (add-typeof-expr lam (tc/rec-lambda/check form args body lp (cons acc-ty ts) expected)) expected)] ;; special case when argument needs inference [(_ body* _) @@ -246,7 +252,7 @@ (begin (check-below (tc-expr/t ac) infer-t) infer-t) (generalize (tc-expr/t ac)))))]) - (tc/rec-lambda/check form args body lp ts expected) + (add-typeof-expr lam (tc/rec-lambda/check form args body lp ts expected)) expected)])) @@ -275,13 +281,15 @@ (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t) (loop (cddr args))]))))] ;; use the additional but normally ignored first argument to make-sequence to provide a better instantiation - [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for)) (~and quo ((~literal quote) (i:id))) arg:expr) - #:when (type-annotation #'i) + [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for)) (~and quo ((~literal quote) (i:id ...))) arg:expr) + #:when (andmap type-annotation (syntax->list #'(i ...))) (match (single-value #'op) [(tc-result1: (and t Poly?)) (tc-expr/check #'quo (ret Univ)) (tc/funapp #'op #'(quo arg) - (ret (instantiate-poly t (list (type-annotation #'i)))) + (ret (instantiate-poly t (extend (list Univ Univ) + (map type-annotation (syntax->list #'(i ...))) + Univ))) (list (ret Univ) (single-value #'arg)) expected)])] ;; unsafe struct operations @@ -565,11 +573,11 @@ [(tc-result1: t) (tc-error/expr #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match - [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) + [(#%plain-app (letrec-values ([(lp) (~and lam (#%plain-lambda args . body))]) lp*) . actuals) #:fail-unless expected #f #:fail-unless (not (andmap type-annotation (syntax->list #'(lp . args)))) #f #:fail-unless (free-identifier=? #'lp #'lp*) #f - (let-loop-check form #'lp #'actuals #'args #'body expected)] + (let-loop-check form #'lam #'lp #'actuals #'args #'body expected)] ;; special cases for classes [(#%plain-app make-object cl . args) (check-do-make-object #'cl #'args #'() #'())] @@ -623,25 +631,25 @@ ;; special case for `list' [(#%plain-app list . args) (begin - ;(printf "calling list: ~a ~a~n" (syntax->datum #'args) expected) + ;(printf "calling list: ~a ~a\n" (syntax->datum #'args) expected) (match expected [(tc-result1: (Mu: var (Union: (or (list (Pair: elem-ty (F: var)) (Value: '())) (list (Value: '()) (Pair: elem-ty (F: var))))))) - ;(printf "special case 1 ~a~n" elem-ty) + ;(printf "special case 1 ~a\n" elem-ty) (for ([i (in-list (syntax->list #'args))]) (tc-expr/check i (ret elem-ty))) expected] [(tc-result1: (app untuple (? (lambda (ts) (and ts (= (length (syntax->list #'args)) (length ts)))) ts))) - ;(printf "special case 2 ~a~n" ts) + ;(printf "special case 2 ~a\n" ts) (for ([ac (in-list (syntax->list #'args))] [exp (in-list ts)]) (tc-expr/check ac (ret exp))) expected] [_ - ;(printf "not special case~n") + ;(printf "not special case\n") (let ([tys (map tc-expr/t (syntax->list #'args))]) (ret (apply -lst* tys)))]))] ;; special case for `list*' @@ -699,7 +707,7 @@ dom) (Values: (list (Result: v (FilterSet: (Top:) (Top:)) (Empty:)))) #f #f (list (Keyword: _ _ #f) ...))))))) - ;(printf "f dom: ~a ~a~n" (syntax->datum #'f) dom) + ;(printf "f dom: ~a ~a\n" (syntax->datum #'f) dom) (let ([arg-tys (map (lambda (a t) (tc-expr/check a (ret t))) (syntax->list #'args) dom)]) diff --git a/collects/typed-scheme/typecheck/tc-apply.rkt b/collects/typed-scheme/typecheck/tc-apply.rkt index a28ef371..2c832ed0 100644 --- a/collects/typed-scheme/typecheck/tc-apply.rkt +++ b/collects/typed-scheme/typecheck/tc-apply.rkt @@ -40,21 +40,24 @@ (match f-ty ;; apply of simple function - [(tc-result1: (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...))) + [(tc-result1: (and t (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...)))) ;; special case for (case-lambda) (when (null? doms) (tc-error/expr #:return (ret (Un)) "empty case-lambda given as argument to apply")) - (match-let ([arg-tys (map tc-expr/t fixed-args)] - [(tc-result1: tail-ty) (single-value tail)]) + (match-let* ([arg-tres (map tc-expr fixed-args)] + [arg-tys (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] + [(tc-result1: tail-ty) (single-value tail)]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond ;; we've run out of cases to try, so error out [(null? doms*) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to function in apply:~n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty #f)))] + (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty #f + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to function in apply:\n" + dom)))] ;; this case of the function type has a rest argument [(and (car rests*) ;; check that the tail expression is a subtype of the rest argument @@ -76,7 +79,8 @@ [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] ;; apply of simple polymorphic function [(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] + (let*-values ([(arg-tres) (map tc-expr fixed-args)] + [(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] [(tail-ty tail-bound) (match (tc-expr/t tail) [(ListDots: tail-ty tail-bound) (values tail-ty tail-bound)] @@ -84,11 +88,13 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result1: (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to polymorphic function in apply:~n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] + [(tc-result1: (and t (Poly-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) + (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to polymorphic function in apply:\n" + dom)))])] ;; the actual work, when we have a * function and a list final argument [(and (car rests*) (not tail-bound) @@ -129,7 +135,8 @@ "Function has no cases")] [(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var)) (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] + (let*-values ([(arg-tres) (map tc-expr fixed-args)] + [(arg-tys) (map (match-lambda [(tc-result1: t _ _) t]) arg-tres)] [(tail-ty tail-bound) (match (tc-expr/t tail) [(ListDots: tail-ty tail-bound) (values tail-ty tail-bound)] @@ -138,11 +145,13 @@ (define (finish substitution) (do-ret (subst-all substitution (car rngs*)))) (cond [(null? doms*) (match f-ty - [(tc-result1: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1)))) - (tc-error/expr #:return (ret (Un)) - (string-append - "Bad arguments to polymorphic function in apply:~n" - (domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])] + [(tc-result1: (and t (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ..1))))) + (domain-mismatches f args t doms rests drests rngs arg-tres tail-ty tail-bound + #:return (ret (Un)) + #:msg-thunk (lambda (dom) + (string-append + "Bad arguments to polymorphic function in apply:\n" + dom)))])] ;; the actual work, when we have a * function and a list final argument [(and (car rests*) (not tail-bound) @@ -208,4 +217,4 @@ (tc-error/expr #:return (ret (Un)) "Function has no cases")] [(tc-result1: f-ty) (tc-error/expr #:return (ret (Un)) - "Type of argument to apply is not a function type: ~n~a" f-ty)])) + "Type of argument to apply is not a function type: \n~a" f-ty)])) diff --git a/collects/typed-scheme/typecheck/tc-envops.rkt b/collects/typed-scheme/typecheck/tc-envops.rkt index c7c59fb5..de799dc4 100644 --- a/collects/typed-scheme/typecheck/tc-envops.rkt +++ b/collects/typed-scheme/typecheck/tc-envops.rkt @@ -11,7 +11,7 @@ (types resolve) (only-in (env type-env-structs lexical-env) env? update-type/lexical env-map env-props replace-props) - scheme/contract scheme/match + scheme/contract racket/match mzlib/trace unstable/debug unstable/struct (typecheck tc-metafunctions) (for-syntax scheme/base)) @@ -72,7 +72,8 @@ ;; sets the flag box to #f if anything becomes (U) (d/c (env+ env fs flag) - (env? (listof Filter/c) (box/c #t). -> . env?) + (([e env?] [fs (listof Filter/c)] [bx (box/c boolean?)]) + #:pre (bx) (unbox bx) . ->i . [_ env?]) (define-values (props atoms) (combine-props fs (env-props env) flag)) (for/fold ([Γ (replace-props env (append atoms props))]) ([f atoms]) (match f @@ -85,4 +86,5 @@ x Γ)] [_ Γ]))) -(p/c [env+ (env? (listof Filter/c) (box/c #t). -> . env?)]) \ No newline at end of file +(p/c [env+ (([e env?] [fs (listof Filter/c)] [bx (box/c boolean?)]) + #:pre (bx) (unbox bx) . ->i . [_ env?])]) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index b5a2b2bc..e09a06d9 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -2,8 +2,7 @@ (require (rename-in "../utils/utils.rkt" [private private-in]) - syntax/kerncase mzlib/trace - scheme/match (prefix-in - scheme/contract) + racket/match (prefix-in - scheme/contract) "signatures.rkt" "tc-envops.rkt" "tc-metafunctions.rkt" "tc-subst.rkt" "check-below.rkt" "tc-funapp.rkt" (types utils convenience union subtype remove-intersect type-table filter-ops) @@ -22,6 +21,15 @@ (import tc-if^ tc-lambda^ tc-app^ tc-let^ check-subforms^) (export tc-expr^) +;; Is the number a fixnum on *all* the platforms Racket supports? This +;; works because Racket compiles only on 32+ bit systems. This check is +;; done at compile time to typecheck literals -- so use it instead of +;; `fixnum?' to avoid creating platform-dependent .zo files. +(define (portable-fixnum? n) + (and (exact-integer? n) + (< n (expt 2 31)) + (> n (- (expt 2 31))))) + ;; return the type of a literal value ;; scheme-value -> type (define (tc-literal v-stx [expected #f]) @@ -35,22 +43,23 @@ [i:boolean (-val (syntax-e #'i))] [i:identifier (-val (syntax-e #'i))] [0 -Zero] - [(~var i (3d (conjoin number? fixnum? positive?))) -PositiveFixnum] - [(~var i (3d (conjoin number? fixnum? negative?))) -NegativeFixnum] - [(~var i (3d (conjoin number? fixnum?))) -Fixnum] + [(~var i (3d (conjoin portable-fixnum? positive?))) -PositiveFixnum] + [(~var i (3d (conjoin portable-fixnum? negative?))) -NegativeFixnum] + [(~var i (3d (conjoin portable-fixnum?))) -Fixnum] [(~var i (3d exact-positive-integer?)) -ExactPositiveInteger] [(~var i (3d exact-nonnegative-integer?)) -ExactNonnegativeInteger] [(~var i (3d exact-integer?)) -Integer] [(~var i (3d (conjoin number? exact? rational?))) -ExactRational] - [(~var i (3d (conjoin inexact-real? + [(~var i (3d (conjoin flonum? (lambda (x) (or (positive? x) (zero? x))) (lambda (x) (not (eq? x -0.0)))))) -NonnegativeFlonum] - [(~var i (3d inexact-real?)) -Flonum] + [(~var i (3d flonum?)) -Flonum] [(~var i (3d real?)) -Real] - ;; a complex number can't have an inexact imaginary part and an exact real part - [(~var i (3d (conjoin number? (lambda (x) (inexact-real? (imag-part x)))))) - -InexactComplex] + ;; a complex number can't have a float imaginary part and an exact real part + [(~var i (3d (conjoin number? (lambda (x) (and (flonum? (imag-part x)) + (flonum? (real-part x))))))) + -FloatComplex] [(~var i (3d number?)) -Number] [i:str -String] [i:char -Char] @@ -115,12 +124,12 @@ [(and (Poly? ty) (not (= (length (syntax->list inst)) (Poly-n ty)))) (tc-error/expr #:return (Un) - "Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" + "Wrong number of type arguments to polymorphic type ~a:\nexpected: ~a\ngot: ~a" ty (Poly-n ty) (length (syntax->list inst)))] [(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty))))) ;; we can provide 0 arguments for the ... var (tc-error/expr #:return (Un) - "Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a" + "Wrong number of type arguments to polymorphic type ~a:\nexpected at least: ~a\ngot: ~a" ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))] [(PolyDots? ty) ;; In this case, we need to check the last thing. If it's a dotted var, then we need to @@ -134,7 +143,7 @@ (let* ([last-id (syntax-e last-id-stx)] [last-ty (extend-tvars (list last-id) (parse-type last-ty-stx))]) (instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id)) - (tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a" + (tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:\nexpected: ~a\ngot: ~a" ty (sub1 (PolyDots-n ty)) (length all-but-last)))] [_ (instantiate-poly ty (map parse-type (syntax->list inst)))]))] @@ -148,8 +157,9 @@ ;; typecheck an identifier ;; the identifier has variable effect -;; tc-id : identifier -> tc-result -(define (tc-id id) +;; tc-id : identifier -> tc-results +(d/c (tc-id id) + (--> identifier? tc-results?) (let* ([ty (lookup-type/lexical id)]) (ret ty (make-FilterSet (-not-filter (-val #f) id) @@ -158,7 +168,7 @@ ;; typecheck an expression, but throw away the effect ;; tc-expr/t : Expr -> Type -(define (tc-expr/t e) (match (tc-expr e) +(define (tc-expr/t e) (match (single-value e) [(tc-result1: t _ _) t] [t (int-err "tc-expr returned ~a, not a single tc-result, for ~a" t (syntax->datum e))])) @@ -207,9 +217,10 @@ t)])))) ;; tc-expr/check : syntax tc-results -> tc-results -(define (tc-expr/check/internal form expected) +(d/c (tc-expr/check/internal form expected) + (--> syntax? tc-results? tc-results?) (parameterize ([current-orig-stx form]) - ;(printf "form: ~a~n" (syntax-object->datum form)) + ;(printf "form: ~a\n" (syntax-object->datum form)) ;; the argument must be syntax (unless (syntax? form) (int-err "bad form input to tc-expr: ~a" form)) @@ -218,13 +229,14 @@ (lambda args (define te (apply ret args)) (check-below te expected))]) - (kernel-syntax-case* form #f - (letrec-syntaxes+values find-method/who) ;; letrec-syntaxes+values is not in kernel-syntax-case literals + (syntax-parse form + #:literal-sets (kernel-literals) + #:literals (find-method/who) [stx - (syntax-property form 'typechecker:with-handlers) + #:when (syntax-property form 'typechecker:with-handlers) (check-subforms/with-handlers/check form expected)] [stx - (syntax-property form 'typechecker:ignore-some) + #:when (syntax-property form 'typechecker:ignore-some) (let ([ty (check-subforms/ignore form)]) (unless ty (int-err "internal error: ignore-some")) @@ -242,15 +254,15 @@ (match-let* ([(tc-result1: id-t) (single-value #'id)] [(tc-result1: val-t) (single-value #'val)]) (unless (subtype val-t id-t) - (tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t)) + (tc-error/expr "Mutation only allowed with compatible types:\n~a is not a subtype of ~a" val-t id-t)) (ret -Void))] ;; top-level variable reference - occurs at top level [(#%top . id) (check-below (tc-id #'id) expected)] ;; weird [(#%variable-reference . _) - (tc-error/expr #:return (ret expected) "#%variable-reference is not supported by Typed Scheme")] + (tc-error/expr #:return (ret expected) "#%variable-reference is not supported by Typed Racket")] ;; identifiers - [x (identifier? #'x) + [x:identifier (check-below (tc-id #'x) expected)] ;; w-c-m [(with-continuation-mark e1 e2 e3) @@ -269,33 +281,33 @@ [(begin e . es) (tc-exprs/check (syntax->list #'(e . es)) expected)] [(begin0 e . es) (begin (tc-exprs/check (syntax->list #'es) Univ) - (tc-expr/check #'e expected))] + (tc-expr/check #'e expected))] ;; if [(if tst thn els) (tc/if-twoarm #'tst #'thn #'els expected)] ;; lambda [(#%plain-lambda formals . body) - (tc/lambda/check form #'(formals) #'(body) expected)] + (tc/lambda/check form #'(formals) #'(body) expected)] [(case-lambda [formals . body] ...) - (tc/lambda/check form #'(formals ...) #'(body ...) expected)] + (tc/lambda/check form #'(formals ...) #'(body ...) expected)] ;; send [(let-values (((_) meth)) - (let-values (((_ _) (#%plain-app find-method/who _ rcvr _))) + (let-values (((_ _) (~and find-app (#%plain-app find-method/who _ rcvr _)))) (#%plain-app _ _ args ...))) - (tc/send #'rcvr #'meth #'(args ...) expected)] + (tc/send #'find-app #'rcvr #'meth #'(args ...) expected)] ;; let [(let-values ([(name ...) expr] ...) . body) (tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)] [(letrec-values ([(name) expr]) name*) - (and (identifier? #'name*) (free-identifier=? #'name #'name*)) + #:when (and (identifier? #'name*) (free-identifier=? #'name #'name*)) (match expected [(tc-result1: t) (with-lexical-env/extend (list #'name) (list t) (tc-expr/check #'expr expected))] - [(tc-results: ts) + [(tc-results: ts) (tc-error/expr #:return (ret (Un)) "Expected ~a values, but got only 1" (length ts))])] [(letrec-values ([(name ...) expr] ...) . body) - (tc/letrec-values #'((name ...) ...) #'(expr ...) #'body form expected)] + (tc/letrec-values #'((name ...) ...) #'(expr ...) #'body form expected)] ;; other - [_ (tc-error/expr #:return (ret expected) "cannot typecheck unknown form : ~a~n" (syntax->datum form))] + [_ (tc-error/expr #:return (ret expected) "cannot typecheck unknown form : ~a\n" (syntax->datum form))] )))) ;; type check form in the current type environment @@ -306,17 +318,18 @@ ;; do the actual typechecking of form ;; internal-tc-expr : syntax -> Type (define (internal-tc-expr form) - (kernel-syntax-case* form #f - (letrec-syntaxes+values #%datum #%app lambda find-method/who) ;; letrec-syntaxes+values is not in kernel-syntax-case literals + (syntax-parse form + #:literal-sets (kernel-literals) + #:literals (#%app lambda find-method/who) ;; [stx - (syntax-property form 'typechecker:with-handlers) + #:when (syntax-property form 'typechecker:with-handlers) (let ([ty (check-subforms/with-handlers form)]) (unless ty (int-err "internal error: with-handlers")) ty)] [stx - (syntax-property form 'typechecker:ignore-some) + #:when (syntax-property form 'typechecker:ignore-some) (let ([ty (check-subforms/ignore form)]) (unless ty (int-err "internal error: ignore-some")) @@ -341,9 +354,9 @@ (tc/lambda form #'(formals ...) #'(body ...))] ;; send [(let-values (((_) meth)) - (let-values (((_ _) (#%plain-app find-method/who _ rcvr _))) + (let-values (((_ _) (~and find-app (#%plain-app find-method/who _ rcvr _)))) (#%plain-app _ _ args ...))) - (tc/send #'rcvr #'meth #'(args ...))] + (tc/send #'find-app #'rcvr #'meth #'(args ...))] ;; let [(let-values ([(name ...) expr] ...) . body) (tc/let-values #'((name ...) ...) #'(expr ...) #'body form)] @@ -354,7 +367,7 @@ (match-let* ([(tc-result1: id-t) (tc-expr #'id)] [(tc-result1: val-t) (tc-expr #'val)]) (unless (subtype val-t id-t) - (tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t)) + (tc-error/expr "Mutation only allowed with compatible types:\n~a is not a subtype of ~a" val-t id-t)) (ret -Void))] ;; top-level variable reference - occurs at top level [(#%top . id) (tc-id #'id)] @@ -362,9 +375,9 @@ [(#%expression e) (tc-expr #'e)] ;; weird [(#%variable-reference . _) - (tc-error/expr #:return (ret (Un)) "#%variable-reference is not supported by Typed Scheme")] + (tc-error/expr #:return (ret (Un)) "#%variable-reference is not supported by Typed Racket")] ;; identifiers - [x (identifier? #'x) (tc-id #'x)] + [x:identifier (tc-id #'x)] ;; application [(#%plain-app . _) (tc/app form)] ;; if @@ -383,10 +396,10 @@ (begin (tc-exprs (syntax->list #'es)) (tc-expr #'e))] ;; other - [_ (tc-error/expr #:return (ret (Un)) "cannot typecheck unknown form : ~a~n" (syntax->datum form))])) + [_ (tc-error/expr #:return (ret (Un)) "cannot typecheck unknown form : ~a\n" (syntax->datum form))])) (parameterize ([current-orig-stx form]) - ;(printf "form: ~a~n" (syntax->datum form)) + ;(printf "form: ~a\n" (syntax->datum form)) ;; the argument must be syntax (unless (syntax? form) (int-err "bad form input to tc-expr: ~a" form)) @@ -401,18 +414,21 @@ (add-typeof-expr form r) r)])))) -(define (tc/send rcvr method args [expected #f]) +(d/c (tc/send form rcvr method args [expected #f]) + (-->* (syntax? syntax? syntax? syntax?) ((-or/c tc-results? #f)) tc-results?) (match (tc-expr rcvr) [(tc-result1: (Instance: (and c (Class: _ _ methods)))) (match (tc-expr method) [(tc-result1: (Value: (? symbol? s))) (let* ([ftype (cond [(assq s methods) => cadr] [else (tc-error/expr "send: method ~a not understood by class ~a" s c)])] - [ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)]) - (if expected - (begin (check-below ret-ty expected) expected) - ret-ty))] - [(tc-result1: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])] + [ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)] + [retval (if expected + (begin (check-below ret-ty expected) expected) + ret-ty)]) + (add-typeof-expr form retval) + retval)] + [(tc-result1: t) (int-err "non-symbol methods not supported by Typed Racket: ~a" t)])] [(tc-result1: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~a" t)])) (define (single-value form [expected #f]) diff --git a/collects/typed-scheme/typecheck/tc-funapp.rkt b/collects/typed-scheme/typecheck/tc-funapp.rkt index 63f12298..48e5363e 100644 --- a/collects/typed-scheme/typecheck/tc-funapp.rkt +++ b/collects/typed-scheme/typecheck/tc-funapp.rkt @@ -3,13 +3,10 @@ (require (rename-in "../utils/utils.rkt" [infer r:infer]) "signatures.rkt" "tc-metafunctions.rkt" "tc-app-helper.rkt" "find-annotation.rkt" - "tc-subst.rkt" "check-below.rkt" (prefix-in c: racket/contract) - syntax/parse racket/match racket/list - unstable/sequence unstable/debug + syntax/parse racket/match racket/list ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy - racket/bool - racket/unsafe/ops + racket/bool racket/unsafe/ops (only-in racket/private/class-internal make-object do-make-object) (only-in '#%kernel [apply k:apply]) ;; end fixme @@ -17,9 +14,8 @@ (private type-annotation) (types utils abbrev union subtype resolve convenience type-table substitute) (utils tc-utils) - (only-in srfi/1 alist-delete) (except-in (env type-env-structs tvar-env index-env) extend) - (rep type-rep filter-rep object-rep rep-utils) + (rep type-rep filter-rep rep-utils) (r:infer infer) '#%paramz (for-template @@ -40,10 +36,10 @@ (let ([substitution (infer vars ... a)]) (and substitution (tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f)))) - (poly-fail t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) + (poly-fail f-stx args-stx t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) (d/c (tc/funapp f-stx args-stx ftype0 argtys expected) - (syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?) + (syntax? syntax? tc-results? (c:listof tc-results?) (c:or/c #f tc-results?) . c:-> . tc-results?) (match* (ftype0 argtys) ;; we special-case this (no case-lambda) for improved error messages [((tc-result1: (and t (Function: (list (and a (arr: dom (Values: _) rest #f kws)))))) argtys) @@ -58,10 +54,11 @@ ;; we call the separate function so that we get the appropriate filters/objects (tc/funapp1 f-stx args-stx a argtys expected #:check #f)) ;; if nothing matched, error - (tc-error/expr - #:return (or expected (ret (Un))) - (string-append "No function domains matched in function application:\n" - (domain-mismatches t doms rests drests rngs argtys-t #f #f))))] + (domain-mismatches f-stx args-stx t doms rests drests rngs argtys #f #f + #:expected expected #:return (or expected (ret (Un))) + #:msg-thunk (lambda (dom) + (string-append "No function domains matched in function application:\n" + dom))))] ;; any kind of dotted polymorphic function without mandatory keyword args [((tc-result1: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var)) @@ -130,41 +127,3 @@ [((tc-result1: f-ty) _) (tc-error/expr #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" f-ty)])) - - -;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? -(d/c (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) - ((syntax? syntax? arr? (c:listof tc-results?) (c:or/c #f tc-results?)) (#:check boolean?) . c:->* . tc-results?) - (match* (ftype0 argtys) - ;; we check that all kw args are optional - [((arr: dom (Values: (and results (list (Result: t-r f-r o-r) ...))) rest #f (and kws (list (Keyword: _ _ #f) ...))) - (list (tc-result1: t-a phi-a o-a) ...)) - (when check? - (cond [(and (not rest) (not (= (length dom) (length t-a)))) - (tc-error/expr #:return (ret t-r) - "Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))] - [(and rest (< (length t-a) (length dom))) - (tc-error/expr #:return (ret t-r) - "Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))]) - (for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] - [a (in-list (syntax->list args-stx))] - [arg-t (in-list t-a)]) - (parameterize ([current-orig-stx a]) (check-below arg-t dom-t)))) - (let* ([dom-count (length dom)] - [arg-count (+ dom-count (if rest 1 0) (length kws))]) - (let-values - ([(o-a t-a) (for/lists (os ts) - ([nm (in-range arg-count)] - [oa (in-sequence-forever (in-list o-a) (make-Empty))] - [ta (in-sequence-forever (in-list t-a) (Un))]) - (values (if (>= nm dom-count) (make-Empty) oa) - ta))]) - (define-values (t-r f-r o-r) - (for/lists (t-r f-r o-r) - ([r (in-list results)]) - (open-Result r o-a t-a))) - (ret t-r f-r o-r)))] - [((arr: _ _ _ drest '()) _) - (int-err "funapp with drest args ~a ~a NYI" drest argtys)] - [((arr: _ _ _ _ kws) _) - (int-err "funapp with keyword args ~a NYI" kws)])) diff --git a/collects/typed-scheme/typecheck/tc-if.rkt b/collects/typed-scheme/typecheck/tc-if.rkt index ce1bca7b..f897a9b0 100644 --- a/collects/typed-scheme/typecheck/tc-if.rkt +++ b/collects/typed-scheme/typecheck/tc-if.rkt @@ -50,18 +50,30 @@ [(tc-results: ts fs2 os2) (with-lexical-env env-thn (tc thn (unbox flag+)))] [(tc-results: us fs3 os3) (with-lexical-env env-els (tc els (unbox flag-)))]) ;(printf "old props: ~a\n" (env-props (lexical-env))) - ;(printf "fs+: ~a~n" fs+) - ;(printf "fs-: ~a~n" fs-) - ;(printf "thn-props: ~a~n" (env-props env-thn)) - ;(printf "els-props: ~a~n" (env-props env-els)) - ;(printf "new-thn-props: ~a~n" new-thn-props) - ;(printf "new-els-props: ~a~n" new-els-props) + ;(printf "fs+: ~a\n" fs+) + ;(printf "fs-: ~a\n" fs-) + ;(printf "thn-props: ~a\n" (env-props env-thn)) + ;(printf "els-props: ~a\n" (env-props env-els)) + ;(printf "new-thn-props: ~a\n" new-thn-props) + ;(printf "new-els-props: ~a\n" new-els-props) ;; record reachability - (when (not (unbox flag+)) - (add-contradiction tst)) - (when (not (unbox flag-)) - (add-tautology tst)) + ;; since we may typecheck a given piece of code multiple times in different + ;; contexts, we need to take previous results into account + (cond [(and (not (unbox flag+)) ; maybe contradiction + ;; to be an actual contradiction, we must have either previously + ;; recorded this test as a contradiction, or have never seen it + ;; before + (not (tautology? tst)) + (not (neither? tst))) + (add-contradiction tst)] + [(and (not (unbox flag-)) ; maybe tautology + ;; mirror case + (not (contradiction? tst)) + (not (neither? tst))) + (add-tautology tst)] + [else + (add-neither tst)]) ;; if we have the same number of values in both cases (cond [(= (length ts) (length us)) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt index b213cce5..de693f9c 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt @@ -16,7 +16,7 @@ (env type-env-structs lexical-env tvar-env index-env) (utils tc-utils) unstable/debug - scheme/match) + racket/match) (require (for-template scheme/base "internal-forms.rkt")) (import tc-expr^) @@ -251,7 +251,7 @@ ns))] [ty (extend-tvars tvars (maybe-loop form formals bodies (ret expected*)))]) - ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) + ;(printf "plambda: ~a ~a ~a \n" literal-tvars new-tvars ty) t)] [(tc-result1: (and t (PolyDots-names: (list ns ... dvar) expected*))) (let-values @@ -278,7 +278,7 @@ [tvars (let* ([ty (extend-tvars tvars (tc/mono-lambda/type formals bodies #f))]) - ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) + ;(printf "plambda: ~a ~a ~a \n" literal-tvars new-tvars ty) (make-Poly tvars ty))])] [(tc-result1: t) (unless (check-below (tc/plambda form formals bodies #f) t) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.rkt b/collects/typed-scheme/typecheck/tc-let-unit.rkt index cbd401cc..b2d2a7ff 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-let-unit.rkt @@ -1,24 +1,24 @@ #lang racket/unit -(require (rename-in "../utils/utils.rkt" [infer r:infer])) -(require "signatures.rkt" "tc-metafunctions.rkt" "tc-subst.rkt" +(require (rename-in "../utils/utils.rkt" [infer r:infer]) + "signatures.rkt" "tc-metafunctions.rkt" "tc-subst.rkt" "check-below.rkt" (types utils convenience) (private type-annotation parse-type) (env lexical-env type-alias-env global-env type-env-structs) (rep type-rep) syntax/free-vars - racket/trace unstable/debug + ;racket/trace unstable/debug racket/match (prefix-in c: racket/contract) (except-in racket/contract -> ->* one-of/c) - syntax/kerncase syntax/parse + syntax/kerncase syntax/parse unstable/syntax + unstable/debug (for-template racket/base "internal-forms.rkt")) (require (only-in srfi/1/list s:member)) - (import tc-expr^) (export tc-let^) @@ -27,46 +27,50 @@ [(tc-results: ts _ _) (ret ts (for/list ([f ts]) (make-NoFilter)) (for/list ([f ts]) (make-NoObject)))])) -(d/c (do-check expr->type namess results form exprs body clauses expected #:abstract [abstract null]) +(d/c (do-check expr->type namess results expected-results form exprs body clauses expected #:abstract [abstract null]) (((syntax? syntax? tc-results? . c:-> . any/c) (listof (listof identifier?)) (listof tc-results?) syntax? (listof syntax?) syntax? (listof syntax?) (or/c #f tc-results?)) (#:abstract any/c) . c:->* . tc-results?) - (w/c t/p ([types (listof (listof Type/c))] - [props (listof (listof Filter?))]) - (define-values (types props) - (for/lists (t p) - ([r (in-list results)] + (w/c t/p ([types (listof (listof Type/c))] ; types that may contain undefined (letrec) + [expected-types (listof (listof Type/c))] ; types that may not contain undefined (what we got from the user) + [props (listof (listof Filter?))]) + (define-values (types expected-types props) + (for/lists (t e p) + ([r (in-list results)] + [e-r (in-list expected-results)] [names (in-list namess)]) - (match r - [(tc-results: ts (FilterSet: fs+ fs-) os) - ;(printf "f+: ~a~n" fs+) - ;(printf "f-: ~a~n" fs-) + (match* (r e-r) + [((tc-results: ts (FilterSet: fs+ fs-) os) (tc-results: e-ts _ _)) ; rest should be the same + ;(printf "f+: ~a\n" fs+) + ;(printf "f-: ~a\n" fs-) (values ts + e-ts (apply append (for/list ([n names] [f+ fs+] [f- fs-]) (list (make-ImpFilter (-not-filter (-val #f) n) f+) (make-ImpFilter (-filter (-val #f) n) f-)))))] - [(tc-results: ts (NoFilter:) _) (values ts null)])))) + [((tc-results: ts (NoFilter:) _) (tc-results: e-ts (NoFilter:) _)) + (values ts e-ts null)])))) + (w/c append-region ([p1 (listof Filter?)] + [p2 (listof Filter?)]) + (define-values (p1 p2) + (combine-props (apply append props) (env-props (lexical-env)) (box #t)))) ;; extend the lexical environment for checking the body (with-lexical-env/extend/props ;; the list of lists of name namess ;; the types types - (w/c append-region - #:result (listof Filter?) - (define-values (p1 p2) - (combine-props (apply append props) (env-props (lexical-env)) (box #t))) - (append p1 p2)) + (append p1 p2) (for-each expr->type clauses exprs - results) + expected-results) (let ([subber (lambda (proc lst) (for/list ([i (in-list lst)]) (for/fold ([s i]) @@ -78,11 +82,20 @@ (ret (subber subst-type ts) (subber subst-filter-set fs) (subber subst-object os))] [(tc-results: ts fs os dt db) (ret (subber subst-type ts) (subber subst-filter-set fs) (subber subst-object os) dt db)])) - (if expected - (check-below - (run (tc-exprs/check (syntax->list body) (erase-filter expected))) - expected) - (run (tc-exprs (syntax->list body))))))) + (with-lexical-env/extend/props + ;; we typechecked the rhss with the lhss having types that potentially contain undefined + ;; if undefined can actually show up, a type error will have been triggered + ;; it is therefore safe to typecheck the body with the original types the user gave us + ;; any undefined-related problems have been caught already + namess + expected-types ; types w/o undefined + (append p1 p2) + ;; typecheck the body + (if expected + (check-below + (run (tc-exprs/check (syntax->list body) (erase-filter expected))) + expected) + (run (tc-exprs (syntax->list body)))))))) (define (tc-expr/maybe-expected/t e name) (define expecteds @@ -115,12 +128,12 @@ (let loop ([names names] [exprs exprs] [flat-names orig-flat-names] [clauses clauses]) (cond ;; after everything, check the body expressions - [(null? names) - (do-check void null null form null body null expected #:abstract orig-flat-names) - #; - (if expected (tc-exprs/check (syntax->list body) expected) (tc-exprs (syntax->list body)))] + [(null? names) + ;(if expected (tc-exprs/check (syntax->list body) expected) (tc-exprs (syntax->list body))) + (do-check void null null null form null body null expected #:abstract orig-flat-names)] ;; if none of the names bound in the letrec are free vars of this rhs - [(not (ormap (lambda (n) (s:member n flat-names bound-identifier=?)) (free-vars (car exprs)))) + [(not (ormap (lambda (n) (s:member n flat-names bound-identifier=?)) + (free-vars (car exprs)))) ;; then check this expression separately (with-lexical-env/extend (list (car names)) @@ -129,9 +142,72 @@ [(tc-results: ts) ts])) (loop (cdr names) (cdr exprs) (apply append (cdr names)) (cdr clauses)))] [else - ;(for-each (lambda (vs) (for-each (lambda (v) (printf/log "Letrec Var: ~a~n" (syntax-e v))) vs)) names) + ;(for-each (lambda (vs) (for-each (lambda (v) (printf/log "Letrec Var: ~a\n" (syntax-e v))) vs)) names) (do-check (lambda (stx e t) (tc-expr/check e t)) - names (map (λ (l) (ret (map get-type l))) names) form exprs body clauses expected)])))) + names + ;; compute set of variables that can't be undefined. see below. + (let-values + ([(safe-bindings _) + (for/fold ([safe-bindings '()] ; includes transitively-safe + [transitively-safe-bindings '()]) + ([names names] + [clause clauses]) + (case (safe-letrec-values-clause? clause transitively-safe-bindings flat-names) + ;; transitively safe -> safe to mention in a subsequent rhs + [(transitively-safe) (values (append names safe-bindings) + (append names transitively-safe-bindings))] + ;; safe -> safe by itself, but may not be safe to use in a subsequent rhs + [(safe) (values (append names safe-bindings) + transitively-safe-bindings)] + ;; unsafe -> could be undefined + [(unsafe) (values safe-bindings transitively-safe-bindings)]))]) + (map (λ (l) (let ([types-from-user (map get-type l)]) + (ret (if (andmap (λ (x) ; are all the lhs vars safe? + (s:member x safe-bindings bound-identifier=?)) + l) + types-from-user + (map (λ (x) (make-Union (list x -Undefined))) + types-from-user))))) + names)) + ;; types the user gave. check against that to error if we could get undefined + (map (λ (l) (ret (map get-type l))) names) + form exprs body clauses expected)])))) + +;; determines whether any of the variables bound in the given clause can have an undefined value +;; in this case, we cannot trust the type the user gave us and must union it with undefined +;; for example, the following code: +;; (letrec: ([x : Float x]) x) +;; should not typecheck with type Float, even though the user said so, because the actual value +;; is undefined. +;; this implements a conservative analysis. +;; we identify 3 kinds of bindings: +;; - safe bindings cannot be undefined +;; - transitively safe bindings are safe and can safely be used in subsequent rhss +;; - unsafe bindings may be undefined +;; x is transitively safe if for all its free variables, they are either transitively safe and +;; earlier in the letrec or they are bound outside the letrec +;; x is safe if it is transitively safe or if its rhs is a lambda +;; otherwise, x is unsafe +;; this function returns either 'transitively-safe, 'safe or 'unsafe +;; Note: In some cases (such as the example on the bottom of page 6 of Ghuloum and Dybvig's +;; Fixing Letrec (reloaded) paper), we are more conservative than a fully-connected component +;; based approach. On the other hand, our algorithm should cover most interesting cases and +;; is much simpler than Tarjan's. +(define (safe-letrec-values-clause? clause transitively-safe-bindings letrec-bound-ids) + (define clause-rhs + (syntax-parse clause + [(bindings . rhs) #'rhs])) + (cond [(andmap (lambda (fv) + (or (not (s:member fv letrec-bound-ids bound-identifier=?)) ; from outside + (s:member fv transitively-safe-bindings bound-identifier=?))) + (apply append + (syntax-map (lambda (x) (free-vars x)) + clause-rhs))) + 'transitively-safe] + [else + (syntax-parse clause-rhs #:literal-sets (kernel-literals) + [((#%plain-lambda _ ...)) 'safe] + [else 'unsafe])])) ;; this is so match can provide us with a syntax property to ;; say that this binding is only called in tail position @@ -158,6 +234,4 @@ tc-expr/check))] ;; the clauses for error reporting [clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])]) - (do-check void names types form exprs body clauses expected))) - - + (do-check void names types types form exprs body clauses expected))) diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.rkt b/collects/typed-scheme/typecheck/tc-metafunctions.rkt index 3e366341..e1fe75d9 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.rkt +++ b/collects/typed-scheme/typecheck/tc-metafunctions.rkt @@ -1,24 +1,15 @@ -#lang scheme/base +#lang racket/base -(require "../utils/utils.rkt") -(require (rename-in (types subtype convenience remove-intersect union utils filter-ops) +(require "../utils/utils.rkt" + (rename-in (types subtype convenience remove-intersect union utils filter-ops) [-> -->] [->* -->*] [one-of/c -one-of/c]) - (rep type-rep filter-rep rep-utils) scheme/list - scheme/contract scheme/match unstable/match scheme/trace - unstable/debug - (for-syntax scheme/base)) + (rep type-rep filter-rep rep-utils) racket/list + racket/contract racket/match unstable/match + (for-syntax racket/base)) -;; this implements the sequence invariant described on the first page relating to Bot - -(define (combine l1 l2) - (match* (l1 l2) - [(_ (Bot:)) (-FS -top -bot)] - [((Bot:) _) (-FS -bot -top)] - [(_ _) (-FS l1 l2)])) - -(provide combine abstract-results) +(provide abstract-results) (d/c (abstract-results results arg-names) @@ -52,8 +43,8 @@ (-> (listof identifier?) (listof name-ref/c) FilterSet/c FilterSet/c) (match fs [(FilterSet: f+ f-) - (combine (abo ids keys f+) (abo ids keys f-))] - [(NoFilter:) (combine -top -top)])) + (-FS (abo ids keys f+) (abo ids keys f-))] + [(NoFilter:) (-FS -top -top)])) (d/c (abo xs idxs f) ((listof identifier?) (listof name-ref/c) Filter/c . -> . Filter/c) @@ -77,7 +68,7 @@ (define (merge-filter-sets fs) (match fs [(list (FilterSet: f+ f-) ...) - (make-FilterSet (make-AndFilter f+) (make-AndFilter f-))])) + (-FS (make-AndFilter f+) (make-AndFilter f-))])) (define (tc-results->values tc) (match tc diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index c43bce64..7aa506ef 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -12,7 +12,7 @@ mzlib/trace unstable/debug racket/function - scheme/match + racket/match (only-in racket/contract listof any/c or/c [->* c->*] @@ -123,7 +123,9 @@ (make-fld t g setters?))] [flds (append parent-fields this-flds)] [sty (make-Struct name parent flds proc-ty poly? pred - (syntax-local-certifier) (or maker* maker))] + ;; this check is so that the tests work + (if (syntax-transforming?) (syntax-local-certifier) values) + (or maker* maker))] [external-fld-types/no-parent types] [external-fld-types (map fld-t flds)]) (if type-only @@ -211,7 +213,7 @@ ;; check and register types for a polymorphic define struct ;; tc/poly-struct : Listof[identifier] (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void -(define (tc/poly-struct vars nm/par flds tys #:maker [maker #f]) +(define (tc/poly-struct vars nm/par flds tys #:maker [maker #f] #:mutable [mutable #f]) ;; parent field types can't actually be determined here (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par)) ;; create type variables for the new type parameters @@ -236,6 +238,7 @@ ;; then register them (mk/register-sty nm flds parent-name parent-field-types types #:maker maker + #:mutable mutable ;; wrap everything in the approriate forall #:wrapper (λ (t) (make-Poly tvars t)) #:type-wrapper (λ (t) (make-App t new-tvars #f)) diff --git a/collects/typed-scheme/typecheck/tc-subst.rkt b/collects/typed-scheme/typecheck/tc-subst.rkt index 7f07fa6b..f784ba05 100644 --- a/collects/typed-scheme/typecheck/tc-subst.rkt +++ b/collects/typed-scheme/typecheck/tc-subst.rkt @@ -6,7 +6,7 @@ [->* -->*] [one-of/c -one-of/c]) (rep type-rep filter-rep rep-utils) scheme/list - scheme/contract scheme/match unstable/match unstable/debug + scheme/contract racket/match unstable/match unstable/debug (for-syntax scheme/base) "tc-metafunctions.rkt") @@ -33,8 +33,8 @@ [_ f])) (match fs [(FilterSet: f+ f-) - (combine (subst-filter (add-extra-filter f+) k o polarity) - (subst-filter (add-extra-filter f-) k o polarity))] + (-FS (subst-filter (add-extra-filter f+) k o polarity) + (subst-filter (add-extra-filter f-) k o polarity))] [_ (-FS -top -top)])) (d/c (subst-type t k o polarity) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index 5acdfdbb..13f5e842 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -4,7 +4,7 @@ syntax/kerncase unstable/list unstable/syntax syntax/parse unstable/debug mzlib/etc - scheme/match + racket/match "signatures.rkt" "tc-structs.rkt" "typechecker.rkt" @@ -97,17 +97,32 @@ (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m)] + [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) + #:maker m #:mutable)) + (#%plain-app values))) + (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) + #:maker #'m #:mutable #t)] [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:maker m)) (#%plain-app values))) (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m)] + [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) + #:maker m #:mutable)) + (#%plain-app values))) + (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) + #:maker #'m #:mutable #t)] [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only)) (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)] ;; define-typed-struct w/ polymorphism + [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:mutable)) (#%plain-app values))) + (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)] [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...))) (#%plain-app values))) - (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))] + (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))] + ;; error in other cases + [(define-values () (begin (quote-syntax (define-typed-struct-internal . _)) (#%plain-app values))) + (int-err "unknown structure form")] ;; executable structs - this is a big hack [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal nm ([fld : ty] ...) proc-ty)) (#%plain-app values))) @@ -293,7 +308,7 @@ (set! syntax-provide? #t)) (dict-set h #'in #'out)] [((~datum protect) . _) - (tc-error "provide: protect not supported by Typed Scheme")] + (tc-error "provide: protect not supported by Typed Racket")] [_ (int-err "unknown provide form")])))] [_ (int-err "non-provide form! ~a" (syntax->datum p))]))) ;; compute the new provides diff --git a/collects/typed-scheme/typed-reader.rkt b/collects/typed-scheme/typed-reader.rkt index 3313c542..810aa6e8 100644 --- a/collects/typed-scheme/typed-reader.rkt +++ b/collects/typed-scheme/typed-reader.rkt @@ -51,11 +51,13 @@ (let* ([prop-name (syntax-e (read-one))]) (skip-whitespace port) (syntax-property name prop-name (read-one)))] - ;; type annotation - [else (syntax-property name 'type-label (syntax->datum next))]))) + ;; otherwise error + [else + (let-values ([(l c p) (port-next-location port)]) + (raise-read-error (format "typed expression ~a must be followed by :, ::, or @" + (syntax->datum name)) src l c p 1))]))) (skip-whitespace port) (let ([c (read-char port)]) - #;(printf "char: ~a" c) (unless (equal? #\} c) (let-values ([(l c p) (port-next-location port)]) (raise-read-error (format "typed expression ~a not properly terminated" (syntax->datum name)) src l c p 1))))))) @@ -72,15 +74,15 @@ (let-values ([(l c p) (port-next-location port)]) (list src line col pos (and pos (- p pos)))))])) -(define readtable - (make-readtable #f #\{ 'dispatch-macro parse-id-type)) +(define (readtable) + (make-readtable (current-readtable) #\{ 'dispatch-macro parse-id-type)) (define (*read inp) - (parameterize ([current-readtable readtable]) + (parameterize ([current-readtable (readtable)]) (read inp))) (define (*read-syntax src port) - (parameterize ([current-readtable readtable]) + (parameterize ([current-readtable (readtable)]) (read-syntax src port))) (provide readtable (rename-out [*read read] [*read-syntax read-syntax])) diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 6063fdfa..9dc546c1 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -1,21 +1,12 @@ #lang racket/base -(require (rename-in "utils/utils.rkt" [infer r:infer]) - (private with-types) - (for-syntax - (except-in syntax/parse id) - racket/match unstable/syntax racket/base unstable/match - (private type-contract) - (optimizer optimizer) - (types utils convenience) - (typecheck typechecker provide-handling tc-toplevel) - (env type-name-env type-alias-env) - (r:infer infer) - (utils tc-utils) - (rep type-rep) - (except-in (utils utils) infer) - (only-in (r:infer infer-dummy) infer-param) - "tc-setup.rkt")) +(require (for-syntax racket/base + ;; these requires are needed since their code + ;; appears in the residual program + "typecheck/renamer.rkt" "types/type-table.rkt") + "private/base-special-env.rkt") + +(begin-for-syntax ) (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] @@ -25,54 +16,28 @@ with-type) (define-syntax (module-begin stx) - (syntax-parse stx - [(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...) - (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))]) - (parameterize ([optimize? (or (optimize?) (attribute opt?))]) - (tc-setup - stx pmb-form 'module-begin new-mod tc-module after-code - (with-syntax* - (;; pmb = #%plain-module-begin - [(pmb . body2) new-mod] - ;; add in syntax property on useless expression to draw check-syntax arrows - [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))] - ;; perform the provide transformation from [Culpepper 07] - [transformed-body (remove-provides #'body2)] - ;; add the real definitions of contracts on requires - [transformed-body (change-contract-fixups #'transformed-body)] - ;; potentially optimize the code based on the type information - [(optimized-body ...) - ;; do we optimize? - (if (optimize?) - (begin0 (map optimize-top (syntax->list #'transformed-body)) - (do-time "Optimized")) - #'transformed-body)]) - ;; reconstruct the module with the extra code - ;; use the regular %#module-begin from `racket/base' for top-level printing - #`(#%module-begin optimized-body ... #,after-code check-syntax-help)))))])) + (initialize-special) + ((dynamic-require 'typed-scheme/private/base-structs 'initialize-structs)) + ((dynamic-require 'typed-scheme/private/base-env-indexing 'initialize-indexing)) + ((dynamic-require 'typed-scheme/private/base-env 'init)) + ((dynamic-require 'typed-scheme/private/base-env-numeric 'init)) + ((dynamic-require 'typed-scheme/core 'mb-core) stx)) (define-syntax (top-interaction stx) - (syntax-parse stx - [(_ . ((~datum module) . rest)) - #'(module . rest)] - [(_ . form) - (tc-setup - stx #'form 'top-level body2 tc-toplevel-form type - (syntax-parse body2 - ;; any of these do not produce an expression to be printed - [(head:invis-kw . _) body2] - [_ (let ([ty-str (match type - ;; don't print results of type void - [(tc-result1: (== -Void type-equal?)) #f] - [(tc-result1: t f o) - (format "- : ~a\n" t)] - [(tc-results: t) - (format "- : ~a\n" (cons 'Values t))] - [x (int-err "bad type result: ~a" x)])]) - (if ty-str - #`(let ([type '#,ty-str]) - (begin0 #,body2 (display type))) - body2))]))])) + (initialize-special) + ((dynamic-require 'typed-scheme/private/base-structs 'initialize-structs)) + ((dynamic-require 'typed-scheme/private/base-env-indexing 'initialize-indexing)) + ((dynamic-require 'typed-scheme/private/base-env 'init)) + ((dynamic-require 'typed-scheme/private/base-env-numeric 'init)) + ((dynamic-require 'typed-scheme/core 'ti-core) stx)) + +(define-syntax (with-type stx) + (initialize-special) + ((dynamic-require 'typed-scheme/private/base-structs 'initialize-structs)) + ((dynamic-require 'typed-scheme/private/base-env-indexing 'initialize-indexing)) + ((dynamic-require 'typed-scheme/private/base-env 'init)) + ((dynamic-require 'typed-scheme/private/base-env-numeric 'init)) + ((dynamic-require 'typed-scheme/core 'wt-core) stx)) diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index a8203f4e..c76aa1ce 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -3,16 +3,14 @@ (require "../utils/utils.rkt") (require (rep type-rep object-rep filter-rep rep-utils) - #;"printer.rkt" "utils.rkt" "resolve.rkt" + "resolve.rkt" (utils tc-utils) - scheme/list - scheme/match - scheme/promise - scheme/flonum (except-in scheme/contract ->* ->) - unstable/syntax - (prefix-in c: scheme/contract) - (for-syntax scheme/base syntax/parse) - (for-template scheme/base scheme/contract scheme/promise scheme/tcp scheme/flonum)) + racket/list + racket/match + (except-in racket/contract ->* ->) + (prefix-in c: racket/contract) + (for-syntax racket/base syntax/parse) + (for-template racket/base racket/contract racket/promise racket/tcp racket/flonum)) (provide (all-defined-out) (rename-out [make-Listof -lst] @@ -29,6 +27,7 @@ (define -box make-Box) (define -channel make-Channel) (define -vec make-Vector) +(define -future make-Future) (define (-seq . args) (make-Sequence args)) (define-syntax *Un @@ -98,6 +97,7 @@ (define -Boolean (make-Base 'Boolean #'boolean?)) (define -Symbol (make-Base 'Symbol #'symbol?)) (define -Void (make-Base 'Void #'void?)) +(define -Undefined (make-Base 'Undefined #'(lambda (x) (equal? (letrec ([y y]) y) x)))) ; initial value of letrec bindings (define -Bytes (make-Base 'Bytes #'bytes?)) (define -Regexp (make-Base 'Regexp #'(and/c regexp? (not/c pregexp?) (not/c byte-regexp?)))) (define -PRegexp (make-Base 'PRegexp #'(and/c pregexp? (not/c byte-pregexp?)))) @@ -107,6 +107,10 @@ (define -Keyword (make-Base 'Keyword #'keyword?)) (define -Char (make-Base 'Char #'char?)) (define -Thread (make-Base 'Thread #'thread?)) +(define -Resolved-Module-Path (make-Base 'Resolved-Module-Path #'resolved-module-path?)) +(define -Module-Path (make-Base 'Module-Path #'module-path?)) +(define -Module-Path-Index (make-Base 'Module-Path-Index #'module-path-index?)) +(define -Compiled-Module-Expression (make-Base 'Compiled-Module-Expression #'compiled-module-expression?)) (define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag?)) (define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set?)) (define -Path (make-Base 'Path #'path?)) @@ -150,13 +154,20 @@ ;; Numeric hierarchy (define -Number (make-Base 'Number #'number?)) -;; a complex number can't have an inexact imaginary part and an exact real part -(define -InexactComplex (make-Base 'InexactComplex #'(and/c number? (lambda (x) (inexact-real? (imag-part x)))))) +(define -FloatComplex (make-Base 'Float-Complex + #'(and/c number? + (lambda (x) + (and (flonum? (imag-part x)) + (flonum? (real-part x))))))) -(define -Flonum (make-Base 'Flonum #'inexact-real?)) -(define -NonnegativeFlonum (make-Base 'Nonnegative-Flonum #'(and/c inexact-real? - (or/c positive? zero?) - (lambda (x) (not (eq? x -0.0)))))) +;; default 64-bit floats +(define -Flonum (make-Base 'Flonum #'flonum?)) +(define -NonnegativeFlonum (make-Base 'Nonnegative-Flonum + #'(and/c flonum? + (or/c positive? zero?) + (lambda (x) (not (eq? x -0.0)))))) +;; could be 32- or 64-bit floats +(define -InexactReal (make-Base 'Inexact-Real #'inexact-real?)) (define -ExactRational (make-Base 'Exact-Rational #'(and/c number? rational? exact?))) @@ -164,19 +175,21 @@ (define -ExactPositiveInteger (make-Base 'Exact-Positive-Integer #'exact-positive-integer?)) +;; We're generating a reference to fixnum? rather than calling it, so +;; we're safe from fixnum size issues on different platforms. (define -PositiveFixnum - (make-Base 'Positive-Fixnum #'(and/c number? fixnum? positive?))) + (make-Base 'Positive-Fixnum #'(and/c fixnum? positive?))) (define -NegativeFixnum - (make-Base 'Negative-Fixnum #'(and/c number? fixnum? negative?))) + (make-Base 'Negative-Fixnum #'(and/c fixnum? negative?))) (define -Zero (-val 0)) -(define -Real (*Un -Flonum -ExactRational)) +(define -Real (*Un -InexactReal -ExactRational)) (define -Fixnum (*Un -PositiveFixnum -NegativeFixnum -Zero)) (define -NonnegativeFixnum (*Un -PositiveFixnum -Zero)) (define -ExactNonnegativeInteger (*Un -ExactPositiveInteger -Zero)) (define -Nat -ExactNonnegativeInteger) -(define -Byte -Integer) +(define -Byte -NonnegativeFixnum) diff --git a/collects/typed-scheme/types/filter-ops.rkt b/collects/typed-scheme/types/filter-ops.rkt index 2d247537..d20a32f4 100644 --- a/collects/typed-scheme/types/filter-ops.rkt +++ b/collects/typed-scheme/types/filter-ops.rkt @@ -5,10 +5,10 @@ (utils tc-utils) (only-in (infer infer) restrict) "abbrev.rkt" (only-in scheme/contract current-blame-format [-> -->] listof) (types comparison printer union subtype utils remove-intersect) - scheme/list scheme/match scheme/promise + scheme/list racket/match scheme/promise (for-syntax syntax/parse scheme/base) unstable/debug syntax/id-table scheme/dict - scheme/trace + racket/trace (for-template scheme/base)) (provide (all-defined-out)) @@ -96,6 +96,13 @@ (loop (cdr props) others)] [p (loop (cdr props) (cons p others))])))) + +(define (-imp p1 p2) + (match* (p1 p2) + [((Bot:) _) -top] + [((Top:) _) p2] + [(_ _) (make-ImpFilter p1 p2)])) + (define (-or . args) (define mk (case-lambda [() -bot] diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 2569ab18..d92c6cc1 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -168,6 +168,7 @@ (fp " ~a" i)) (fp ")")] [(Box: e) (fp "(Boxof ~a)" e)] + [(Future: e) (fp "(Futureof ~a)" e)] [(Channel: e) (fp "(Channelof ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] [(Pair: l r) (fp "(Pairof ~a ~a)" l r)] @@ -186,7 +187,7 @@ #;[(Poly-unsafe: n b) (fp "(unsafe-poly ~a ~a ~a)" (Type-seq c) n b)] [(Poly-names: names body) - #;(fprintf (current-error-port) "POLY SEQ: ~a~n" (Type-seq body)) + #;(fprintf (current-error-port) "POLY SEQ: ~a\n" (Type-seq body)) (fp "(All ~a ~a)" names body)] #;[(PolyDots-unsafe: n b) (fp "(unsafe-polydots ~a ~a ~a)" (Type-seq c) n b)] [(PolyDots-names: (list names ... dotted) body) diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt index 64d55e8f..6b3855f0 100644 --- a/collects/typed-scheme/types/remove-intersect.rkt +++ b/collects/typed-scheme/types/remove-intersect.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" (rep type-rep rep-utils) (types union subtype resolve convenience utils) - scheme/match mzlib/trace unstable/debug) + racket/match mzlib/trace unstable/debug) (provide (rename-out [*remove remove]) overlap) @@ -28,6 +28,10 @@ (overlap (resolve-once t1) (resolve-once t2)))] [(list (? Mu?) _) (overlap (unfold t1) t2)] [(list _ (? Mu?)) (overlap t1 (unfold t2))] + + [(list (Refinement: t _ _) t2) (overlap t t2)] + [(list t1 (Refinement: t _ _)) (overlap t1 t)] + [(list (Union: e) t) (ormap (lambda (t*) (overlap t* t)) e)] [(list t (Union: e)) diff --git a/collects/typed-scheme/types/resolve.rkt b/collects/typed-scheme/types/resolve.rkt index 4a30c813..73767a04 100644 --- a/collects/typed-scheme/types/resolve.rkt +++ b/collects/typed-scheme/types/resolve.rkt @@ -5,7 +5,7 @@ (env type-name-env) (utils tc-utils) (types utils) - scheme/match + racket/match scheme/contract) (provide resolve-name resolve-app needs-resolving? resolve) @@ -34,7 +34,8 @@ [(Name: n) (when (and (current-poly-struct) (free-identifier=? n (poly-name (current-poly-struct))) - (not (andmap type-equal? rands (poly-vars (current-poly-struct))))) + (not (or (ormap Error? rands) + (andmap type-equal? rands (poly-vars (current-poly-struct)))))) (tc-error "Structure type constructor ~a applied to non-regular arguments ~a" rator rands)) (let ([r (resolve-name rator)]) (and r (resolve-app r rands stx)))] diff --git a/collects/typed-scheme/types/substitute.rkt b/collects/typed-scheme/types/substitute.rkt index a2957404..e5fcc5ab 100644 --- a/collects/typed-scheme/types/substitute.rkt +++ b/collects/typed-scheme/types/substitute.rkt @@ -5,20 +5,13 @@ (utils tc-utils) (only-in (rep free-variance) combine-frees) (env index-env tvar-env) - scheme/match + racket/match scheme/contract) (provide subst-all substitute substitute-dots substitute-dotted subst (struct-out t-subst) (struct-out i-subst) (struct-out i-subst/starred) (struct-out i-subst/dotted) substitution/c make-simple-substitution) -(define (subst v t e) (substitute t v e)) - -(d/c (make-simple-substitution vs ts) - (([vs (listof symbol?)] [ts (listof Type/c)]) () #:pre-cond (= (length vs) (length ts)) . ->d . [_ substitution/c]) - (for/hash ([v (in-list vs)] [t (in-list ts)]) - (values v (t-subst t)))) - (d-s/c subst-rhs () #:transparent) (d-s/c (t-subst subst-rhs) ([type Type/c]) #:transparent) (d-s/c (i-subst subst-rhs) ([types (listof Type/c)]) #:transparent) @@ -27,6 +20,16 @@ (define substitution/c (hash/c symbol? subst-rhs? #:immutable #t)) +(define (subst v t e) (substitute t v e)) + +(d/c (make-simple-substitution vs ts) + (([vs (listof symbol?)] [ts (listof Type/c)]) () + #:pre (vs ts) (= (length vs) (length ts)) + . ->i . [_ substitution/c]) + (for/hash ([v (in-list vs)] [t (in-list ts)]) + (values v (t-subst t)))) + + ;; substitute : Type Name Type -> Type (d/c (substitute image name target #:Un [Un (get-union-maker)]) ((Type/c symbol? Type?) (#:Un procedure?) . ->* . Type?) @@ -71,7 +74,7 @@ ;; We need to recur first, just to expand out any dotted usages of this. (let ([expanded (sb dty)]) (for/fold ([t (make-Value null)]) - ([img images]) + ([img (reverse images)]) (make-Pair (substitute img name expanded) t))) (make-ListDots (sb dty) dbound))] [#:ValuesDots types dty dbound diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index 6f946a89..a13328e3 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -1,15 +1,14 @@ -#lang scheme/base +#lang racket/base (require "../utils/utils.rkt" (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) (types utils comparison resolve abbrev substitute) (env type-name-env) (only-in (infer infer-dummy) unify) - scheme/match unstable/match - mzlib/trace (rename-in scheme/contract - [-> c->] - [->* c->*]) - (for-syntax scheme/base syntax/parse)) + racket/match unstable/match + (rename-in racket/contract + [-> c->] [->* c->*]) + (for-syntax racket/base syntax/parse)) ;; exn representing failure of subtyping ;; s,t both types @@ -234,9 +233,10 @@ ;; value types [((Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))] ;; now we encode the numeric hierarchy - bletch + [((Base: 'Integer _) (== -Real =t)) A0] [((Base: 'Integer _) (Base: 'Number _)) A0] + [((Base: 'Flonum _) (Base: 'Inexact-Real _)) A0] [((Base: 'Flonum _) (== -Real =t)) A0] - [((Base: 'Integer _) (== -Real =t)) A0] [((Base: 'Flonum _) (Base: 'Number _)) A0] [((Base: 'Exact-Rational _) (Base: 'Number _)) A0] [((Base: 'Integer _) (Base: 'Exact-Rational _)) A0] @@ -264,10 +264,13 @@ [((== -Fixnum =t) (Base: 'Integer _)) A0] [((Base: 'Nonnegative-Flonum _) (Base: 'Flonum _)) A0] - [((Base: 'Nonnegative-Flonum _) (Base: 'InexactComplex _)) A0] + [((Base: 'Nonnegative-Flonum _) (Base: 'Inexact-Real _)) A0] [((Base: 'Nonnegative-Flonum _) (Base: 'Number _)) A0] - [((Base: 'InexactComplex _) (Base: 'Number _)) A0] + [((Base: 'Inexact-Real _) (== -Real =t)) A0] + [((Base: 'Inexact-Real _) (Base: 'Number _)) A0] + + [((Base: 'Float-Complex _) (Base: 'Number _)) A0] ;; values are subtypes of their "type" @@ -275,7 +278,7 @@ [((Value: (and n (? number?) (? exact?) (? rational?))) (Base: 'Exact-Rational _)) A0] [((Value: (? exact-nonnegative-integer? n)) (== -Nat =t)) A0] [((Value: (? exact-positive-integer? n)) (Base: 'Exact-Positive-Integer _)) A0] - [((Value: (? inexact-real? n)) (Base: 'Flonum _)) A0] + [((Value: (? flonum? n)) (Base: 'Flonum _)) A0] [((Value: (? real? n)) (== -Real =t)) A0] [((Value: (? number? n)) (Base: 'Number _)) A0] @@ -378,7 +381,7 @@ [((Hashtable: _ _) (HashtableTop:)) A0] ;; subtyping on structs follows the declared hierarchy [((Struct: nm (? Type? parent) flds proc _ _ _ _) other) - ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other) + ;(printf "subtype - hierarchy : ~a ~a ~a\n" nm parent other) (subtype* A0 parent other)] ;; Promises are covariant [((Struct: (== promise-sym) _ (list t) _ _ _ _ _) (Struct: (== promise-sym) _ (list t*) _ _ _ _ _)) (subtype* A0 t t*)] @@ -393,6 +396,8 @@ ;; subtyping on other stuff [((Syntax: t) (Syntax: t*)) (subtype* A0 t t*)] + [((Future: t) (Future: t*)) + (subtype* A0 t t*)] [((Instance: t) (Instance: t*)) (subtype* A0 t t*)] [((Class: '() '() (list (and s (list names meths )) ...)) diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt index a4bb8890..43b1221a 100644 --- a/collects/typed-scheme/types/type-table.rkt +++ b/collects/typed-scheme/types/type-table.rkt @@ -1,8 +1,11 @@ -#lang scheme/base +#lang racket/base -(require unstable/debug scheme/contract "../utils/utils.rkt" syntax/id-table racket/dict racket/match - (rep type-rep object-rep) (only-in (types abbrev utils) tc-results?) (utils tc-utils) - (env init-envs) mzlib/pconvert) +(require racket/contract syntax/id-table racket/dict racket/match mzlib/pconvert + "../utils/utils.rkt" + (rep type-rep object-rep) + (only-in (types utils) tc-results?) + (utils tc-utils) + (env init-envs)) (define table (make-hasheq)) @@ -52,19 +55,20 @@ ;; keeps track of expressions that always evaluate to true or always evaluate ;; to false, so that the optimizer can eliminate dead code +;; 3 possible values: 'tautology 'contradiction 'neither (define tautology-contradiction-table (make-hasheq)) -(define-values (add-tautology add-contradiction) +(define-values (add-tautology add-contradiction add-neither) (let () (define ((mk t?) e) (when (optimize?) (hash-set! tautology-contradiction-table e t?))) - (values (mk #t) (mk #f)))) -(define-values (tautology? contradiction?) + (values (mk 'tautology) (mk 'contradiction) (mk 'neither)))) +(define-values (tautology? contradiction? neither?) (let () (define ((mk t?) e) (eq? t? (hash-ref tautology-contradiction-table e 'not-there))) - (values (mk #t) (mk #f)))) + (values (mk 'tautology) (mk 'contradiction) (mk 'neither)))) (p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)] [type-of (syntax? . -> . tc-results?)] @@ -76,5 +80,7 @@ [make-struct-table-code (-> syntax?)] [add-tautology (syntax? . -> . any/c)] [add-contradiction (syntax? . -> . any/c)] + [add-neither (syntax? . -> . any/c)] [tautology? (syntax? . -> . boolean?)] - [contradiction? (syntax? . -> . boolean?)]) + [contradiction? (syntax? . -> . boolean?)] + [neither? (syntax? . -> . boolean?)]) diff --git a/collects/typed-scheme/types/union.rkt b/collects/typed-scheme/types/union.rkt index 4452a8ec..e61c03c3 100644 --- a/collects/typed-scheme/types/union.rkt +++ b/collects/typed-scheme/types/union.rkt @@ -1,11 +1,10 @@ #lang scheme/base -(require "../utils/utils.rkt") - -(require (rep type-rep rep-utils) +(require "../utils/utils.rkt" + (rep type-rep rep-utils) (utils tc-utils) (types utils subtype abbrev printer comparison) - scheme/match mzlib/trace) + racket/match) (provide Un) diff --git a/collects/typed-scheme/types/utils.rkt b/collects/typed-scheme/types/utils.rkt index af9780bf..f81288a1 100644 --- a/collects/typed-scheme/types/utils.rkt +++ b/collects/typed-scheme/types/utils.rkt @@ -1,17 +1,15 @@ -#lang scheme/base +#lang racket/base -(require "../utils/utils.rkt") - -(require (rep type-rep filter-rep object-rep rep-utils) +(require "../utils/utils.rkt" + (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) "substitute.rkt" (only-in (rep free-variance) combine-frees) (env index-env tvar-env) - scheme/match - scheme/list - mzlib/trace - scheme/contract - (for-syntax scheme/base syntax/parse)) + racket/match + racket/list + racket/contract + (for-syntax racket/base syntax/parse)) (provide fv fv/list fi instantiate-poly @@ -137,16 +135,16 @@ (p/c [ret - (->d ([t (or/c Type/c (listof Type/c))]) - ([f (if (list? t) - (listof FilterSet/c) - FilterSet/c)] - [o (if (list? t) - (listof Object?) - Object?)] + (->i ([t (or/c Type/c (listof Type/c))]) + ([f (t) (if (list? t) + (listof FilterSet/c) + FilterSet/c)] + [o (t) (if (list? t) + (listof Object?) + Object?)] [dty Type/c] [dbound symbol?]) - [_ tc-results?])]) + [res tc-results?])]) (define (combine-results tcs) (match tcs @@ -173,7 +171,7 @@ (define (fv/list ts) (hash-map (combine-frees (map free-vars* ts)) (lambda (k v) k))) (define (tc-error/expr msg #:return [return (make-Union null)] #:stx [stx (current-orig-stx)] . rest) - (tc-error/delayed #:stx stx (apply format msg rest)) + (apply tc-error/delayed #:stx stx msg rest) return) ;; error for unbound variables diff --git a/collects/typed-scheme/utils/any-wrap.rkt b/collects/typed-scheme/utils/any-wrap.rkt index b1c63e0b..6bc2ae17 100644 --- a/collects/typed-scheme/utils/any-wrap.rkt +++ b/collects/typed-scheme/utils/any-wrap.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/match scheme/vector scheme/contract) +(require racket/match scheme/vector scheme/contract) (define-struct any-wrap (val) #:property prop:custom-write diff --git a/collects/typed-scheme/utils/require-contract.rkt b/collects/typed-scheme/utils/require-contract.rkt index 3c43b7e7..3e8b43d5 100644 --- a/collects/typed-scheme/utils/require-contract.rkt +++ b/collects/typed-scheme/utils/require-contract.rkt @@ -3,9 +3,7 @@ (require scheme/contract unstable/location (for-syntax scheme/base - syntax/kerncase syntax/parse - "../utils/tc-utils.rkt" (prefix-in tr: "../private/typed-renaming.rkt"))) (provide require/contract define-ignored) diff --git a/collects/typed-scheme/utils/tc-utils.rkt b/collects/typed-scheme/utils/tc-utils.rkt index 90a96e0f..97ddb2d3 100644 --- a/collects/typed-scheme/utils/tc-utils.rkt +++ b/collects/typed-scheme/utils/tc-utils.rkt @@ -1,15 +1,13 @@ #lang scheme/base #| -This file is for utilities that are only useful for Typed Scheme, but +This file is for utilities that are only useful for Typed Racket, but don't depend on any other portion of the system |# (provide (all-defined-out)) -(require "syntax-traversal.rkt" - "utils.rkt" racket/dict - syntax/parse (for-syntax scheme/base syntax/parse) scheme/match unstable/debug - (for-syntax unstable/syntax)) +(require "syntax-traversal.rkt" racket/dict + syntax/parse (for-syntax scheme/base syntax/parse) racket/match) ;; a parameter representing the original location of the syntax being currently checked (define current-orig-stx (make-parameter #'here)) @@ -54,15 +52,15 @@ don't depend on any other portion of the system (and (syntax-transforming?) (syntax-original? (syntax-local-introduce e))) #;(and (orig-module-stx) (eq? (debugf syntax-source-module e) (debugf syntax-source-module (orig-module-stx)))) #;(syntax-source-module stx)) - (log-message l 'warning (format "Typed Scheme has detected unreachable code: ~e" (syntax->datum (locate-stx e))) + (log-message l 'warning (format "Typed Racket has detected unreachable code: ~.s" (syntax->datum (locate-stx e))) e)))) (define (locate-stx stx) (define omodule (orig-module-stx)) (define emodule (expanded-module-stx)) - ;(printf "orig: ~a~n" (syntax-object->datum omodule)) - ;(printf "exp: ~a~n" (syntax-object->datum emodule)) - ;(printf "stx (locate): ~a~n" (syntax-object->datum stx)) + ;(printf "orig: ~a\n" (syntax-object->datum omodule)) + ;(printf "exp: ~a\n" (syntax-object->datum emodule)) + ;(printf "stx (locate): ~a\n" (syntax-object->datum stx)) (if (and (not (print-syntax?)) omodule emodule stx) (or (look-for-in-orig omodule emodule stx) stx) stx)) @@ -85,6 +83,7 @@ don't depend on any other portion of the system (define (reset!) (set! delayed-errors null)) (match (reverse delayed-errors) [(list) (void)] + ;; if there's only one, we don't need multiple-error handling [(list (struct err (msg stx))) (reset!) (raise-typecheck-error msg stx)] @@ -138,13 +137,12 @@ don't depend on any other portion of the system ;; raise an internal error - typechecker bug! (define (int-err msg . args) - (parameterize ([custom-printer #t]) - (raise (make-exn:fail:tc (string-append "Internal Typechecker Error: " - (apply format msg args) - (format "\nwhile typechecking\n~aoriginally\n~a" - (syntax->datum (current-orig-stx)) - (syntax->datum (locate-stx (current-orig-stx))))) - (current-continuation-marks))))) + (raise (make-exn:fail:tc (string-append "Internal Typechecker Error: " + (apply format msg args) + (format "\nwhile typechecking\n~aoriginally\n~a" + (syntax->datum (current-orig-stx)) + (syntax->datum (locate-stx (current-orig-stx))))) + (current-continuation-marks)))) (define-syntax (nyi stx) (syntax-case stx () @@ -168,8 +166,8 @@ don't depend on any other portion of the system #:transparent #:attributes (ty id) (pattern [nm:identifier ~! ty] - #:fail-unless (list? (identifier-template-binding #'nm)) "not a bound identifier" - #:with id #'#'nm) + #:fail-unless (list? ((if (= 1 (syntax-local-phase-level)) identifier-template-binding identifier-template-binding) #'nm)) "not a bound identifier" + #:with id #'(quote-syntax nm)) (pattern [e:expr ty] #:with id #'e)) (syntax-parse stx diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index afed7b55..47712145 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -1,14 +1,14 @@ -#lang scheme/base +#lang racket/base #| This file is for utilities that are of general interest, at least theoretically. |# -(require (for-syntax scheme/base syntax/parse scheme/string) - scheme/contract scheme/match scheme/require-syntax - scheme/provide-syntax mzlib/struct scheme/unit - scheme/pretty mzlib/pconvert syntax/parse) +(require (for-syntax racket/base syntax/parse racket/string) + racket/contract racket/require-syntax + racket/provide-syntax racket/unit + racket/pretty mzlib/pconvert syntax/parse) ;; to move to unstable (provide reverse-begin list-update list-set) @@ -19,14 +19,15 @@ at least theoretically. ;; timing start-timing do-time ;; logging - printf/log + printf/log show-input? ;; struct printing custom-printer define-struct/printer ;; provide macros rep utils typecheck infer env private types) -(define optimize? (make-parameter #f)) +(define optimize? (make-parameter #t)) (define-for-syntax enable-contracts? #f) +(define show-input? (make-parameter #f)) ;; fancy require syntax (define-syntax (define-requirer stx) @@ -114,7 +115,7 @@ at least theoretically. (when (last-time) (error #f "Timing already started")) (last-time (current-process-milliseconds)) - (printf "Starting ~a at ~a~n" msg (last-time)))]) + (printf "Starting ~a at ~a\n" msg (last-time)))]) (syntax-rules () [(_ msg) (begin @@ -124,7 +125,7 @@ at least theoretically. [old (last-time)] [diff (- t old)]) (last-time t) - (printf "Timing ~a at ~a@~a~n" msg diff t)))])) + (printf "Timing ~a at ~a@~a\n" msg diff t)))])) (values (lambda _ #'(void)) (lambda _ #'(void))))) ;; custom printing diff --git a/collects/typed/racket/base.rkt b/collects/typed/racket/base.rkt index b728ae5f..65d54324 100644 --- a/collects/typed/racket/base.rkt +++ b/collects/typed/racket/base.rkt @@ -2,7 +2,7 @@ -(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct) +(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*) (except typed-scheme/private/prims) (except typed-scheme/private/base-types) (except typed-scheme/private/base-types-extra)) @@ -10,13 +10,9 @@ #%top-interaction lambda #%app)) -(require typed-scheme/private/base-env - typed-scheme/private/base-special-env - typed-scheme/private/base-env-numeric - typed-scheme/private/base-env-indexing - typed-scheme/private/extra-procs +(require typed-scheme/private/extra-procs (for-syntax typed-scheme/private/base-types-extra)) (provide (rename-out [with-handlers: with-handlers] [define-type-alias define-type]) - assert with-type + assert defined? with-type for for* (for-syntax (all-from-out typed-scheme/private/base-types-extra))) diff --git a/collects/typed/scheme/base.rkt b/collects/typed/scheme/base.rkt index 2a751ed8..4c184c21 100644 --- a/collects/typed/scheme/base.rkt +++ b/collects/typed/scheme/base.rkt @@ -2,7 +2,7 @@ -(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct) +(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*) (except typed-scheme/private/prims) (except typed-scheme/private/base-types) (except typed-scheme/private/base-types-extra)) @@ -10,13 +10,9 @@ #%top-interaction lambda #%app)) -(require typed-scheme/private/base-env - typed-scheme/private/base-special-env - typed-scheme/private/base-env-numeric - typed-scheme/private/base-env-indexing - typed-scheme/private/extra-procs +(require typed-scheme/private/extra-procs (for-syntax typed-scheme/private/base-types-extra)) (provide (rename-out [with-handlers: with-handlers] [define-type-alias define-type]) - assert with-type + assert defined? with-type for for* (for-syntax (all-from-out typed-scheme/private/base-types-extra)))