From fcfd000fccecd1279730100f7aa6f83422181a3c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 7 Jun 2010 13:13:47 -0400 Subject: [PATCH 001/198] Properly handling immutable invariant structs. original commit: 7df8e3279396e7483a5645603726afa5424a071a --- .../typed-scheme/succeed/hari-vector-bug.rkt | 20 +++++++++++++++++++ .../typed-scheme/typecheck/tc-structs.rkt | 16 ++++++++++++--- .../typed-scheme/types/remove-intersect.rkt | 6 ++++++ 3 files changed, 39 insertions(+), 3 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/hari-vector-bug.rkt diff --git a/collects/tests/typed-scheme/succeed/hari-vector-bug.rkt b/collects/tests/typed-scheme/succeed/hari-vector-bug.rkt new file mode 100644 index 00000000..69bc7efd --- /dev/null +++ b/collects/tests/typed-scheme/succeed/hari-vector-bug.rkt @@ -0,0 +1,20 @@ +#lang typed/racket +(define-struct: (A) Base ([prevbase : (Block A)] + [elems : (Vectorof A)])) +(define-struct: Mt ()) + +(define-type-alias Block (All (A) (U Mt (Base A)))) + +(: get-base : (All (A) ((Block A) -> (Base A)))) +(define (get-base block) + (if (Mt? block) + (error "" 'get-base) + (make-Base (Base-prevbase block) + (Base-elems block)))) + +(: get-base2 : (All (A) ((Block A) -> (Base A)))) +(define (get-base2 block) + (if (Base? block) + (make-Base (Base-prevbase block) + (Base-elems block)) + (error "" 'get-base))) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index a6cc8330..f73d7844 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.rkt" - (rep type-rep) + (except-in (rep type-rep free-variance) Dotted) (private parse-type) (types convenience utils union resolve abbrev) (env type-env type-environments type-name-env) @@ -131,6 +131,16 @@ (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?)) ;; the type name that is used in all the types (define name (type-wrapper (make-Name nm))) + ;; is this structure covariant in *all* arguments? + (define covariant? (if (and setters? poly?) + #f + (if poly? + (for*/and ([var (in-list poly?)] + [t (in-list external-fld-types)]) + (let ([variance (hash-ref (free-vars* t) var Constant)]) + (or (eq? variance Constant) + (eq? variance Covariant)))) + #t))) ;; the list of names w/ types (define bindings (append @@ -140,7 +150,7 @@ (cons (or maker* maker) (wrapper (->* external-fld-types (if cret cret name)))) (cons (or pred* pred) - (make-pred-ty (if (and setters? poly?) + (make-pred-ty (if (not covariant?) (make-StructTop sty) (pred-wrapper name))))) (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) @@ -190,7 +200,7 @@ #:wrapper (lambda (t) (make-Poly tvars t)) #:type-wrapper (lambda (t) (make-App t new-tvars #f)) #:pred-wrapper (lambda (t) (subst-all (for/list ([t tvars]) (list t Univ)) t)) - #:poly? #t)) + #:poly? tvars)) ;; typecheck a non-polymophic struct and register the approriate types diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt index 6f21b58e..abf9e562 100644 --- a/collects/typed-scheme/types/remove-intersect.rkt +++ b/collects/typed-scheme/types/remove-intersect.rkt @@ -56,10 +56,16 @@ [(list (Struct: n _ flds _ _ _ _ _ _) (Struct: n _ flds* _ _ _ _ _ _)) (for/and ([f flds] [f* flds*]) (overlap f f*))] + [(list (Struct: n #f _ _ _ _ _ _ _) + (StructTop: (Struct: n #f _ _ _ _ _ _ _))) + #t] ;; n and n* must be different, so there's no overlap [(list (Struct: n #f flds _ _ _ _ _ _) (Struct: n* #f flds* _ _ _ _ _ _)) #f] + [(list (Struct: n #f flds _ _ _ _ _ _) + (StructTop: (Struct: n* #f flds* _ _ _ _ _ _))) + #f] [(list (Struct: n p flds _ _ _ _ _ _) (Struct: n* p* flds* _ _ _ _ _ _)) (and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))] From 2d28ab5f139bea9b862ee0dc219b742cce1848be Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 1 Jun 2010 18:31:05 -0400 Subject: [PATCH 002/198] Special-case (- x 1) for use in loops. original commit: 7f300a2c4f9d934522a3b3ba3d5c949b5bd075ed --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 5 +++++ collects/typed-scheme/typecheck/tc-app.rkt | 6 ++++++ 2 files changed, 11 insertions(+) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 74608a25..b1d8e540 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -802,6 +802,11 @@ (eq? 'r x) (eq? 's x))) (make-pred-ty (t:Un (-val 'q) (-val 'r) (-val 's)))] + [tc-e (let: ([x : Exact-Positive-Integer 1]) + (vector-ref #("a" "b") x) + (vector-ref #("a" "b") (sub1 x)) + (vector-ref #("a" "b") (- x 1))) + -String] ) (test-suite "check-type tests" diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 9afae1e2..44e9d45a 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -508,6 +508,12 @@ (tc-error/expr "expected ~a, but got ~a" t (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))) expected] [_ (int-err "bad expected: ~a" expected)])] + ;; special case for `-' used like `sub1' + [(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1))) + (match-let ([(tc-result1: t) (single-value #'v)]) + (if (subtype t -ExactPositiveInteger) + (ret -Nat) + (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)))] ;; call-with-values [(#%plain-app call-with-values prod con) (match (tc/funapp #'prod #'() (single-value #'prod) null #f) From 36854b7150f9525530f5006ec47997e4072326eb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 2 Jun 2010 10:26:31 -0400 Subject: [PATCH 003/198] Predicates for numeric comparisons. original commit: e44e454b9478e40f6cf00481bf23de27f2ee5b45 --- collects/typed-scheme/private/base-env-numeric.rkt | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 479e21bc..2c01762c 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -66,8 +66,15 @@ [= (->* (list N N) N B)] [>= real-comp] -[< real-comp] -[<= real-comp] +[< (cl->* + (-> -Nat -Integer B : (-FS (-filter -Pos 1) -top)) + (-> -Integer -Nat B : (-FS -top (-filter -Nat 0))) + (-> -Integer (-val 0) B : (-FS -top (-filter -Nat 0))) + real-comp)] +[<= (cl->* + (-> -Nat -Integer B : (-FS (-filter -Nat 1) -top)) + (-> -Pos -Integer B : (-FS (-filter -Pos 1) -top)) + real-comp)] [> real-comp] From f315f666d55f06da78db6048b29d8f660970841d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 8 Jun 2010 11:59:54 -0400 Subject: [PATCH 004/198] more precise type for `max' original commit: 0f4db44be3cbc42e0546b7b61ad1b18156cf6607 --- collects/typed-scheme/private/base-env-numeric.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 2c01762c..163115bf 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -89,7 +89,7 @@ (for/list ([t (list -ExactRational -Flonum -Real N)]) (->* (list t) t t)))] -[max (apply cl->* (for/list ([t all-num-types]) (->* (list t) t t)))] +[max (apply cl->* (->* (list -Pos) -Integer -Pos) (->* (list -Nat) -Integer -Nat) (for/list ([t all-num-types]) (->* (list t) t t)))] [min (apply cl->* (for/list ([t all-num-types]) (->* (list t) t t)))] From 2ddda6b00a6260f9947c03b9e540e0014f33110e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 8 Jun 2010 17:31:07 -0400 Subject: [PATCH 005/198] Support case-lambda with multiple branches with keyword arguments. original commit: 78832fe332fccfe7c533243c4e1f1c1d0e3753e4 --- collects/tests/typed-scheme/succeed/kw.rkt | 8 +++ collects/typed-scheme/private/base-env.rkt | 8 ++- collects/typed-scheme/typecheck/tc-app.rkt | 67 ++++++++++++++++------ 3 files changed, 64 insertions(+), 19 deletions(-) diff --git a/collects/tests/typed-scheme/succeed/kw.rkt b/collects/tests/typed-scheme/succeed/kw.rkt index 0d95c87c..a7a4ec81 100644 --- a/collects/tests/typed-scheme/succeed/kw.rkt +++ b/collects/tests/typed-scheme/succeed/kw.rkt @@ -4,3 +4,11 @@ (open-input-file "foo" #:mode 'binary) (open-input-file "foo" #:mode 'text) (open-input-file "foo")) + +((inst sort Real Real) (list 1 2 3) >) + +((inst sort Real Real) (list 1 2 3) #:key (λ: ([x : Real]) (/ 1 x)) >) + +((inst sort Real String) (list 1 2 3) #:key number->string stringstring stringstring ((-lst -Char) . -> . -String)] [string->list (-String . -> . (-lst -Char))] -[sort (-poly (a) ((-lst a) (a a . -> . B) . -> . (-lst a)))] +[sort (-poly (a b) (cl->* ((-lst a) (a a . -> . B) + #:cache-keys? B #f + . ->key . (-lst a)) + ((-lst a) (b b . -> . B) + #:key (a . -> . b) #t + #:cache-keys? B #f + . ->key . (-lst a))))] [find-system-path (Sym . -> . -Path)] [object-name (Univ . -> . Univ)] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 44e9d45a..8d9e9bb9 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -78,9 +78,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Keywords -(define (tc-keywords form arities kws kw-args pos-args expected) - (match arities - [(list (arr: dom rng rest #f ktys)) +(define (tc-keywords/internal arity kws kw-args error?) + (match arity + [(arr: dom rng rest #f ktys) ;; assumes that everything is in sorted order (let loop ([actual-kws kws] [actuals (map tc-expr/t (syntax->list kw-args))] @@ -89,28 +89,59 @@ [('() '()) (void)] [(_ '()) - (tc-error/expr #:return (ret (Un)) - "Unexpected keyword argument ~a" (car actual-kws))] + (if error? + (tc-error/expr #:return (ret (Un)) + "Unexpected keyword argument ~a" (car actual-kws)) + #f)] [('() (cons fst rst)) (match fst [(Keyword: k _ #t) - (tc-error/expr #:return (ret (Un)) - "Missing keyword argument ~a" k)] + (if error? + (tc-error/expr #:return (ret (Un)) + "Missing keyword argument ~a" k) + #f)] [_ (loop actual-kws actuals rst)])] [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) - (cond [(eq? k k*) ;; we have a match - (unless (subtype (car actuals) t) - (tc-error/delayed - "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" - t (car actuals) k)) - (loop kws-rest (cdr actuals) form-rest)] + (cond [(eq? k k*) ;; we have a match + (if (subtype (car actuals) t) + ;; success + (loop kws-rest (cdr actuals) form-rest) + ;; failure + (and error? + (tc-error/delayed + "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" + t (car actuals) k) + (loop kws-rest (cdr actuals) form-rest)))] [req? ;; this keyword argument was required - (tc-error/delayed "Missing keyword argument ~a" k*) - (loop kws-rest (cdr actuals) form-rest)] + (if error? + (begin (tc-error/delayed "Missing keyword argument ~a" k*) + (loop kws-rest (cdr actuals) form-rest)) + #f)] [else ;; otherwise, ignore this formal param, and continue - (loop actual-kws actuals form-rest)])])) - (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function (list (make-arr* dom rng #:rest rest)))) (map tc-expr (syntax->list pos-args)) expected)] - [_ (int-err "case-lambda w/ keywords not supported")])) + (loop actual-kws actuals form-rest)])]))])) + +(define (tc-keywords form arities kws kw-args pos-args expected) + (match arities + [(list (and a (arr: dom rng rest #f ktys))) + (tc-keywords/internal a kws kw-args #t) + (tc/funapp (car (syntax-e form)) kw-args + (ret (make-Function (list (make-arr* dom rng #:rest rest)))) + (map tc-expr (syntax->list pos-args)) expected)] + [(list (and a (arr: doms rngs rests (and drests #f) ktyss)) ...) + (let ([new-arities + (for/list ([a (in-list arities)] + ;; find all the arities where the keywords match + #:when (tc-keywords/internal a kws kw-args #f)) + (match a + [(arr: dom rng rest #f ktys) (make-arr* dom rng #:rest rest)]))]) + (if (null? new-arities) + (tc-error/expr + #: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)))])) (define (type->list t) (match t From e16c33e1a6fe13bd9992447f3b74f9fafb0f7fb8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 8 Jun 2010 19:30:10 -0400 Subject: [PATCH 006/198] Sequenceof type. - inferencing and subtyping relation with vectors, lists, etc - use in `make-sequence' - add tests original commit: 78023d08f99bd423a17e532b6ff9b1ded758b658 --- .../tests/typed-scheme/succeed/for-seq.rkt | 19 ++++++++++++++ collects/typed-scheme/infer/infer-unit.rkt | 25 ++++++++++++++++++- .../typed-scheme/private/base-special-env.rkt | 2 ++ .../typed-scheme/private/base-types-new.rkt | 1 + collects/typed-scheme/rep/type-rep.rkt | 7 ++++++ collects/typed-scheme/types/abbrev.rkt | 1 + collects/typed-scheme/types/printer.rkt | 4 +++ collects/typed-scheme/types/subtype.rkt | 21 +++++++++++++++- 8 files changed, 78 insertions(+), 2 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/for-seq.rkt diff --git a/collects/tests/typed-scheme/succeed/for-seq.rkt b/collects/tests/typed-scheme/succeed/for-seq.rkt new file mode 100644 index 00000000..a5e11bea --- /dev/null +++ b/collects/tests/typed-scheme/succeed/for-seq.rkt @@ -0,0 +1,19 @@ +#lang typed/racket + +(: Approximate (Natural -> Void)) +(define (Approximate n) ; works + (for: : Void ([i : Integer (in-range 10)]) + (display i))) + +(for: : Void ((i : Integer (ann '(1 2 3) (Sequenceof Integer))) ; doesn't + (j : Char "abc")) + (display (list i j))) + + +(for: : Void ; doesn't + ([from-to : (List Symbol Symbol) + (ann '([a t] [c g]) (Sequenceof (List Symbol Symbol)))]) + #t) + + +(for/list: : (Listof Integer) ([i : Integer (in-range 10)]) i) ; works diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 165bcdc3..d45d75d3 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -341,6 +341,29 @@ (fail! S T))] [((Pair: a b) (Pair: a* b*)) (cset-meet (cg a a*) (cg b b*))] + ;; sequences are covariant + [((Sequence: ts) (Sequence: ts*)) + (cgen/list V X ts ts*)] + [((Listof: t) (Sequence: (list t*))) + (cg t t*)] + [((List: ts) (Sequence: (list t*))) + (cset-meet* (for/list ([t (in-list ts)]) + (cg t t*)))] + [((HeterogenousVector: ts) (Sequence: (list t*))) + (cset-meet* (for/list ([t (in-list ts)]) + (cg t t*)))] + [((Vector: t) (Sequence: (list t*))) + (cg t t*)] + [((Base: 'String _) (Sequence: (list t*))) + (cg -Char t*)] + [((Base: 'Bytes _) (Sequence: (list t*))) + (cg -Nat t*)] + [((Base: 'Input-Port _) (Sequence: (list t*))) + (cg -Nat t*)] + [((Vector: t) (Sequence: (list t*))) + (cg t t*)] + [((Hashtable: k v) (Sequence: (list k* v*))) + (cgen/list V X (list k v) (list k* v*))] ;; if we have two mu's, we rename them to have the same variable ;; and then compare the bodies [((Mu-unsafe: s) (Mu-unsafe: t)) @@ -386,7 +409,7 @@ (move-vars-to-dmap new-cset dbound vars))] [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound)) (when (memq dbound X) (fail! ss ts)) - (cgen/list V X (cons s-dty ss) (cons t-dty ts))] + (cgen/list V X (cons s-dty ss) (cons t-dty ts))] [((Vector: e) (Vector: e*)) (cset-meet (cg e e*) (cg e* e))] [((Box: e) (Box: e*)) diff --git a/collects/typed-scheme/private/base-special-env.rkt b/collects/typed-scheme/private/base-special-env.rkt index 6575c55f..c4933663 100644 --- a/collects/typed-scheme/private/base-special-env.rkt +++ b/collects/typed-scheme/private/base-special-env.rkt @@ -160,6 +160,8 @@ (-> 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)) diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types-new.rkt index 98d22dec..84e29ede 100644 --- a/collects/typed-scheme/private/base-types-new.rkt +++ b/collects/typed-scheme/private/base-types-new.rkt @@ -50,4 +50,5 @@ [Nothing (Un)] [Pairof (-poly (a b) (-pair a b))] [MPairof (-poly (a b) (-mpair a b))] +[Sequenceof (-poly (a) (-seq a))] diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 4a076230..49cf247a 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -335,6 +335,13 @@ ;; cls : Class (dt Instance ([cls Type/c]) [#:key 'instance]) +;; sequences +;; includes lists, vectors, etc +;; tys : sequence produces this set of values at each step +(dt Sequence ([tys (listof Type/c)]) + [#:frees (λ (f) (combine-frees (map f tys)))] + [#:key #f] [#:fold-rhs (*Sequence (map type-rec-id tys))]) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Ugly hack - should use units diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 43bcdbbe..9585f9d4 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -27,6 +27,7 @@ (define -Param make-Param) (define -box make-Box) (define -vec make-Vector) +(define (-seq . args) (make-Sequence args)) (define-syntax *Un (syntax-rules () diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index ba991333..2b0d2c0b 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -211,6 +211,10 @@ [(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)] [(Refinement: parent p? _) (fp "(Refinement ~a ~a)" parent (syntax-e p?))] + [(Sequence: ts) + (fp "(Sequenceof") + (for ([t ts]) (fp " ~a" t)) + (fp ")")] [(Error:) (fp "Error")] [else (fp "(Unknown Type: ~a)" (struct->vector c))] )) diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index 9cb832da..ccaaf720 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -256,7 +256,26 @@ [((Value: (? symbol? n)) (Base: 'Symbol _)) A0] [((Value: (? string? n)) (Base: 'String _)) A0] ;; tvars are equal if they are the same variable - [((F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))] + [((F: t) (F: t*)) (if (eq? t t*) A0 (fail! s t))] + ;; sequences are covariant + [((Sequence: ts) (Sequence: ts*)) + (subtypes* A0 ts ts*)] + [((Listof: t) (Sequence: (list t*))) + (subtype* A0 t t*)] + [((List: ts) (Sequence: (list t*))) + (subtypes* A0 ts (map (λ _ t*) ts))] + [((HeterogenousVector: ts) (Sequence: (list t*))) + (subtypes* A0 ts (map (λ _ t*) ts))] + [((Vector: t) (Sequence: (list t*))) + (subtype* A0 t t*)] + [((Base: 'String _) (Sequence: (list t*))) + (subtype* A0 -Char t*)] + [((Base: 'Bytes _) (Sequence: (list t*))) + (subtype* A0 -Nat t*)] + [((Base: 'Input-Port _) (Sequence: (list t*))) + (subtype* A0 -Nat t*)] + [((Hashtable: k v) (Sequence: (list k* v*))) + (subtypes* A0 (list k v) (list k* v*))] ;; special-case for case-lambda/union [((Function: arr1) (Function: (list arr2))) (when (null? arr1) (fail! s t)) From 4347da736b2e56ccde75606d2e62858c5afa1b25 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 9 Jun 2010 12:20:39 -0400 Subject: [PATCH 007/198] document `assert' original commit: ed5b10afd20f455964445a6eee56a0142bdc2167 --- .../scribblings/ts-reference.scrbl | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index e3ef9417..86b1680d 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -8,6 +8,8 @@ @(define the-eval (make-base-eval)) @(the-eval '(require (except-in typed/racket #%top-interaction #%module-begin))) +@(define the-top-eval (make-base-eval)) +@(the-top-eval '(require (except-in typed/racket #%module-begin))) @title[#:tag "top"]{The Typed Racket Reference} @@ -27,6 +29,7 @@ @defidform[Natural] @defidform[Exact-Positive-Integer] @defidform[Exact-Nonnegative-Integer] +@defidform[Exact-Rational] @defidform[Boolean] @defidform[True] @defidform[False] @@ -379,6 +382,28 @@ Other libraries can be used with Typed Racket via (check-version) ] +@section{Utilities} + +Typed Racket provides some additional utility functions to facilitate typed programming. + +@defproc*[ +([(assert [v (U #f A)]) A] + [(assert [v A] [p? (A -> Any : B)]) B])]{ +Verifies that the argument satisfies the constraint. If no predicate +is provided, simply checks that the value is not +@racket[#f]. +} + +@examples[#:eval the-top-eval +(define: x : (U #f Number) (string->number "7")) +x +(assert x) +(define: y : (U String Number) 0) +y +(assert y number?) +(assert y boolean?)] + + @section{Typed Racket Syntax Without Type Checking} @defmodulelang[typed-scheme/no-check] From ee7d9e61dd0428f6bf1c74a10ed4420fcbdf7768 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 9 Jun 2010 12:51:27 -0400 Subject: [PATCH 008/198] typed/racket/no-check original commit: 30fe053f7842c14bf0e0471a69b3105f41903bee --- collects/typed-scheme/no-check/lang/reader.rkt | 2 +- .../typed-scheme/scribblings/ts-reference.scrbl | 13 ++++++++----- collects/typed/racket/base/no-check.rkt | 4 ++++ collects/typed/racket/base/no-check/lang/reader.rkt | 8 ++++++++ collects/typed/racket/no-check.rkt | 4 ++++ collects/typed/racket/no-check/lang/reader.rkt | 8 ++++++++ 6 files changed, 33 insertions(+), 6 deletions(-) create mode 100644 collects/typed/racket/base/no-check.rkt create mode 100644 collects/typed/racket/base/no-check/lang/reader.rkt create mode 100644 collects/typed/racket/no-check.rkt create mode 100644 collects/typed/racket/no-check/lang/reader.rkt diff --git a/collects/typed-scheme/no-check/lang/reader.rkt b/collects/typed-scheme/no-check/lang/reader.rkt index c8265194..9448bbaf 100644 --- a/collects/typed-scheme/no-check/lang/reader.rkt +++ b/collects/typed-scheme/no-check/lang/reader.rkt @@ -5,4 +5,4 @@ typed-scheme/no-check #:read r:read #:read-syntax r:read-syntax -(require (prefix-in r: "../../typed-reader.ss")) +(require (prefix-in r: typed-scheme/typed-reader)) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 86b1680d..da763578 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -406,16 +406,19 @@ y @section{Typed Racket Syntax Without Type Checking} -@defmodulelang[typed-scheme/no-check] +@defmodulelang*[(typed/racket/no-check + typed/racket/base/no-check)] On occasions where the Typed Racket syntax is useful, but actual -typechecking is not desired, the @racketmodname[typed-scheme/no-check] -language is useful. It provides the same bindings and syntax as Typed -Racket, but does no type checking. +typechecking is not desired, the @racketmodname[typed/racket/no-check] +and @racketmodname[typed/racket/base/no-check] languages are useful. +They provide the same bindings and syntax as +@racketmodname[typed/racket] and @racketmodname[typed/racket/base], +but do no type checking. Examples: -@racketmod[typed-scheme/no-check +@racketmod[typed/racket/no-check (: x Number) (define x "not-a-number")] diff --git a/collects/typed/racket/base/no-check.rkt b/collects/typed/racket/base/no-check.rkt new file mode 100644 index 00000000..755a07f3 --- /dev/null +++ b/collects/typed/racket/base/no-check.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(require racket/require typed-scheme/no-check (subtract-in typed/racket/base typed-scheme/no-check)) +(provide (all-from-out typed/racket/base typed-scheme/no-check)) \ No newline at end of file diff --git a/collects/typed/racket/base/no-check/lang/reader.rkt b/collects/typed/racket/base/no-check/lang/reader.rkt new file mode 100644 index 00000000..af4b238d --- /dev/null +++ b/collects/typed/racket/base/no-check/lang/reader.rkt @@ -0,0 +1,8 @@ +#lang s-exp syntax/module-reader + +typed/racket/base/no-check + +#:read r:read +#:read-syntax r:read-syntax + +(require (prefix-in r: typed-scheme/typed-reader)) diff --git a/collects/typed/racket/no-check.rkt b/collects/typed/racket/no-check.rkt new file mode 100644 index 00000000..eb8a3c78 --- /dev/null +++ b/collects/typed/racket/no-check.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(require racket/require typed-scheme/no-check (subtract-in typed/racket typed-scheme/no-check)) +(provide (all-from-out typed/racket typed-scheme/no-check)) \ No newline at end of file diff --git a/collects/typed/racket/no-check/lang/reader.rkt b/collects/typed/racket/no-check/lang/reader.rkt new file mode 100644 index 00000000..7d16e804 --- /dev/null +++ b/collects/typed/racket/no-check/lang/reader.rkt @@ -0,0 +1,8 @@ +#lang s-exp syntax/module-reader + +typed/racket/no-check + +#:read r:read +#:read-syntax r:read-syntax + +(require (prefix-in r: typed-scheme/typed-reader)) From e0219a6f8f24e0701d366ae6f1b195913c72c6f0 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 9 Jun 2010 11:41:58 -0400 Subject: [PATCH 009/198] Modified the for: macros to use sequence types. original commit: 0741b48c99e190a31365c2fe2f2cd927d9561bb2 --- collects/tests/typed-scheme/succeed/for.rkt | 40 +++++++++---------- .../typed-scheme/xfail/for-inference.rkt | 20 ++++++++++ collects/typed-scheme/private/for-clauses.rkt | 25 +++++++++--- collects/typed-scheme/private/prims.rkt | 15 +++++-- 4 files changed, 72 insertions(+), 28 deletions(-) diff --git a/collects/tests/typed-scheme/succeed/for.rkt b/collects/tests/typed-scheme/succeed/for.rkt index cdd22c1c..5569e268 100644 --- a/collects/tests/typed-scheme/succeed/for.rkt +++ b/collects/tests/typed-scheme/succeed/for.rkt @@ -18,7 +18,7 @@ (with-output-to-string (lambda () (for: : Void - ((i : Exact-Positive-Integer '(1 2 3)) + ((i : Integer '(1 2 3)) (j : Char "abc") #:when (odd? i) (k : True #(#t #t)) @@ -32,22 +32,22 @@ (check equal? (for/list: : (Listof Integer) - ((i : Exact-Positive-Integer '(1 2 3)) - (j : Exact-Positive-Integer '(10 20 30)) + ((i : Integer '(1 2 3)) + (j : Integer '(10 20 30)) #:when (odd? i)) (+ i j 10)) '(21 43)) (check equal? (for/or: : Boolean - ((i : Exact-Positive-Integer '(1 2 3))) + ((i : Integer '(1 2 3))) (>= i 3)) #t) (check equal? (for/or: : Boolean - ((i : Exact-Positive-Integer '(1 2 3)) - (j : Exact-Positive-Integer '(2 1 3))) + ((i : Integer '(1 2 3)) + (j : Integer '(2 1 3))) (>= i j)) #t) @@ -56,9 +56,9 @@ (for/lists: : (values (Listof Integer) (Listof Integer)) ((x : (Listof Integer)) (y : (Listof Integer))) - ((i : Exact-Positive-Integer '(1 2 3)) + ((i : Integer '(1 2 3)) #:when #t - (j : Exact-Positive-Integer '(10 20 30)) + (j : Integer '(10 20 30)) #:when (> j 12)) (values i j))]) (append x y)) @@ -67,19 +67,19 @@ (check = (for/fold: : Integer ((acc : Integer 0)) - ((i : Exact-Positive-Integer '(1 2 3)) - (j : Exact-Positive-Integer '(10 20 30))) + ((i : Integer '(1 2 3)) + (j : Integer '(10 20 30))) (+ acc i j)) 66) (check = (for/fold: : Integer ((acc : Integer 0)) - ((i : Exact-Positive-Integer '(1 2 3)) + ((i : Integer '(1 2 3)) #:when (even? i) - (j : Exact-Positive-Integer '(10 20 30)) + (j : Integer '(10 20 30)) #:when #t - (k : Exact-Positive-Integer '(100 200 300))) + (k : Integer '(100 200 300))) (+ acc i j k)) 1998) @@ -87,8 +87,8 @@ (with-output-to-string (lambda () (for*: : Void - ((i : Exact-Positive-Integer '(1 2 3)) - (j : Exact-Positive-Integer '(10 20 30))) + ((i : Integer '(1 2 3)) + (j : Integer '(10 20 30))) (display (list i j))))) "(1 10)(1 20)(1 30)(2 10)(2 20)(2 30)(3 10)(3 20)(3 30)") @@ -97,8 +97,8 @@ (for*/lists: : (values (Listof Integer) (Listof Integer)) ((x : (Listof Integer)) (y : (Listof Integer))) - ((i : Exact-Positive-Integer '(1 2 3)) - (j : Exact-Positive-Integer '(10 20 30)) + ((i : Integer '(1 2 3)) + (j : Integer '(10 20 30)) #:when (> j 12)) (values i j))]) (append x y)) @@ -107,9 +107,9 @@ (check = (for*/fold: : Integer ((acc : Integer 0)) - ((i : Exact-Positive-Integer '(1 2 3)) + ((i : Integer '(1 2 3)) #:when (even? i) - (j : Exact-Positive-Integer '(10 20 30)) - (k : Exact-Positive-Integer '(100 200 300))) + (j : Integer '(10 20 30)) + (k : Integer '(100 200 300))) (+ acc i j k)) 1998) diff --git a/collects/tests/typed-scheme/xfail/for-inference.rkt b/collects/tests/typed-scheme/xfail/for-inference.rkt index faa0154b..14a3a70d 100644 --- a/collects/tests/typed-scheme/xfail/for-inference.rkt +++ b/collects/tests/typed-scheme/xfail/for-inference.rkt @@ -59,3 +59,23 @@ (for/last: : (Option Integer) ((i : Exact-Positive-Integer '(1 2 3))) i) + +;; unlike the usual cases with #:when clauses, inference does something, but does it wrong +(for/list: : (Listof Integer) + (#:when #t + (i : Exact-Positive-Integer '(1 2 3)) + (j : Exact-Positive-Integer '(10 20 30))) + (+ i j 10)) + +;; that same bug makes for/hash:, for/hasheq: and for/hasheqv: unusable +;; this infers Nothing for the type of the elements of the HashTable +;; since they don't work, these functions are not currently documented +(for/hash: : (HashTable Integer Char) + ((i : Exact-Positive-Integer '(1 2 3)) + (j : Char "abc")) + (values i j)) + +;; same thing for for/and: +(for/and: : Boolean + ((i : Exact-Positive-Integer '(1 2 3))) + (< i 3)) diff --git a/collects/typed-scheme/private/for-clauses.rkt b/collects/typed-scheme/private/for-clauses.rkt index 83c7f36b..54013522 100644 --- a/collects/typed-scheme/private/for-clauses.rkt +++ b/collects/typed-scheme/private/for-clauses.rkt @@ -2,18 +2,25 @@ (require syntax/parse "annotate-classes.rkt" - (for-template racket/base)) + (for-template racket/base + "base-types-new.rkt")) (provide (all-defined-out)) (define-splicing-syntax-class for-clause ;; single-valued seq-expr (pattern (var:annotated-name seq-expr:expr) - #:with (expand ...) (list #'(var.ann-name seq-expr))) + #:with (expand ...) (list #`(var.ann-name + #,(syntax-property #'seq-expr + 'type-ascription + #'(Sequenceof var.ty))))) ;; multi-valued seq-expr ;; currently disabled because it triggers an internal error in the typechecker #;(pattern (((v:annotated-name) ...) seq-expr:expr) - #:with (expand ...) (list #'((v.ann-name ...) seq-expr))) + #:with (expand ...) (list #`((v.ann-name ...) + #,(syntax-property #'seq-expr + 'type-ascription + #'(Sequenceof (values v.ty ...)))))) ;; when clause (pattern (~seq #:when guard:expr) #:with (expand ...) (list #'#:when #'guard))) @@ -22,11 +29,19 @@ (define-splicing-syntax-class for*-clause ;; single-valued seq-expr (pattern (var:annotated-name seq-expr:expr) - #:with (expand ...) (list #'(var.ann-name seq-expr) #'#:when #'#t)) + #:with (expand ...) (list #`(var.ann-name + #,(syntax-property #'seq-expr + 'type-ascription + #'(Sequenceof var.ty))) + #'#:when #'#t)) ;; multi-valued seq-expr ;; currently disabled because it triggers an internal error in the typechecker #;(pattern (((v:annotated-name) ...) seq-expr:expr) - #:with (expand ...) (list #'((v.ann-name ...) seq-expr) #'#:when #'#t)) + #:with (expand ...) (list #`((v.ann-name ...) + #,(syntax-property #'seq-expr + 'type-ascription + #'(Sequenceof (values v.ty ...)))) + #'#:when #'#t)) ;; when clause (pattern (~seq #:when guard:expr) #:with (expand ...) (list #'#:when #'guard))) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index dd08d722..d2263605 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -392,11 +392,20 @@ This file defines two sorts of primitives. All of them are provided into any mod (let loop ((clauses #'clauses)) (define-syntax-class for-clause ;; 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) - #:with expand #'(var.ann-name seq-expr)) + #:with expand #`(var.ann-name + #,(syntax-property #'seq-expr + 'type-ascription + #'(Sequenceof var.ty)))) ;; multi-valued seq-expr - (pattern ((v:annotated-name ...) seq-expr:expr) - #:with expand #'((v.ann-name ...) seq-expr))) + ;; currently disabled because it triggers an internal error in the typechecker + #;(pattern ((v:annotated-name ...) seq-expr:expr) + #:with expand #`((v.ann-name ...) + #,(syntax-property #'seq-expr + 'type-ascription + #'(Sequenceof (values v.ty ...)))))) (syntax-parse clauses [(head:for-clause next:for-clause ... #:when rest ...) (syntax-property From ce236fdf46c83e8f6637fbff158b131666c60883 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 8 Jun 2010 19:53:07 -0400 Subject: [PATCH 010/198] Added Channel types. original commit: ec799fb208197df8b2f4cafc0b0af3aad423871a --- collects/typed-scheme/infer/infer-unit.rkt | 2 ++ collects/typed-scheme/infer/promote-demote.rkt | 2 ++ collects/typed-scheme/private/base-env.rkt | 8 +++++++- collects/typed-scheme/private/base-types-new.rkt | 1 + collects/typed-scheme/private/type-contract.rkt | 2 ++ collects/typed-scheme/rep/type-rep.rkt | 7 ++++++- collects/typed-scheme/types/abbrev.rkt | 1 + collects/typed-scheme/types/printer.rkt | 5 ++++- collects/typed-scheme/types/subtype.rkt | 1 + 9 files changed, 26 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index d45d75d3..5b5a2d8e 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -414,6 +414,8 @@ (cset-meet (cg e e*) (cg e* e))] [((Box: e) (Box: e*)) (cset-meet (cg e e*) (cg e* e))] + [((Channel: e) (Channel: e*)) + (cset-meet (cg e e*) (cg e* e))] [((Hashtable: s1 s2) (Hashtable: t1 t2)) ;; for mutable hash tables, both are invariant (cset-meet* (list (cg t1 s1) (cg s1 t1) (cg t2 s2) (cg s2 t2)))] diff --git a/collects/typed-scheme/infer/promote-demote.rkt b/collects/typed-scheme/infer/promote-demote.rkt index 5d2daef8..334eecc7 100644 --- a/collects/typed-scheme/infer/promote-demote.rkt +++ b/collects/typed-scheme/infer/promote-demote.rkt @@ -25,6 +25,7 @@ [#:F name (if (memq name V) Univ T)] [#:Vector t (make-Vector (inv t))] [#:Box t (make-Box (inv t))] + [#:Channel t (make-Channel (inv t))] [#:Hashtable k v (if (V-in? V v) Univ @@ -58,6 +59,7 @@ [#:F name (if (memq name V) (Un) T)] [#:Vector t (make-Vector (inv t))] [#:Box t (make-Box (inv t))] + [#:Channel t (make-Channel (inv t))] [#:Hashtable k v (if (V-in? V v) (Un) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 1a92f30f..8054c0c0 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -16,7 +16,7 @@ (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-VectorTop))) + (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-ChannelTop make-VectorTop))) [raise (Univ . -> . (Un))] [raise-syntax-error (cl->* @@ -207,6 +207,12 @@ [empty? (make-pred-ty (-val null))] [empty (-val null)] +[make-channel (-poly (a) (-> (-channel a)))] +[channel? (make-pred-ty (make-ChannelTop))] +[channel-get (-poly (a) ((-channel a) . -> . a))] +[channel-try-get (-poly (a) ((-channel a) . -> . (Un a (-val #f))))] +[channel-put (-poly (a) ((-channel a) a . -> . -Void))] + [string? (make-pred-ty -String)] [string (->* '() -Char -String)] [string-length (-String . -> . -Nat)] diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types-new.rkt index 84e29ede..8dbf20df 100644 --- a/collects/typed-scheme/private/base-types-new.rkt +++ b/collects/typed-scheme/private/base-types-new.rkt @@ -43,6 +43,7 @@ [Promise (-poly (a) (-Promise a))] [Pair (-poly (a b) (-pair a b))] [Boxof (-poly (a) (make-Box a))] +[Channelof (-poly (a) (make-Channel a))] [Continuation-Mark-Set -Cont-Mark-Set] [False (-val #f)] [True (-val #t)] diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt index a8f395b5..c7cee8a1 100644 --- a/collects/typed-scheme/private/type-contract.rkt +++ b/collects/typed-scheme/private/type-contract.rkt @@ -126,6 +126,8 @@ #`(vectorof #,(t->c t))] [(Box: t) #`(box/c #,(t->c t))] + [(Channel: t) + #`(channel/c #,(t->c t))] [(Pair: t1 t2) #`(cons/c #,(t->c t1) #,(t->c t2))] [(Opaque: p? cert) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 49cf247a..a824bba0 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -84,7 +84,11 @@ ;; elem is a Type (dt Box ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] - [#:key 'box]) + [#:key 'box]) + +;; elem is a Type +(dt Channel ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] + [#:key 'channel]) ;; name is a Symbol (not a Name) (dt Base ([name symbol?] [contract syntax?]) [#:frees #f] [#:fold-rhs #:base] [#:intern name] @@ -247,6 +251,7 @@ ;; the supertype of all of these values (dt BoxTop () [#:fold-rhs #:base] [#:key 'box]) +(dt ChannelTop () [#:fold-rhs #:base] [#:key 'channel]) (dt VectorTop () [#:fold-rhs #:base] [#:key 'vector]) (dt HashtableTop () [#:fold-rhs #:base] [#:key 'hash]) (dt MPairTop () [#:fold-rhs #:base] [#:key 'mpair]) diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 9585f9d4..a15c22c2 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -26,6 +26,7 @@ (define -val make-Value) (define -Param make-Param) (define -box make-Box) +(define -channel make-Channel) (define -vec make-Vector) (define (-seq . args) (make-Sequence args)) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 2b0d2c0b..23cee27b 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -123,6 +123,7 @@ (fp "~a" name)] [(StructTop: st) (fp "~a" st)] [(BoxTop:) (fp "Box")] + [(ChannelTop:) (fp "Channel")] [(VectorTop:) (fp "Vector")] [(MPairTop:) (fp "MPair")] ;; names are just the printed as the original syntax @@ -165,6 +166,7 @@ (fp " ~a" i)) (fp ")")] [(Box: e) (fp "(Boxof ~a)" e)] + [(Channel: e) (fp "(Channelof ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] [(Pair: l r) (fp "(Pairof ~a ~a)" l r)] [(F: nm) (fp "~a" nm)] @@ -195,7 +197,8 @@ (Mu: var (Union: (list (Value: '()) (Pair: (F: x) (F: var))))) (Mu: y (Union: (list (F: x) (Pair: (F: x) (F: y))))) (Vector: (F: x)) - (Box: (F: x)))))) + (Box: (F: x)) + (Channel: (F: x)))))) (fp "Syntax")] [(Mu-name: name body) (fp "(Rec ~a ~a)" name body)] ;; FIXME - this should not be used diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index ccaaf720..d03769bb 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -335,6 +335,7 @@ [((Struct: _ _ _ _ _ _ _ _ _) (StructTop: (? (lambda (s2) (type-equal? s2 s))))) A0] [((Box: _) (BoxTop:)) A0] + [((Channel: _) (ChannelTop:)) A0] [((Vector: _) (VectorTop:)) A0] [((HeterogenousVector: _) (VectorTop:)) A0] [((HeterogenousVector: (list e ...)) (Vector: e*)) From d5c72476e8afa9a3d7078e1eb8a325c1cc028482 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 9 Jun 2010 12:34:17 -0400 Subject: [PATCH 011/198] Added the Thread type and related functions. original commit: 15b0c8542d3a54a37539608623754109f96b4d3e --- collects/typed-scheme/private/base-env.rkt | 12 +++++++++++- collects/typed-scheme/private/base-types-new.rkt | 1 + collects/typed-scheme/types/abbrev.rkt | 1 + 3 files changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 8054c0c0..d3d251bf 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -280,7 +280,17 @@ [fprintf (->* (list -Output-Port -String) Univ -Void)] [format (->* (list -String) Univ -String)] -[sleep (N . -> . -Void)] +[thread (-> (-> Univ) -Thread)] +[thread? (make-pred-ty -Thread)] +[current-thread (-> -Thread)] +[thread/suspend-to-kill (-> (-> Univ) -Thread)] +[thread-suspend (-Thread . -> . -Void)] +[kill-thread (-Thread . -> . -Void)] +[break-thread (-Thread . -> . -Void)] +[sleep ([N] . ->opt . -Void)] +[thread-running? (-Thread . -> . B)] +[thread-dead? (-Thread . -> . B)] +[thread-wait (-Thread . -> . -Void)] [reverse (-poly (a) (-> (-lst a) (-lst a)))] [append (-poly (a) (->* (list) (-lst a) (-lst a)))] diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types-new.rkt index 8dbf20df..d5a8cc81 100644 --- a/collects/typed-scheme/private/base-types-new.rkt +++ b/collects/typed-scheme/private/base-types-new.rkt @@ -35,6 +35,7 @@ [Identifier Ident] [Procedure top-func] [Keyword -Keyword] +[Thread -Thread] [Listof -Listof] [Vectorof (-poly (a) (make-Vector a))] [FlVector -FlVector] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index a15c22c2..9bdfbb75 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -93,6 +93,7 @@ (define -String (make-Base 'String #'string?)) (define -Keyword (make-Base 'Keyword #'keyword?)) (define -Char (make-Base 'Char #'char?)) +(define -Thread (make-Base 'Thread #'thread?)) (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?)) From c689b7d3e68c9e0d332d245ece205931bcf478a4 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 9 Jun 2010 11:55:59 -0400 Subject: [PATCH 012/198] Added tests and documentation for Thread and Channel types. original commit: 6b4ca4d7b05ca42527788049a8bf20e322da889d --- .../succeed/threads-and-channels.rkt | 50 +++++++++++++++++++ .../scribblings/ts-reference.scrbl | 4 +- 2 files changed, 53 insertions(+), 1 deletion(-) create mode 100644 collects/tests/typed-scheme/succeed/threads-and-channels.rkt diff --git a/collects/tests/typed-scheme/succeed/threads-and-channels.rkt b/collects/tests/typed-scheme/succeed/threads-and-channels.rkt new file mode 100644 index 00000000..6261363e --- /dev/null +++ b/collects/tests/typed-scheme/succeed/threads-and-channels.rkt @@ -0,0 +1,50 @@ +#lang typed/scheme + +(: chan (Channelof Symbol)) +(define chan (make-channel)) + +(define (reader) + (thread + (lambda () + (let: loop : True ((i : Integer 10)) + (if (= i 0) + #t + (begin (channel-get chan) + (loop (- i 1)))))))) + +(: writer (Symbol -> Thread)) +(define (writer x) + (thread + (lambda () + (channel-put chan x) + (channel-put chan x)))) + +(reader) +(writer 'a) +(writer 'b) +(writer 'c) +(writer 'd) +(writer 'e) + + +(define-type JumpingChannel (Rec JumpingChannel (Channelof (Pair JumpingChannel Symbol)))) +(: jump-chan JumpingChannel) +(define jump-chan (make-channel)) + +(define (jumping-reader) + (thread + (lambda () + (let: loop : True ((i : Integer 3) + (c : JumpingChannel jump-chan)) + (if (= i 0) + #t + (loop (- i 1) + (car (channel-get c)))))))) + +(jumping-reader) +(let: ((c2 : JumpingChannel (make-channel))) + (channel-put jump-chan (cons c2 'a)) + (let: ((c3 : JumpingChannel (make-channel))) + (channel-put c2 (cons c3 'b)) + (let: ((c4 : JumpingChannel (make-channel))) + (channel-put c3 (cons c4 'c))))) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index da763578..a341bffe 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -48,7 +48,8 @@ @defidform[Namespace] @defidform[EOF] @defidform[Continuation-Mark-Set] -@defidform[Char])]{ +@defidform[Char] +@defidform[Thread])]{ These types represent primitive Racket data. Note that @racket[Integer] represents exact integers.} @defidform[Any]{Any Racket value. All other types are subtypes of @racket[Any].} @@ -61,6 +62,7 @@ The following base types are parameteric in their type arguments. @defform[(Listof t)]{Homogenous @rtech{lists} of @racket[t]} @defform[(Boxof t)]{A @rtech{box} of @racket[t]} +@defform[(Channelof t)]{A @rtech{channel} on which only @racket[t]s can be sent} @defform[(Syntaxof t)]{A @rtech{syntax object} containing a @racket[t]} @defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]} @defform[(Option t)]{Either @racket[t] of @racket[#f]} From aacdee78b9445ae7d6c0719e0f91eba7302dcac1 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 8 Jun 2010 12:54:22 -0400 Subject: [PATCH 013/198] Added some Bytes and IO-related stuff to Typed Scheme. original commit: 04e618388c53c32a80b9be89402fec685bbb783d --- collects/typed-scheme/private/base-env.rkt | 20 ++++++++++++++++--- .../typed-scheme/private/base-types-new.rkt | 2 ++ 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index d3d251bf..cd4dbe71 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -179,6 +179,7 @@ (-> (Un a (-val #f)) a)))] [gensym (->opt [Sym] Sym)] [string-append (->* null -String -String)] +[string-copy! (->opt -String -Nat -String -Nat [-Nat -Nat] -Void)] [open-input-string (-> -String -Input-Port)] [open-output-file (->key -Pathlike @@ -550,8 +551,11 @@ #;[hash-table-index (-poly (a b) ((-HT a b) a b . -> . -Void))] [bytes (->* (list) -Integer -Bytes)] -[bytes-ref (-> -Bytes -Integer -Integer)] -[bytes-append (->* (list -Bytes) -Bytes -Bytes)] +[make-bytes (cl-> [(-Integer -Integer) -Bytes] + [(-Integer) -Bytes])] +[bytes-ref (-> -Bytes -Integer -Nat)] +[bytes-set! (-> -Bytes -Integer -Integer -Void)] +[bytes-append (->* (list) -Bytes -Bytes)] [subbytes (cl-> [(-Bytes -Integer) -Bytes] [(-Bytes -Integer -Integer) -Bytes])] [bytes-length (-> -Bytes -Nat)] [unsafe-bytes-length (-> -Bytes -Nat)] @@ -562,7 +566,11 @@ [close-output-port (-> -Output-Port -Void)] [read-line (->opt [-Input-Port Sym] -String)] [copy-file (-> -Pathlike -Pathlike -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)] [bytes->string/utf-8 (-> -Bytes -String)] +[string->bytes/utf-8 (-> -String -Bytes)] [force (-poly (a) (-> (-Promise a) a))] [bytes* (list -Bytes) -Bytes B)] @@ -574,6 +582,9 @@ [read-byte (cl->* [-> (Un -Byte (-val eof))] [-Input-Port . -> . (Un -Byte (-val eof))])] +[read-string (-Nat [-Input-Port] . ->opt . (Un -String (-val eof)))] +[read-string! (-String [-Input-Port -Nat -Nat] . ->opt . (Un -Nat (-val eof)))] +[read-bytes (-Nat [-Input-Port] . ->opt . (Un -Bytes (-val eof)))] [make-pipe (cl->* [->opt [N] (-values (list -Input-Port -Output-Port))])] [open-output-bytes @@ -713,7 +724,7 @@ [tcp-close (-TCP-Listener . -> . -Void )] [tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] [tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] -[tcp-listen (N . -> . -TCP-Listener)] +[tcp-listen (-Nat [-Nat Univ (-opt -String)] . ->opt . -TCP-Listener)] ;; scheme/bool [boolean=? (B B . -> . B)] @@ -729,9 +740,12 @@ ;; scheme/port [port->lines (cl->* ([-Input-Port] . ->opt . (-lst -String)))] +[port->bytes (->opt [-Input-Port] -Bytes)] [with-output-to-string (-> (-> Univ) -String)] [open-output-nowhere (-> -Output-Port)] +[input-port? (make-pred-ty -Input-Port)] +[output-port? (make-pred-ty -Output-Port)] ;; scheme/path diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types-new.rkt index d5a8cc81..c5c5db1d 100644 --- a/collects/typed-scheme/private/base-types-new.rkt +++ b/collects/typed-scheme/private/base-types-new.rkt @@ -20,6 +20,8 @@ [Path-String -Pathlike] [Regexp -Regexp] [PRegexp -PRegexp] +[Byte-Regexp -Byte-Regexp] +[Byte-PRegexp -Byte-PRegexp] [Char -Char] [Namespace -Namespace] [Input-Port -Input-Port] From feaef17915eb9463e80cf84985025781ebee8889 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 9 Jun 2010 12:45:00 -0400 Subject: [PATCH 014/198] Modified the numeric base type environment. original commit: 2fd1e3ac9ffc0b939cceac0e7ded9093d5e7a9a8 --- .../typed-scheme/private/base-env-numeric.rkt | 43 ++++++++++++++----- 1 file changed, 33 insertions(+), 10 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 163115bf..daf5aacb 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -78,16 +78,38 @@ [> real-comp] -[* (apply cl->* (for/list ([t all-num-types]) (->* (list) t t)))] -[+ (apply cl->* (for/list ([t all-num-types]) (->* (list) t t)))] +[* (apply cl->* + (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) + (list (->* (list (Un -Integer -ExactRational -Real -Flonum)) + (Un -Integer -ExactRational -Real -Flonum) + -Flonum)) + (list (->* (list) -Real -Real)) + (list (->* (list) N N))))] +[+ (apply cl->* + (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) + (list (->* (list (Un -Integer -ExactRational -Real -Flonum)) + (Un -Integer -ExactRational -Real -Flonum) + -Flonum)) + (list (->* (list) -Real -Real)) + (list (->* (list) N N))))] -[- (apply cl->* - (for/list ([t (list -Integer -ExactRational -Flonum -Real N)]) - (->* (list t) t t)))] -[/ (apply cl->* - (->* (list -Integer) -Integer -ExactRational) - (for/list ([t (list -ExactRational -Flonum -Real N)]) - (->* (list t) t t)))] +[- (apply cl->* + (append (for/list ([t (list -Integer -ExactRational -Flonum)]) + (->* (list t) t t)) + (list (->* (list (Un -Integer -ExactRational -Real -Flonum)) + (Un -Integer -ExactRational -Real -Flonum) + -Flonum)) + (list (->* (list -Real) -Real -Real)) + (list (->* (list N) N N))))] +[/ (apply cl->* + (append (list (->* (list -Integer) -Integer -ExactRational)) + (for/list ([t (list -ExactRational -Flonum)]) + (->* (list t) t t)) + (list (->* (list (Un -Integer -ExactRational -Real -Flonum)) + (Un -Integer -ExactRational -Real -Flonum) + -Flonum)) + (list (->* (list -Real) -Real -Real)) + (list (->* (list N) N N))))] [max (apply cl->* (->* (list -Pos) -Integer -Pos) (->* (list -Nat) -Integer -Nat) (for/list ([t all-num-types]) (->* (list t) t t)))] [min (apply cl->* (for/list ([t all-num-types]) (->* (list t) t t)))] @@ -137,7 +159,8 @@ [denominator (-Real . -> . -Real)] [rationalize (-Real -Real . -> . N)] [expt (cl->* (-Nat -Nat . -> . -Nat) - (-Integer -Integer . -> . -Integer) + (-Integer -Nat . -> . -Integer) + (-Real -Integer . -> . -Real) (N N . -> . N))] [sqrt (cl->* (-Nat . -> . -Real) From e34babbff007d28aa2206b99adfd93e996f03cbc Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 9 Jun 2010 15:28:10 -0400 Subject: [PATCH 015/198] Fixed the implementation of Channel types. original commit: 436e001b0e485111da5772f54fcf004eec8a3068 --- collects/typed-scheme/types/printer.rkt | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 23cee27b..e6208201 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -197,8 +197,7 @@ (Mu: var (Union: (list (Value: '()) (Pair: (F: x) (F: var))))) (Mu: y (Union: (list (F: x) (Pair: (F: x) (F: y))))) (Vector: (F: x)) - (Box: (F: x)) - (Channel: (F: x)))))) + (Box: (F: x)))))) (fp "Syntax")] [(Mu-name: name body) (fp "(Rec ~a ~a)" name body)] ;; FIXME - this should not be used From 5b0fec235c203b46f2a3839b987d49abdea06bc4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 9 Jun 2010 15:40:55 -0400 Subject: [PATCH 016/198] Improve TS reference docs - lots of examples - reorganize type listing - add Zero type original commit: 315156612505bb7f666da0b1eacdbe6dce1705aa --- .../typed-scheme/private/base-types-new.rkt | 1 + .../scribblings/ts-reference.scrbl | 150 +++++++++++++++--- 2 files changed, 125 insertions(+), 26 deletions(-) diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types-new.rkt index c5c5db1d..23f0118d 100644 --- a/collects/typed-scheme/private/base-types-new.rkt +++ b/collects/typed-scheme/private/base-types-new.rkt @@ -9,6 +9,7 @@ [Exact-Positive-Integer -ExactPositiveInteger] [Exact-Nonnegative-Integer -ExactNonnegativeInteger] [Natural -ExactNonnegativeInteger] +[Zero (-val 0)] [Void -Void] [Boolean -Boolean] diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index a341bffe..46f9f993 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -11,6 +11,9 @@ @(define the-top-eval (make-base-eval)) @(the-top-eval '(require (except-in typed/racket #%module-begin))) +@(define-syntax-rule (ex . args) + (examples #:eval the-top-eval . args)) + @title[#:tag "top"]{The Typed Racket Reference} @author["Sam Tobin-Hochstadt"] @@ -20,16 +23,41 @@ @section[#:tag "type-ref"]{Type Reference} -@subsubsub*section{Base Types} +@defidform[Any]{Any Racket value. All other types are subtypes of @racket[Any].} + +@defidform[Nothing]{The empty type. No values inhabit this type, and +any expression of this type will not evaluate to a value.} + +@subsection{Base Types} + +@subsubsection{Numeric Types} @deftogether[( @defidform[Number] @defidform[Complex] @defidform[Real] +@defidform[Float] +@defidform[Exact-Rational] @defidform[Integer] @defidform[Natural] -@defidform[Exact-Positive-Integer] @defidform[Exact-Nonnegative-Integer] -@defidform[Exact-Rational] +@defidform[Exact-Positive-Integer] +@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?]. + +@ex[ +7 +8.3 +(/ 8 3) +0 +-12 +3+4i] +} + +@subsubsection{Other Base Types} + +@deftogether[( @defidform[Boolean] @defidform[True] @defidform[False] @@ -42,39 +70,107 @@ @defidform[Path] @defidform[Regexp] @defidform[PRegexp] -@defidform[Syntax] -@defidform[Identifier] @defidform[Bytes] @defidform[Namespace] @defidform[EOF] @defidform[Continuation-Mark-Set] @defidform[Char] @defidform[Thread])]{ -These types represent primitive Racket data. Note that @racket[Integer] represents exact integers.} +These types represent primitive Racket data. -@defidform[Any]{Any Racket value. All other types are subtypes of @racket[Any].} +@ex[ +#t +#f +"hello" +(current-input-port) +(current-output-port) +(string->path "/") +#rx"a*b*" +#px"a*b*" +'#"bytes" +(current-namespace) +#\b +(thread (lambda () (add1 7))) +] +} -@defidform[Nothing]{The empty type. No values inhabit this type, and -any expression of this type will not evaluate to a value.} +@subsection{Singleton Types} + +Some kinds of data are given singleton types by default. In +particular, @rtech{symbols} and @rtech{keywords} have types which +consist only of the particular symbol or keyword. These types are +subtypes of @racket[Symbol] and @racket[Keyword], respectively. + +@ex[ +'#:foo +'bar +] + +@subsection{Containers} The following base types are parameteric in their type arguments. -@defform[(Listof t)]{Homogenous @rtech{lists} of @racket[t]} -@defform[(Boxof t)]{A @rtech{box} of @racket[t]} -@defform[(Channelof t)]{A @rtech{channel} on which only @racket[t]s can be sent} -@defform[(Syntaxof t)]{A @rtech{syntax object} containing a @racket[t]} -@defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]} -@defform[(Option t)]{Either @racket[t] of @racket[#f]} -@defform*[[(Parameter t) - (Parameter s t)]]{A @rtech{parameter} of @racket[t]. If two type arguments are supplied, - the first is the type the parameter accepts, and the second is the type returned.} -@defform[(Pair s t)]{is the pair containing @racket[s] as the @racket[car] +@defform[(Pair s t)]{is the @rtech{pair} containing @racket[s] as the @racket[car] and @racket[t] as the @racket[cdr]} -@defform[(HashTable k v)]{is the type of a @rtech{hash table} with key type - @racket[k] and value type @racket[v].} -@subsubsub*section{Type Constructors} +@ex[ +(cons 1 2) +(cons 1 "one") +] + + +@defform[(Listof t)]{Homogenous @rtech{lists} of @racket[t]} +@defform[(List t ...)]{is the type of the list with one element, in order, + for each type provided to the @racket[List] type constructor.} + +@ex[ +(list 'a 'b 'c) +(map symbol->string (list 'a 'b 'c)) +] + +@defform[(Boxof t)]{A @rtech{box} of @racket[t]} + +@ex[(box "hello world")] + +@deftogether[( + @defform[(Syntaxof t)] + @defidform[Syntax] + @defidform[Identifier])]{A @rtech{syntax object} containing a + @racket[t]. @racket[Syntax] is the type of any object constructable + via @racket[datum->syntax]. @racket[Identifier] is @racket[(Syntaxof + Symbol)]. + +@ex[#'here] + +} + +@defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]} +@defform[(Vector t ...)]{is the type of the list with one element, in order, + for each type provided to the @racket[Vector] type constructor.} + +@ex[(vector 1 2 3) +#(a b c)] + +@defform[(HashTable k v)]{is the type of a @rtech{hash table} with key type + @racket[k] and value type @racket[v]. + +@ex[#hash((a . 1) (b . 2))] +} + +@defform[(Channelof t)]{A @rtech{channel} on which only @racket[t]s can be sent. +@ex[ +(ann (make-channel) (Channelof Symbol)) +] +} + +@defform*[[(Parameterof t) + (Parameterof s t)]]{A @rtech{parameter} of @racket[t]. If two type arguments are supplied, + the first is the type the parameter accepts, and the second is the type returned. +@ex[current-input-port] +} + +@subsection{Other Type Constructors} @defform*[#:id -> #:literals (* ...) [(dom ... -> rng) @@ -97,10 +193,6 @@ The following base types are parameteric in their type arguments. @racket[t] at types @racket[t1 t2 ...]} @defform[(All (v ...) t)]{is a parameterization of type @racket[t], with type variables @racket[v ...]} -@defform[(List t ...)]{is the type of the list with one element, in order, - for each type provided to the @racket[List] type constructor.} -@defform[(Vector t ...)]{is the type of the list with one element, in order, - for each type provided to the @racket[Vector] type constructor.} @defform[(values t ...)]{is the type of a sequence of multiple values, with types @racket[t ...]. This can only appear as the return type of a function.} @@ -111,6 +203,11 @@ name or a type variable} @defform[(Rec n t)]{is a recursive type where @racket[n] is bound to the recursive type in the body @racket[t]} + +@subsection{Other Types} + +@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. @@ -120,6 +217,7 @@ 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 From 9aef73b98099971b5f8fb93542a57fd972e0f47b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 9 Jun 2010 16:38:07 -0400 Subject: [PATCH 017/198] Fix promise printing, add docs. Closes PR 10968. original commit: 0149a05719fdb1fbab56d231905f088bb13b4252 --- .../scribblings/ts-reference.scrbl | 19 +++++++++++++++---- collects/typed-scheme/types/abbrev.rkt | 6 ++++-- collects/typed-scheme/types/printer.rkt | 6 +++--- 3 files changed, 22 insertions(+), 9 deletions(-) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 46f9f993..10cc05e3 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -167,8 +167,12 @@ The following base types are parameteric in their type arguments. @defform*[[(Parameterof t) (Parameterof s t)]]{A @rtech{parameter} of @racket[t]. If two type arguments are supplied, the first is the type the parameter accepts, and the second is the type returned. -@ex[current-input-port] +@ex[current-input-port + current-directory] } + +@defform[(Promise t)]{A @rtech{promise} of @racket[t]. + @ex[(delay 3)]} @subsection{Other Type Constructors} @@ -184,8 +188,14 @@ The following base types are parameteric in their type arguments. second occurrence of @racket[...] is literal, and @racket[bound] must be an identifier denoting a type variable. In the fourth form, there must be only one @racket[dom] and @racket[pred] is the type - checked by the predicate.} -@defform[(U t ...)]{is the union of the types @racket[t ...]} + checked by the predicate. + + @ex[(λ: ([x : Number]) x) + (λ: ([x : Number] . [y : String *]) (length y)) + ormap + string?]} +@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 types constructed with @racket[->].} @@ -195,7 +205,8 @@ The following base types are parameteric in their type arguments. type variables @racket[v ...]} @defform[(values t ...)]{is the type of a sequence of multiple values, with types @racket[t ...]. This can only appear as the return type of a -function.} +function. +@ex[(values 1 2 3)]} @defform/none[v]{where @racket[v] is a number, boolean or string, is the singleton type containing only that value} @defform/none[(quote val)]{where @racket[val] is a Racket value, is the singleton type containing only that value} @defform/none[i]{where @racket[i] is an identifier can be a reference to a type diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 9bdfbb75..ca9a8995 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt") (require (rep type-rep object-rep filter-rep rep-utils) - "printer.rkt" "utils.rkt" "resolve.rkt" + #;"printer.rkt" "utils.rkt" "resolve.rkt" (utils tc-utils) scheme/list scheme/match @@ -75,8 +75,10 @@ ;; basic types +(define promise-str (string->uninterned-symbol "Promise")) + (define make-promise-ty - (let ([s (string->uninterned-symbol "Promise")]) + (let ([s promise-str]) (lambda (t) (make-Struct s #f (list t) #f #f #'promise? values (list #'values) #'values)))) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index e6208201..2c0f959c 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -1,7 +1,7 @@ #lang scheme/base (require unstable/sequence racket/require racket/match - (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" + (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" "types/abbrev.rkt" "rep/rep-utils.rkt" "utils/utils.rkt" "utils/tc-utils.rkt")) ;; do we attempt to find instantiations of polymorphic types to print? @@ -142,8 +142,8 @@ (fp "~a" (cons 'List (tuple-elems t)))] [(Base: n cnt) (fp "~a" n)] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] - [(Struct: 'Promise par (list fld) proc _ _ _ _ _) (fp "(Promise ~a)" fld)] - [(Struct: nm par flds proc _ _ _ _ _) + [(Struct: (== promise-str eq?) #f (list fld) _ _ _ _ _ _) (fp "(Promise ~a)" fld)] + [(Struct: nm par flds proc _ _ _ _ _) (fp "#(struct:~a ~a" nm flds) (when proc (fp " ~a" proc)) From ed35e04293f013ba065db418fe15a918e3a470b8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 10 Jun 2010 11:58:41 -0400 Subject: [PATCH 018/198] New interface for unstable/mutated-vars - functional hash tables - fix clients original commit: 0379e534e3f0024473d6af9379d0cac0d2bd1a37 --- .../unit-tests/typecheck-tests.rkt | 8 +- collects/typed-scheme/env/lexical-env.rkt | 1 - .../typed-scheme/typecheck/tc-toplevel.rkt | 1 - collects/typed-scheme/typed-scheme.rkt | 5 +- collects/typed-scheme/types/abbrev.rkt | 2 +- collects/typed-scheme/utils/tc-utils.rkt | 7 +- collects/unstable/mutated-vars.rkt | 86 ++++++++----------- 7 files changed, 51 insertions(+), 59 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index b1d8e540..1f15665c 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -64,8 +64,8 @@ [current-namespace (namespace-anchor->namespace anch)] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) - (find-mutated-vars ex) - (values (lambda () (tc-expr ex)) ex)))])) + (parameterize ([mutated-vars (find-mutated-vars ex)]) + (values (lambda () (tc-expr ex)) ex))))])) (define-syntax (tc-expr/expand stx) (syntax-case stx () @@ -74,8 +74,8 @@ [current-namespace (namespace-anchor->namespace anch)] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) - (find-mutated-vars ex) - (tc-expr ex)))])) + (parameterize ([mutated-vars (find-mutated-vars ex)]) + (tc-expr ex))))])) ;; check that an expression typechecks correctly (define-syntax (tc-e stx) diff --git a/collects/typed-scheme/env/lexical-env.rkt b/collects/typed-scheme/env/lexical-env.rkt index 15f9e25b..deef63f3 100644 --- a/collects/typed-scheme/env/lexical-env.rkt +++ b/collects/typed-scheme/env/lexical-env.rkt @@ -3,7 +3,6 @@ (require "../utils/utils.rkt" "type-environments.rkt" "type-env.rkt" - unstable/mutated-vars (only-in scheme/contract ->* -> or/c any/c listof cons/c) (utils tc-utils) (only-in (rep type-rep) Type/c) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index 7db4b125..269fd6e1 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -34,7 +34,6 @@ (define (tc-toplevel/pass1 form) ;(printf "form-top: ~a~n" form) ;; first, find the mutated variables: - (find-mutated-vars form) (parameterize ([current-orig-stx form]) (syntax-parse form #:literals (values define-type-alias-internal define-typed-struct-internal define-type-internal diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 615cc6b4..586744c1 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -5,6 +5,7 @@ (require (private with-types) (for-syntax (except-in syntax/parse id) + unstable/mutated-vars scheme/base (private type-contract optimize) (types utils convenience) @@ -72,6 +73,7 @@ forms ...)) 'module-begin null)])] + [parameterize ([mutated-vars (find-mutated-vars #'new-mod)])] [with-syntax ([(pmb body2 ...) #'new-mod])] [begin (do-time "Local Expand Done")] [with-syntax ([after-code (parameterize ([orig-module-stx (or (orig-module-stx) stx)] @@ -121,7 +123,8 @@ ;; local-expand the module [let ([body2 (local-expand #'(#%top-interaction . form) 'top-level null)])] [parameterize ([orig-module-stx #'form] - [expanded-module-stx body2])] + [expanded-module-stx body2] + [mutated-vars (find-mutated-vars body2)])] ;; typecheck the body, and produce syntax-time code that registers types [let ([type (tc-toplevel-form body2)])]) (define-syntax-class invis-kw diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index ca9a8995..a4bd73a5 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -9,7 +9,7 @@ scheme/match scheme/promise scheme/flonum (except-in scheme/contract ->* ->) - unstable/syntax unstable/mutated-vars + 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)) diff --git a/collects/typed-scheme/utils/tc-utils.rkt b/collects/typed-scheme/utils/tc-utils.rkt index b946a22a..d6a1c317 100644 --- a/collects/typed-scheme/utils/tc-utils.rkt +++ b/collects/typed-scheme/utils/tc-utils.rkt @@ -7,7 +7,7 @@ don't depend on any other portion of the system (provide (all-defined-out)) (require "syntax-traversal.rkt" - "utils.rkt" + "utils.rkt" racket/dict syntax/parse (for-syntax scheme/base syntax/parse) scheme/match unstable/debug (for-syntax unstable/syntax)) @@ -16,6 +16,11 @@ don't depend on any other portion of the system (define orig-module-stx (make-parameter #f)) (define expanded-module-stx (make-parameter #f)) +;; a parameter holding the mutated variables for the form currently being checked +(define mutated-vars (make-parameter #hash())) + +(define (is-var-mutated? id) (dict-ref (mutated-vars) id #f)) + (define (stringify l [between " "]) (define (intersperse v l) (cond [(null? l) null] diff --git a/collects/unstable/mutated-vars.rkt b/collects/unstable/mutated-vars.rkt index 1665b820..6a252521 100644 --- a/collects/unstable/mutated-vars.rkt +++ b/collects/unstable/mutated-vars.rkt @@ -1,57 +1,43 @@ #lang racket/base -(require (for-template racket/base) - syntax/boundmap syntax/kerncase) +(require (for-template racket/base) racket/dict + racket/trace + syntax/id-table syntax/kerncase) -;; mapping telling whether an identifer is mutated -;; maps id -> boolean -(define table (make-module-identifier-mapping)) +;; samth : this should use sets, not dicts +;; but sets do not have extensible comparisons +;; shouldn't be promoted until this is fixed ;; find and add to mapping all the set!'ed variables in form -;; syntax -> void +;; syntax -> table (define (find-mutated-vars form) - ;; syntax -> void - (define (fmv/list lstx) - (for-each find-mutated-vars (syntax->list lstx))) - (kernel-syntax-case* form #f () - ;; what we care about: set! - [(set! v e) - (begin - (module-identifier-mapping-put! table #'v #t))] - [(define-values (var ...) expr) - (find-mutated-vars #'expr)] - [(#%plain-app . rest) (fmv/list #'rest)] - [(begin . rest) (fmv/list #'rest)] - [(begin0 . rest) (fmv/list #'rest)] - [(#%plain-lambda _ . rest) (fmv/list #'rest)] - [(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))] - [(if . es) (fmv/list #'es)] - [(with-continuation-mark . es) (fmv/list #'es)] - [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) - (fmv/list #'b))] - [(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) - (fmv/list #'b))] - [(letrec-syntaxes+values _ ([_ e] ...) . b) (begin (fmv/list #'(e ...)) - (fmv/list #'b))] - [(#%expression e) (find-mutated-vars #'e)] - ;; all the other forms don't have any expression subforms (like #%top) - [_ (void)])) + (let loop ([stx form] [tbl (make-immutable-free-id-table)]) + ;; syntax-list -> table + (define (fmv/list lstx) + (for/fold ([tbl tbl]) + ([stx (in-list (syntax->list lstx))]) + (loop stx tbl))) + (kernel-syntax-case* stx #f (#%top-interaction) + ;; what we care about: set! + [(set! v e) + (dict-set (loop #'e tbl) #'v #t)] + ;; forms with expression subforms + [(define-values (var ...) expr) + (loop #'expr tbl)] + [(#%expression e) (loop #'e tbl)] + [(#%plain-app . rest) (fmv/list #'rest)] + [(begin . rest) (fmv/list #'rest)] + [(begin0 . rest) (fmv/list #'rest)] + [(#%plain-lambda _ . rest) (fmv/list #'rest)] + [(case-lambda (_ rest ...) ...) + (fmv/list #'(rest ... ...))] + [(if . es) (fmv/list #'es)] + [(with-continuation-mark . es) (fmv/list #'es)] + [(let-values ([_ e] ...) b ...) (fmv/list #'(b ... e ...))] + [(letrec-values ([_ e] ...) b ...) (fmv/list #'(b ... e ...))] + [(letrec-syntaxes+values _ ([_ e] ...) b ...) (fmv/list #'(b ... e ...))] + [(#%plain-module-begin . forms) (fmv/list #'forms)] + ;; all the other forms don't have any expression subforms (like #%top) + [_ tbl]))) -;; checks to see if a particular variable is ever set!'d -;; is-var-mutated? : identifier -> boolean -(define (is-var-mutated? id) (module-identifier-mapping-get table id (lambda _ #f))) - -;; Eli: -;; - The `for-template' doesn't look like it's needed. -;; - This is the *worst* looking interface I've seen in a while. Seems very -;; specific to some unclear optimization needs. (Either that, or translated -;; from C.) -;; - Besides weird, identifiers maps are (IIRC) not weak, which makes this even -;; less general. -;; - What's with the typed-scheme literals? If they were needed, then -;; typed-scheme is probably broken now. -;; ryanc: -;; - The for-template is needed. -;; - I've removed the bogus literals. - -(provide find-mutated-vars is-var-mutated?) +(provide find-mutated-vars) From dd84cab0b2c82c0324482164fe2fd47dbf21963b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 10 Jun 2010 17:39:07 -0400 Subject: [PATCH 019/198] Add types for a few more values. original commit: 490361c0fc3a94187083ea45132c5d9470b1df7a --- collects/typed-scheme/private/base-env.rkt | 17 ++++++++++++----- .../typed-scheme/private/base-special-env.rkt | 7 ++++++- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index cd4dbe71..072c20c0 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -1,16 +1,17 @@ #lang s-exp "env-lang.rkt" (require - scheme/tcp - scheme - scheme/unsafe/ops - scheme/fixnum + 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]) (only-in racket/private/pre-base new-apply-proc) - (for-syntax (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 (only-in string-constants/private/only-once maybe-print-message) (only-in mzscheme make-namespace) @@ -827,6 +828,12 @@ (-poly (a) ((list (-vec a)) -Integer . ->* . (-values (list (-vec a) (-vec a)))))] +;; racket/string +[string-join (-> (-lst -String) -String -String)] +[string-append* + (cl->* (-> (-lst -String) -String) + (-> -String (-lst -String) -String))] + ;; scheme/system [system (-String . -> . -Boolean)] [system* ((list -Pathlike) -String . ->* . -Boolean)] diff --git a/collects/typed-scheme/private/base-special-env.rkt b/collects/typed-scheme/private/base-special-env.rkt index c4933663..0ccb7b2e 100644 --- a/collects/typed-scheme/private/base-special-env.rkt +++ b/collects/typed-scheme/private/base-special-env.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base ;; these are libraries providing functions we add types to that are not in scheme/base (require @@ -66,9 +66,14 @@ [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 () From 589306a88fae999a8245c7339fdddf6391e9c003 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 11 Jun 2010 11:09:39 -0400 Subject: [PATCH 020/198] Refactor #%module-begin and #%top-interaction for Typed Scheme. original commit: 5f069ed4bb033531d39c8b268180f4ef70598c57 --- collects/typed-scheme/tc-setup.rkt | 62 +++++++ .../typed-scheme/typecheck/tc-toplevel.rkt | 9 +- collects/typed-scheme/typed-scheme.rkt | 171 +++++------------- 3 files changed, 117 insertions(+), 125 deletions(-) create mode 100644 collects/typed-scheme/tc-setup.rkt diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt new file mode 100644 index 00000000..79f8abfd --- /dev/null +++ b/collects/typed-scheme/tc-setup.rkt @@ -0,0 +1,62 @@ +#lang racket/base + +(require (rename-in "utils/utils.rkt" [infer r:infer]) + (except-in syntax/parse id) + unstable/mutated-vars + scheme/base + (private type-contract optimize) + (types utils convenience) + (typecheck typechecker provide-handling tc-toplevel) + (env type-environments 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) + scheme/nest + syntax/kerncase + scheme/match + (for-syntax racket/base) + (for-template racket/base)) + +(provide tc-setup invis-kw) + +(define-syntax-class invis-kw + #:literals (define-values define-syntaxes #%require #%provide begin) + (pattern (~or define-values define-syntaxes #%require #%provide begin))) + +(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx checker result . body) + (let () + (set-box! typed-context? #t) + (start-timing (syntax-property stx 'enclosing-module-name)) + (with-handlers + ([(lambda (e) (and #f (exn:fail? e) (not (exn:fail:syntax? e)))) + (lambda (e) (tc-error "Internal Typed Racket Error : ~a" e))]) + (parameterize (;; enable fancy printing? + [custom-printer #t] + ;; a cheat to avoid units + [infer-param infer] + ;; do we report multiple errors + [delay-errors? #t] + ;; this parameter is for parsing types + [current-tvars initial-tvar-env] + ;; 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]) + (do-time "Initialized Envs") + (let ([fully-expanded-stx (local-expand stx expand-ctxt null)]) + (do-time "Local Expand Done") + (parameterize ([mutated-vars (find-mutated-vars fully-expanded-stx)] + [orig-module-stx (or (orig-module-stx) orig-stx)] + [expanded-module-stx fully-expanded-stx]) + (let ([result (checker fully-expanded-stx)]) + (do-time "Typechecking Done") + . body))))))) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index 269fd6e1..da080236 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -26,7 +26,8 @@ scheme/base)) (c:provide/contract - [type-check (syntax? . c:-> . syntax?)] + [type-check (syntax? . c:-> . syntax?)] + [tc-module (syntax? . c:-> . syntax?)] [tc-toplevel-form (syntax? . c:-> . c:any/c)]) (define unann-defs (make-free-id-table)) @@ -277,6 +278,12 @@ #,(talias-env-init-code) (begin new-provs ... ...))))) +;; typecheck a whole module +;; syntax -> syntax +(define (tc-module stx) + (syntax-parse stx + [(pmb . forms) (type-check #'forms)])) + ;; typecheck a top-level form ;; used only from #%top-interaction ;; syntax -> void diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 586744c1..95ab29d3 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -1,12 +1,10 @@ #lang scheme/base -(require (rename-in "utils/utils.rkt" [infer r:infer])) - -(require (private with-types) +(require (rename-in "utils/utils.rkt" [infer r:infer]) + (private with-types) (for-syntax (except-in syntax/parse id) - unstable/mutated-vars - scheme/base + unstable/syntax racket/base unstable/match (private type-contract optimize) (types utils convenience) (typecheck typechecker provide-handling tc-toplevel) @@ -16,9 +14,8 @@ (rep type-rep) (except-in (utils utils) infer) (only-in (r:infer infer-dummy) infer-param) - scheme/nest - syntax/kerncase - scheme/match)) + scheme/match + "tc-setup.rkt")) (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] @@ -27,129 +24,55 @@ [require require]) with-type) -(define-for-syntax catch-errors? #f) - -;(begin (init-tnames)) - - (define-syntax (module-begin stx) - (define module-name (syntax-property stx 'enclosing-module-name)) - ;(printf "BEGIN: ~a~n" (syntax->datum stx)) (syntax-parse stx [(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...) - (nest - ([begin (set-box! typed-context? #t) - (start-timing module-name)] - [with-handlers - ([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e)))) - (lambda (e) (tc-error "Internal error: ~a" e))])] - [parameterize (;; enable fancy printing? - [custom-printer #t] - ;; a cheat to avoid units - [infer-param infer] - ;; do we report multiple errors - [delay-errors? #t] - ;; do we optimize? - [optimize? (or (attribute opt?) (optimize?))] - ;; this parameter is for parsing types - [current-tvars initial-tvar-env] - ;; 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])] - [begin (do-time "Initialized Envs")] - ;; local-expand the module - ;; pmb = #%plain-module-begin - [with-syntax ([new-mod - (local-expand (syntax/loc stx - (#%plain-module-begin - forms ...)) - 'module-begin - null)])] - [parameterize ([mutated-vars (find-mutated-vars #'new-mod)])] - [with-syntax ([(pmb body2 ...) #'new-mod])] - [begin (do-time "Local Expand Done")] - [with-syntax ([after-code (parameterize ([orig-module-stx (or (orig-module-stx) stx)] - [expanded-module-stx #'new-mod]) - (type-check #'(body2 ...)))] - [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))] - [(transformed-body ...) (remove-provides #'(body2 ...))])] - [with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])] - - [with-syntax ([(transformed-body ...) - (if (optimize?) - (begin (printf "optimizing ...\n") - (map optimize (syntax->list #'(transformed-body ...)))) - #'(transformed-body ...))])]) - (do-time "Typechecked") - #;(printf "checked ~a~n" module-name) - #;(printf "created ~a types~n" (count!)) - #;(printf "tried to create ~a types~n" (all-count!)) - #;(printf "created ~a union types~n" (union-count!)) + (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))]) + (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 (or (attribute opt?) (optimize?)) + (begin (printf "optimizing ...\n") + (begin0 (map optimize (syntax->list #'transformed-body)) + (do-time "Optimized"))) + #'transformed-body)]) ;; reconstruct the module with the extra code - #'(#%module-begin transformed-body ... after-code check-syntax-help))])) + ;; use the regular %#module-begin from `racket/base' for top-level printing + #`(#%module-begin optimized-body ... #,after-code check-syntax-help))))])) (define-syntax (top-interaction stx) - (syntax-case stx () - [(_ . (module . rest)) - (eq? 'module (syntax-e #'module)) + (syntax-parse stx + [(_ . ((~datum module) . rest)) #'(module . rest)] - [(_ . form) - (nest - ([begin (set-box! typed-context? #t)] - [parameterize (;; disable fancy printing - [custom-printer #t] - ;; a cheat to avoid units - [infer-param infer] - ;; this paramter is for parsing types - [current-tvars initial-tvar-env] - ;; 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)))))])] - ;(do-time "Initialized Envs") - ;; local-expand the module - [let ([body2 (local-expand #'(#%top-interaction . form) 'top-level null)])] - [parameterize ([orig-module-stx #'form] - [expanded-module-stx body2] - [mutated-vars (find-mutated-vars body2)])] - ;; typecheck the body, and produce syntax-time code that registers types - [let ([type (tc-toplevel-form body2)])]) - (define-syntax-class invis-kw - #:literals (define-values define-syntaxes #%require #%provide begin) - (pattern define-values) - (pattern define-syntaxes) - (pattern #%require) - (pattern #%provide) - (pattern begin)) - (syntax-parse body2 - [(head:invis-kw . _) - body2] - [_ (let ([ty-str (match type - [(tc-result1: (? (lambda (t) (type-equal? t -Void)))) #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))]))])) + [(_ . 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))]))])) From d1bbefe5bff15bb986d67942b6b815a81c88180b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 11 Jun 2010 11:53:39 -0400 Subject: [PATCH 021/198] minor refactorings original commit: 4f2952f4b9c69c6e77d64511b8a39f9729039778 --- collects/typed-scheme/private/with-types.rkt | 68 +++++++++----------- 1 file changed, 30 insertions(+), 38 deletions(-) diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-scheme/private/with-types.rkt index 8af94fdf..db090578 100644 --- a/collects/typed-scheme/private/with-types.rkt +++ b/collects/typed-scheme/private/with-types.rkt @@ -1,63 +1,57 @@ -#lang scheme/base +#lang racket/base -(require (for-syntax scheme/base syntax/parse mzlib/etc scheme/match) - scheme/require - "base-env.rkt" - "base-special-env.rkt" - "base-env-numeric.rkt" - "base-env-indexing.rkt" - "extra-procs.rkt" - "prims.rkt" - racket/contract/regions racket/contract/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 - "base-types-extra.rkt" - unstable/debug - (path-up "env/type-name-env.rkt" - "env/type-alias-env.rkt" - "infer/infer-dummy.rkt" - "private/parse-type.rkt" - "private/type-contract.rkt" - "typecheck/typechecker.rkt" - "env/type-environments.rkt" - "env/type-env.rkt" - "infer/infer.rkt" - "utils/tc-utils.rkt" - "types/utils.rkt") - (except-in (path-up "utils/utils.rkt" "types/convenience.rkt" "types/abbrev.rkt") infer ->))) + scheme/base 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" + "private/parse-type.rkt" + "private/type-contract.rkt" + "typecheck/typechecker.rkt" + "env/type-environments.rkt" + "env/type-env.rkt" + "infer/infer.rkt" + "utils/tc-utils.rkt" + "types/utils.rkt" + "types/convenience.rkt" + "types/abbrev.rkt") + ->) + (except-in (path-up "utils/utils.rkt") infer))) (provide with-type) (define-for-syntax (with-type-helper stx body fvids fvtys exids extys resty expr? ctx) - (begin-with-definitions + (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 - (lambda () (tc-error/stx stx "Type ~a could not be converted to a contract." t))))) + (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 - (lambda () (tc-error/stx stx "Type ~a could not be converted to a contract." t))))) + (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 - (lambda () (tc-error/stx #'region-ty-stx "Type ~a could not be converted to a contract." 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 - (lambda () (tc-error/stx #'region-ty-stx "Type ~a could not be converted to a contract." t))))]) + (no-contract t #'region-ty-stx)))]) null)) (for ([i (in-list (syntax->list fvids))] [ty (in-list fv-types)]) @@ -91,10 +85,8 @@ [type-name-references null] ;; for error reporting [orig-module-stx stx] - [expanded-module-stx expanded-body]) - (if expr? - (tc-expr/check expanded-body region-tc-result) - (tc-expr/check expanded-body (ret ex-types)))) + [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 From 946a8dd48f6fd84313ae8cdecacb02c1d9ff9c73 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 11 Jun 2010 11:53:55 -0400 Subject: [PATCH 022/198] new bug with mutation original commit: b649575afc2611ca0a3bec1f6f3d70e45ec011c1 --- .../typed-scheme/xfail/xmodule-mutation.rkt | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 collects/tests/typed-scheme/xfail/xmodule-mutation.rkt diff --git a/collects/tests/typed-scheme/xfail/xmodule-mutation.rkt b/collects/tests/typed-scheme/xfail/xmodule-mutation.rkt new file mode 100644 index 00000000..fb8dfc4f --- /dev/null +++ b/collects/tests/typed-scheme/xfail/xmodule-mutation.rkt @@ -0,0 +1,19 @@ +#lang racket/load + +(module m typed/racket + (: x Any) + (define x "foo") + (: f (-> Void)) + (define (f) (set! x 1)) + (provide f x)) + +(module n typed/racket + (require 'm) + (if (string? x) + (begin + (f) + ;; this should be a type error! + (string-append x "foo")) + 0)) + +(require 'n) From aa087d75dba11332c31c2f88bcbec7432bb30bd1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 11 Jun 2010 14:21:15 -0400 Subject: [PATCH 023/198] Fix optimizer for refactoring. original commit: fd1b20c93d195f236619a415e15c1b1dc8efde7f --- .../typed-scheme/succeed/optimize-simple.rkt | 3 ++ collects/typed-scheme/tc-setup.rkt | 6 +-- collects/typed-scheme/typed-scheme.rkt | 52 +++++++++---------- 3 files changed, 31 insertions(+), 30 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/optimize-simple.rkt diff --git a/collects/tests/typed-scheme/succeed/optimize-simple.rkt b/collects/tests/typed-scheme/succeed/optimize-simple.rkt new file mode 100644 index 00000000..035a3c75 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/optimize-simple.rkt @@ -0,0 +1,3 @@ +#lang typed/racket #:optimize + +(+ 3 4) diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt index 79f8abfd..f4e04141 100644 --- a/collects/typed-scheme/tc-setup.rkt +++ b/collects/typed-scheme/tc-setup.rkt @@ -4,7 +4,7 @@ (except-in syntax/parse id) unstable/mutated-vars scheme/base - (private type-contract optimize) + (private type-contract) (types utils convenience) (typecheck typechecker provide-handling tc-toplevel) (env type-environments type-name-env type-alias-env) @@ -13,9 +13,7 @@ (rep type-rep) (except-in (utils utils) infer) (only-in (r:infer infer-dummy) infer-param) - scheme/nest - syntax/kerncase - scheme/match + racket/match (for-syntax racket/base) (for-template racket/base)) diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 95ab29d3..bf710a4f 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -1,10 +1,10 @@ -#lang scheme/base +#lang racket/base (require (rename-in "utils/utils.rkt" [infer r:infer]) (private with-types) (for-syntax (except-in syntax/parse id) - unstable/syntax racket/base unstable/match + racket/match unstable/syntax racket/base unstable/match (private type-contract optimize) (types utils convenience) (typecheck typechecker provide-handling tc-toplevel) @@ -13,8 +13,7 @@ (utils tc-utils) (rep type-rep) (except-in (utils utils) infer) - (only-in (r:infer infer-dummy) infer-param) - scheme/match + (only-in (r:infer infer-dummy) infer-param) "tc-setup.rkt")) (provide (rename-out [module-begin #%module-begin] @@ -28,28 +27,29 @@ (syntax-parse stx [(mb (~optional (~and #:optimize (~bind [opt? #'#t]))) forms ...) (let ([pmb-form (syntax/loc stx (#%plain-module-begin forms ...))]) - (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 (or (attribute opt?) (optimize?)) - (begin (printf "optimizing ...\n") - (begin0 (map optimize (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))))])) + (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?) + (begin (printf "optimizing ...\n") + (begin0 (map optimize (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-syntax (top-interaction stx) (syntax-parse stx From aa6d48e80f9d1c7235983607332725e35334512d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 11 Jun 2010 16:51:13 -0400 Subject: [PATCH 024/198] Print names using the name, ignoring aliases. original commit: 7c32898cb29bb6baee4591bc05fa96621ff1d6d1 --- collects/typed-scheme/types/printer.rkt | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 2c0f959c..ebcb3196 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -6,7 +6,7 @@ ;; do we attempt to find instantiations of polymorphic types to print? ;; FIXME - currently broken -(define print-poly-types? #f) +(define print-poly-types? #t) ;; do we use simple type aliases in printing (define print-aliases #t) @@ -117,8 +117,8 @@ [(? Rep-stx a) (fp "~a" (syntax->datum (Rep-stx a)))] [(Univ:) (fp "Any")] - ;; special case number until something better happens - ;;[(Base: 'Number _) (fp "Number")] + ;; names are just the printed as the original syntax + [(Name: stx) (fp "~a" (syntax-e stx))] [(app has-name? (? values name)) (fp "~a" name)] [(StructTop: st) (fp "~a" st)] @@ -126,8 +126,6 @@ [(ChannelTop:) (fp "Channel")] [(VectorTop:) (fp "Vector")] [(MPairTop:) (fp "MPair")] - ;; names are just the printed as the original syntax - [(Name: stx) (fp "~a" (syntax-e stx))] [(App: rator rands stx) (fp "~a" (list* rator rands))] ;; special cases for lists From 79fe558827d75bc8fab2abbd62274a619cc7258a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 11 Jun 2010 18:54:05 -0400 Subject: [PATCH 025/198] Fix type of `zero?' to properly handle 0.0. original commit: 7ece2a4872bfd02d7b62b39c040e877c7ba638ee --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 1 + collects/typed-scheme/private/base-env-numeric.rkt | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 1f15665c..df5a9c17 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -807,6 +807,7 @@ (vector-ref #("a" "b") (sub1 x)) (vector-ref #("a" "b") (- x 1))) -String] + [tc-err (string-append "bar" (if (zero? (ann 0.0 Float)) #f "foo"))] ) (test-suite "check-type tests" diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index daf5aacb..f0ccb723 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -41,7 +41,8 @@ ) ;; numeric predicates -[zero? (make-pred-ty (list N) B -Zero)] +[zero? (asym-pred N B (-FS (-filter (Un -Flonum -Zero) 0) + (-not-filter -Zero 0)))] [number? (make-pred-ty N)] [integer? (asym-pred Univ B (-FS (-filter (Un -Integer -Flonum) 0) (-not-filter -Integer 0)))] From b19c37e9dfecee8c07efdcce745e3d5e4cabc944 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 11 Jun 2010 19:35:56 -0400 Subject: [PATCH 026/198] Actually typecheck actuals even when there's a type annotation. original commit: 1cff0a1f85e30ca231cde5fa94ec2d8c47b74d68 --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 5 ++++- collects/typed-scheme/typecheck/tc-app.rkt | 7 ++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index df5a9c17..93e88328 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -808,7 +808,10 @@ (vector-ref #("a" "b") (- x 1))) -String] [tc-err (string-append "bar" (if (zero? (ann 0.0 Float)) #f "foo"))] - ) + [tc-err (do: : Void + ([j : Natural (+ i 'a) (+ j i)]) + ((>= j 10)) + #f)]) (test-suite "check-type tests" (test-exn "Fails correctly" exn:fail:syntax? (lambda () (parameterize ([orig-module-stx #'here]) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 8d9e9bb9..d359b15f 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -238,9 +238,10 @@ [_ (let ([ts (for/list ([ac (syntax->list actuals)] [f (syntax->list args)]) - (or - (type-annotation f #:infer #t) - (generalize (tc-expr/t ac))))]) + (let ([infer-t (type-annotation f #:infer #t)]) + (if infer-t + (check-below (tc-expr/t ac) infer-t) + (generalize (tc-expr/t ac)))))]) (tc/rec-lambda/check form args body lp ts expected) expected)])) From aa18b9971ec318141f7d9adb0a59728fd1e14108 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 9 Jun 2010 17:50:59 -0400 Subject: [PATCH 027/198] Fixed a bug with eof and procedure types overlapping. original commit: 96c541912ccb6e752d83101c38f57d6da5984a42 --- collects/typed-scheme/types/remove-intersect.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt index abf9e562..af4e5d54 100644 --- a/collects/typed-scheme/types/remove-intersect.rkt +++ b/collects/typed-scheme/types/remove-intersect.rkt @@ -69,6 +69,9 @@ [(list (Struct: n p flds _ _ _ _ _ _) (Struct: n* p* flds* _ _ _ _ _ _)) (and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))] + [(list (== (-val eof)) + (Function: _)) + #f] [else #t])]))) From 450f6f98e23a5d7c3987449ac88530e89a7e8707 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 9 Jun 2010 17:51:27 -0400 Subject: [PATCH 028/198] Fixed string-copy!'s type signature. original commit: de0d9a27dc83c261a166d00cb6cfbefda7a70de3 --- collects/typed-scheme/private/base-env.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 072c20c0..fc0c9431 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -180,7 +180,7 @@ (-> (Un a (-val #f)) a)))] [gensym (->opt [Sym] Sym)] [string-append (->* null -String -String)] -[string-copy! (->opt -String -Nat -String -Nat [-Nat -Nat] -Void)] +[string-copy! (->opt -String -Nat -String [-Nat -Nat] -Void)] [open-input-string (-> -String -Input-Port)] [open-output-file (->key -Pathlike From dcf687d53b3a997c35fed13747f1a19499565859 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 11 Jun 2010 15:48:12 -0400 Subject: [PATCH 029/198] Made Typed Scheme's optimizer silent. original commit: a4c556bc85512ac720e9c11b3abeee9c8a8f5faa --- collects/typed-scheme/typed-scheme.rkt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index bf710a4f..b9b4a326 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -43,9 +43,8 @@ [(optimized-body ...) ;; do we optimize? (if (optimize?) - (begin (printf "optimizing ...\n") - (begin0 (map optimize (syntax->list #'transformed-body)) - (do-time "Optimized"))) + (begin0 (map optimize (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 From 0289d63af2caa58e39b47ecc20b4e4f0c6370675 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 10 Jun 2010 12:54:14 -0400 Subject: [PATCH 030/198] Fixed a bug in the optimizer that made it optimize where it shouldn't have. original commit: aae1acf035fb548067aef1dc3a9203a19ee76b90 --- collects/typed-scheme/private/optimize.rkt | 24 ++++++++++------------ collects/typed-scheme/types/type-table.rkt | 4 ++-- 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 8e7358ea..7d65e5a7 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -56,45 +56,43 @@ (define-syntax-class opt-expr* #:literal-sets (kernel-literals) - #:local-conventions ([#px"^e" opt-expr] - [#px"^f\\d*s?$" float-opt-expr] - [#px"^p\\d*s?$" pair-opt-expr]) ;; interesting cases, where something is optimized - (pattern (#%plain-app op:float-unary-op f) + (pattern (#%plain-app op:float-unary-op f:float-opt-expr) #:with opt (begin (log-optimization "unary float" #'op) #'(op.unsafe f.opt))) ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments - (pattern (#%plain-app op:float-binary-op f1 f2 fs ...) + (pattern (#%plain-app op:float-binary-op f1:float-opt-expr f2:float-opt-expr fs:float-opt-expr ...) #:with opt (begin (log-optimization "binary float" #'op) (for/fold ([o #'f1.opt]) ([e (syntax->list #'(f2.opt fs.opt ...))]) #`(op.unsafe #,o #,e)))) - (pattern (#%plain-app op:pair-unary-op p) + (pattern (#%plain-app op:pair-unary-op p:pair-opt-expr) #:with opt (begin (log-optimization "unary pair" #'op) #'(op.unsafe p.opt))) ;; boring cases, just recur down - (pattern (#%plain-lambda formals e ...) + (pattern (#%plain-lambda formals e:opt-expr ...) #:with opt #'(#%plain-lambda formals e.opt ...)) - (pattern (define-values formals e ...) + (pattern (define-values formals e:opt-expr ...) #:with opt #'(define-values formals e.opt ...)) - (pattern (case-lambda [formals e ...] ...) + (pattern (case-lambda [formals e:opt-expr ...] ...) #:with opt #'(case-lambda [formals e.opt ...] ...)) - (pattern (let-values ([ids e-rhs] ...) e-body ...) + (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] ...) e-body ...) + (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] ...) e-body ...) + (pattern (letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs:opt-expr] ...) e-body:opt-expr ...) #:with opt #'(letrec-syntaxes+values stx-bindings ([(ids ...) e-rhs.opt] ...) e-body.opt ...)) (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)) - #:with opt #'(kw expr.opt ...)) + #:with (expr*:opt-expr ...) #'(expr ...) ; we don't want to optimize in the cases that don't match the #:when clause + #:with opt #'(kw expr*.opt ...)) (pattern other:expr #:with opt #'other)) diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt index a8c17fbf..498768da 100644 --- a/collects/typed-scheme/types/type-table.rkt +++ b/collects/typed-scheme/types/type-table.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require unstable/debug "../utils/utils.rkt" (rep type-rep) (only-in (types abbrev utils) tc-results?) scheme/contract) +(require unstable/debug "../utils/utils.rkt" (rep type-rep) (only-in (types abbrev utils) tc-results?) (utils tc-utils) scheme/contract) (define table (make-hasheq)) @@ -10,7 +10,7 @@ (when (optimize?) (hash-set! table e t))) -(define (type-of e) (hash-ref table e)) +(define (type-of e) (hash-ref table e (lambda () (int-err (format "no type for ~a" (syntax->datum e)))))) (p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)] [type-of (syntax? . -> . tc-results?)] From 833693035f65f9cb3eec173e32b4ef3f58c5adc2 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 10 Jun 2010 13:58:41 -0400 Subject: [PATCH 031/198] Added some closure and promotion type signatures. original commit: c9a96c1d2c49e87ebbc26e837edf563b359f8c57 --- .../typed-scheme/private/base-env-numeric.rkt | 24 ++++++++----------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index f0ccb723..56885801 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -62,7 +62,8 @@ [odd? (-> -Integer B)] [even? (-> -Integer B)] -[modulo (cl->* (-Integer -Integer . -> . -Integer))] +[modulo (cl->* (-Nat -Nat . -> . -Nat) + (-Integer -Integer . -> . -Integer))] [= (->* (list N N) N B)] @@ -81,34 +82,28 @@ [* (apply cl->* (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) - (list (->* (list (Un -Integer -ExactRational -Real -Flonum)) - (Un -Integer -ExactRational -Real -Flonum) - -Flonum)) (list (->* (list) -Real -Real)) (list (->* (list) N N))))] [+ (apply cl->* (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) - (list (->* (list (Un -Integer -ExactRational -Real -Flonum)) - (Un -Integer -ExactRational -Real -Flonum) - -Flonum)) + ;; 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 -Flonum) -Real -Flonum)) + (list (->* (list -Real -Flonum) -Real -Flonum)) (list (->* (list) -Real -Real)) (list (->* (list) N N))))] [- (apply cl->* (append (for/list ([t (list -Integer -ExactRational -Flonum)]) (->* (list t) t t)) - (list (->* (list (Un -Integer -ExactRational -Real -Flonum)) - (Un -Integer -ExactRational -Real -Flonum) - -Flonum)) + (list (->* (list -Flonum) -Real -Flonum)) + (list (->* (list -Real -Flonum) -Real -Flonum)) (list (->* (list -Real) -Real -Real)) (list (->* (list N) N N))))] [/ (apply cl->* (append (list (->* (list -Integer) -Integer -ExactRational)) (for/list ([t (list -ExactRational -Flonum)]) (->* (list t) t t)) - (list (->* (list (Un -Integer -ExactRational -Real -Flonum)) - (Un -Integer -ExactRational -Real -Flonum) - -Flonum)) (list (->* (list -Real) -Real -Real)) (list (->* (list N) N N))))] @@ -169,7 +164,8 @@ [log (cl->* (-Pos . -> . -Real) (N . -> . N))] -[exp (N . -> . N)] +[exp (cl->* (-Real . -> . -Real) + (N . -> . N))] [cos (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] [sin (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] [tan (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] From fc607e7696cc7c7a783d25935fff4859a4bd52e2 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 10 Jun 2010 12:15:23 -0400 Subject: [PATCH 032/198] Added some stuff to typed scheme, mostly port and character functions. original commit: 90f015408cb021a258a0c25b3eb62f589fae33f3 --- collects/typed-scheme/private/base-env.rkt | 37 ++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index fc0c9431..105f992a 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -279,6 +279,7 @@ [void (->* '() Univ -Void)] [void? (make-pred-ty -Void)] [printf (->* (list -String) Univ -Void)] +[eprintf (->* (list -String) Univ -Void)] [fprintf (->* (list -Output-Port -String) Univ -Void)] [format (->* (list -String) Univ -String)] @@ -319,6 +320,22 @@ [string<=? (->* (list -String -String) -String B)] [string>=? (->* (list -String -String) -String B)] +[char-alphabetic? (-> -Char B)] +[char-lower-case? (-> -Char B)] +[char-upper-case? (-> -Char B)] +[char-title-case? (-> -Char B)] +[char-numeric? (-> -Char B)] +[char-symbolic? (-> -Char B)] +[char-punctuation? (-> -Char B)] +[char-graphic? (-> -Char B)] +[char-whitespace? (-> -Char B)] +[char-blank? (-> -Char B)] +[char-iso-control? (-> -Char B)] +[char-general-category (-> -Char (apply Un (map -val + '(lu ll lt lm lo mn mc me nd nl no ps pe pi pf pd + pc po sc sm sk so zs zp zl cc cf cs co cn))))] +[make-known-char-range-list (-> (-lst (-Tuple (list -ExactPositiveInteger -ExactPositiveInteger B))))] + [string-ci* (list -String -String) -String B)] [string-ci>? (->* (list -String -String) -String B)] [string-ci=? (->* (list -String -String) -String B)] @@ -335,6 +352,7 @@ [char-foldcase (-> -Char -Char)] [char->integer (-> -Char -Nat)] [integer->char (-> -Nat -Char)] +[char-utf-8-length (-> -Char (apply Un (map -val '(1 2 3 4 5 6))))] [string-normalize-nfd (-> -String -String)] [string-normalize-nfkd (-> -String -String)] @@ -567,6 +585,7 @@ [close-output-port (-> -Output-Port -Void)] [read-line (->opt [-Input-Port Sym] -String)] [copy-file (-> -Pathlike -Pathlike -Void)] +[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)] @@ -591,6 +610,9 @@ [open-output-bytes (cl->* [[Univ] . ->opt . -Output-Port])] [get-output-bytes (-Output-Port [Univ N N] . ->opt . -Bytes)] +[char-ready? (->opt [-Input-Port] B)] +[byte-ready? (->opt [-Input-Port] B)] + #;[exn:fail? (-> Univ B)] #;[exn:fail:read? (-> Univ B)] @@ -658,6 +680,8 @@ [list->string ((-lst -Char) . -> . -String)] [string->list (-String . -> . (-lst -Char))] +[build-string (-Nat (-Nat . -> . -Char) . -> . -String)] + [sort (-poly (a b) (cl->* ((-lst a) (a a . -> . B) #:cache-keys? B #f . ->key . (-lst a)) @@ -671,6 +695,12 @@ [path? (make-pred-ty -Path)] +;; scheme/function +[const (-poly (a) (-> a (->* '() Univ a)))] +(primitive? (-> Univ B)) +(primitive-closure? (-> Univ B)) + + ;; scheme/cmdline [parse-command-line @@ -712,6 +742,8 @@ ((-lst b) b) . ->... .(-lst c)))] [append* (-poly (a) ((-lst (-lst a)) . -> . (-lst a)))] +[argmin (-poly (a) ((a . -> . -Real) (-lst a) . -> . a))] +[argmax (-poly (a) ((a . -> . -Real) (-lst a) . -> . a))] ;; scheme/tcp [tcp-listener? (make-pred-ty -TCP-Listener)] @@ -741,10 +773,15 @@ ;; scheme/port [port->lines (cl->* ([-Input-Port] . ->opt . (-lst -String)))] +[port->bytes-lines (cl->* ([-Input-Port] . ->opt . (-lst -Bytes)))] +[port->list (-poly (a) (->opt [(-> -Input-Port a) -Input-Port] (-lst a)))] [port->bytes (->opt [-Input-Port] -Bytes)] +[port->string (->opt [-Input-Port] -String)] [with-output-to-string (-> (-> Univ) -String)] [open-output-nowhere (-> -Output-Port)] +[copy-port (->* (list -Input-Port -Output-Port) -Output-Port -Void)] + [input-port? (make-pred-ty -Input-Port)] [output-port? (make-pred-ty -Output-Port)] From c6730fa63b329fb64764230546e6be60bd7a2268 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 13 Jun 2010 14:34:16 -0400 Subject: [PATCH 033/198] Fix grammar for rest args in lambda:. Closes PR 10976 original commit: c2ac8046c45d4e807fb623f2048a4dbfabb6300d --- collects/typed-scheme/scribblings/ts-reference.scrbl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 10cc05e3..9912490b 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -267,7 +267,8 @@ Type-annotated versions of @defform/subs[(lambda: formals . body) ([formals ([v : t] ...) - ([v : t] ... . [v : t])])]{ + ([v : t] ... . [v : t *]) + ([v : t] ... . [v : t ...])])]{ A function of the formal arguments @racket[v], where each formal argument has the associated type. If a rest argument is present, then it has type @racket[(Listof t)].} From 3f3e732ac30dc4d4cd7c8e15e50ca705aadbcccd Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 13 Jun 2010 14:35:05 -0400 Subject: [PATCH 034/198] add \rightarrow as alias for -> original commit: 408d9adb5abaed3f3684e045b62225c13db01a9d --- collects/typed-scheme/private/base-types-extra.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/typed-scheme/private/base-types-extra.rkt b/collects/typed-scheme/private/base-types-extra.rkt index de39e172..43ba28ad 100644 --- a/collects/typed-scheme/private/base-types-extra.rkt +++ b/collects/typed-scheme/private/base-types-extra.rkt @@ -18,6 +18,7 @@ (provide (rename-out [All ∀] [U Un] + [-> →] [List Tuple] [Rec mu] [Parameterof Parameter])) From ae851e41cdf95f0537cfd438deaf2360eadf1fab Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 13 Jun 2010 14:35:37 -0400 Subject: [PATCH 035/198] Allow (All (A) A -> A), dropping pair of parens. original commit: d4d286d31dce759129c372c9e42bfb37300bf167 --- .../unit-tests/parse-type-tests.rkt | 5 +++++ collects/typed-scheme/private/parse-type.rkt | 21 +++++++++++++++---- .../scribblings/ts-reference.scrbl | 4 +++- 3 files changed, 25 insertions(+), 5 deletions(-) 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 b365336b..155a8026 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt @@ -74,6 +74,11 @@ [(-> (values Number Boolean Number)) (t:-> (-values (list N B N)))] [(Number -> Number) (t:-> N N)] [(Number -> Number) (t:-> N N)] + [(All (A) Number -> Number) (-poly (a) (t:-> N N))] + [(All (A) (Number -> Number)) (-poly (a) (t:-> N N))] + [(All (A) A -> A) (-poly (a) (t:-> a a))] + [(All (A) A → A) (-poly (a) (t:-> a a))] + [(All (A) (A -> A)) (-poly (a) (t:-> a a))] ;; requires transformer time stuff that doesn't work #;[(Refinement even?) (make-Refinement #'even?)] [(Number Number Number Boolean -> Number) (N N N B . t:-> . N)] diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index 3477ec06..1232d7ee 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -51,23 +51,36 @@ #:attr bound (datum->syntax #'i (string->symbol (substring (attribute s) 3)) #'i #'i)) (pattern (~seq _:ddd bound:id))) +(define (parse-all-body s) + (syntax-parse s + [(ty) + (parse-type #'ty)] + [(x ...) + #:fail-unless (= 1 (length + (for/list ([i (syntax->list #'(x ...))] + #:when (and (identifier? i) + (free-identifier=? i #'t:->))) + i))) + #f + (parse-type s)])) + (define (parse-all-type stx parse-type) ;(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) + [((~and kw t:All) (vars:id ... v:id dd:ddd) . t) (let* ([vars (map syntax-e (syntax->list #'(vars ...)))] [tvars (map make-F vars)] [v (syntax-e #'v)] [tv (make-Dotted (make-F v))]) (add-type-name-reference #'kw) (parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))]) - (make-PolyDots (append vars (list v)) (parse-type #'t))))] - [((~and kw t:All) (vars:id ...) t) + (make-PolyDots (append vars (list v)) (parse-all-body #'t))))] + [((~and kw t:All) (vars:id ...) . t) (let* ([vars (map syntax-e (syntax->list #'(vars ...)))] [tvars (map make-F vars)]) (add-type-name-reference #'kw) (parameterize ([current-tvars (extend-env vars tvars (current-tvars))]) - (make-Poly vars (parse-type #'t))))] + (make-Poly vars (parse-all-body #'t))))] [(t:All (_:id ...) _ _ _ ...) (tc-error "All: too many forms in body of All type")] [(t:All . rest) (tc-error "All: bad syntax")])) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 9912490b..f7cc38cd 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -202,7 +202,9 @@ The following base types are parameteric in their type arguments. @defform/none[(t t1 t2 ...)]{is the instantiation of the parametric type @racket[t] at types @racket[t1 t2 ...]} @defform[(All (v ...) t)]{is a parameterization of type @racket[t], with - type variables @racket[v ...]} + type variables @racket[v ...]. If @racket[t] is a function type + constructed with @racket[->], the outer pair of parentheses + around the function type may be omitted.} @defform[(values t ...)]{is the type of a sequence of multiple values, with types @racket[t ...]. This can only appear as the return type of a function. From b4d568a84dfc6bf97b3465b0c155f8e95839e73a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 13 Jun 2010 14:50:33 -0400 Subject: [PATCH 036/198] Generate -> instead of ->* when required by case->. Closes PR 10977. original commit: cf5c74a2ca36a951d7cbeac61e58235f493291dd --- .../tests/typed-scheme/fail/all-bad-syntax.rkt | 4 ++-- .../typed-scheme/succeed/provide-case-rest.rkt | 8 ++++++++ collects/typed-scheme/private/type-contract.rkt | 15 ++++++++++----- 3 files changed, 20 insertions(+), 7 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/provide-case-rest.rkt diff --git a/collects/tests/typed-scheme/fail/all-bad-syntax.rkt b/collects/tests/typed-scheme/fail/all-bad-syntax.rkt index c076f4d3..daf10f54 100644 --- a/collects/tests/typed-scheme/fail/all-bad-syntax.rkt +++ b/collects/tests/typed-scheme/fail/all-bad-syntax.rkt @@ -1,5 +1,5 @@ #; -(exn-pred 1) +(exn-pred 2) #lang typed-scheme (require scheme/list) @@ -22,4 +22,4 @@ (list key) (rt))) #;empty)) -(+ 'foo) \ No newline at end of file +(+ 'foo) diff --git a/collects/tests/typed-scheme/succeed/provide-case-rest.rkt b/collects/tests/typed-scheme/succeed/provide-case-rest.rkt new file mode 100644 index 00000000..02681eb3 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/provide-case-rest.rkt @@ -0,0 +1,8 @@ +#lang typed/racket + +(provide foo) + +(define foo + (case-lambda: + (((x : Number)) x) + (((x : Number) (y : Number) z : Number *) y))) diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt index c7cee8a1..914043ce 100644 --- a/collects/typed-scheme/private/type-contract.rkt +++ b/collects/typed-scheme/private/type-contract.rkt @@ -64,7 +64,7 @@ [(Function: arrs) (when flat? (exit (fail))) (let () - (define (f a) + (define ((f [case-> #f]) a) (define-values (dom* opt-dom* rngs* rst) (match a ;; functions with no filters or objects @@ -91,16 +91,21 @@ [(list r) r] [_ #`(values #,@rngs*)])] [rst* rst]) - (if (or rst (pair? (syntax-e #'(opt-dom* ...)))) - #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*) - #'(dom* ... . -> . rng*)))) + ;; Garr, I hate case->! + (if (and (pair? (syntax-e #'(opt-dom* ...))) case->) + (exit (fail)) + (if (or rst (pair? (syntax-e #'(opt-dom* ...)))) + (if case-> + #'(dom* ... #:rest (listof rst*) . -> . rng*) + #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*)) + #'(dom* ... . -> . rng*))))) (unless (no-duplicates (for/list ([t arrs]) (match t [(arr: dom _ _ _ _) (length dom)] ;; is there something more sensible here? [(top-arr:) (int-err "got top-arr")]))) (exit (fail))) - (match (map f arrs) + (match (map (f (not (= 1 (length arrs)))) arrs) [(list e) e] [l #`(case-> #,@l)]))] [_ (int-err "not a function" f)])) From 3c594198ce37c49c1d6b91a28b640e7052dd6954 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 13 Jun 2010 21:39:58 -0400 Subject: [PATCH 037/198] Type for `curry'. Closes PR 10956 original commit: 81f262c7caf0954f7efebebc6d10bef6c93972bd --- collects/typed-scheme/private/base-env.rkt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 105f992a..e64f0852 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -912,3 +912,8 @@ ;;write-special-evt [port-writes-atomic? (-Output-Port . -> . -Boolean)] [port-writes-special? (-Output-Port . -> . -Boolean)] + +;; probably the most useful cases +[curry (-poly (a b c) + (cl->* ((a b . -> . c) a . -> . (b . -> . c)) + ((a b . -> . c) . -> . (a . -> . (b . -> . c)))))] \ No newline at end of file From 8ddbeba6e32e79775bb005bbb7f0f84ae341a217 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 14 Jun 2010 17:23:42 -0400 Subject: [PATCH 038/198] fix types of `read' functions original commit: b644ec7be4c77e5b0ac8c66a1bc10283856447a9 --- collects/typed-scheme/private/base-env.rkt | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index e64f0852..11f7a992 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -190,7 +190,7 @@ 'must-truncate 'truncate/replace) #f -Output-Port)] -[read (->opt [-Input-Port] -Sexp)] +[read (->opt [-Input-Port] (Un -Sexp (-val eof)))] [ormap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))] [andmap (-polydots (a c d b) (cl->* ;; 1 means predicate on second argument @@ -567,7 +567,6 @@ ((-HT a b) -Integer . -> . a))] [hash-iterate-value (-poly (a b) ((-HT a b) -Integer . -> . b))] -#;[hash-table-index (-poly (a b) ((-HT a b) a b . -> . -Void))] [bytes (->* (list) -Integer -Bytes)] [make-bytes (cl-> [(-Integer -Integer) -Bytes] @@ -579,11 +578,11 @@ [bytes-length (-> -Bytes -Nat)] [unsafe-bytes-length (-> -Bytes -Nat)] -[read-bytes-line (->opt [-Input-Port Sym] -Bytes)] +[read-bytes-line (->opt [-Input-Port Sym] (Un -Bytes (-val eof)))] [open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)] [close-input-port (-> -Input-Port -Void)] [close-output-port (-> -Output-Port -Void)] -[read-line (->opt [-Input-Port Sym] -String)] +[read-line (->opt [-Input-Port Sym] (Un -String (-val eof)))] [copy-file (-> -Pathlike -Pathlike -Void)] [flush-output (->opt [-Output-Port] -Void)] [file-stream-buffer-mode (cl-> [(-Port) (Un (-val 'none) (-val 'line) (-val 'block) (-val #f))] @@ -613,11 +612,8 @@ [char-ready? (->opt [-Input-Port] B)] [byte-ready? (->opt [-Input-Port] B)] -#;[exn:fail? (-> Univ B)] -#;[exn:fail:read? (-> Univ B)] - [open-output-string (-> -Output-Port)] -;; FIXME - wrong +;; FIXME - this is too general [get-output-string (-> -Output-Port -String)] [make-directory (-> -Path -Void)] From 36d46fac77e3e9f7f3f85fdbda4a1018cf30b0ec Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 15 Jun 2010 14:59:08 -0400 Subject: [PATCH 039/198] eq? is a predicate for eof original commit: f73d63e1afdca9f509ff0a143ae2348875766ce2 --- .../tests/typed-scheme/unit-tests/typecheck-tests.rkt | 9 ++++++++- collects/typed-scheme/typecheck/tc-app.rkt | 2 +- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 93e88328..82a987df 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -811,7 +811,14 @@ [tc-err (do: : Void ([j : Natural (+ i 'a) (+ j i)]) ((>= j 10)) - #f)]) + #f)] + [tc-e/t + (let ([x eof]) + (if (procedure? x) + x + (lambda (z) (eq? x z)))) + (make-pred-ty (-val eof))] + ) (test-suite "check-type tests" (test-exn "Fails correctly" exn:fail:syntax? (lambda () (parameterize ([orig-module-stx #'here]) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index d359b15f..aef7db1e 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -41,7 +41,7 @@ ;; typecheck eq? applications ;; identifier expr expr -> tc-results (define (tc/eq comparator v1 v2) - (define (eq?-able e) (or (boolean? e) (keyword? e) (symbol? e))) + (define (eq?-able e) (or (boolean? e) (keyword? e) (symbol? e) (eof-object? e))) (define (eqv?-able e) (or (eq?-able e) (number? e))) (define (equal?-able e) #t) (define (ok? val) From 4ed047109d7778f8d226e2f429b3963956eb1f99 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 15 Jun 2010 15:58:22 -0400 Subject: [PATCH 040/198] types for basic mpair ops original commit: 913179f2ed6e601e795e07f79e2e38399626ad1e --- collects/typed-scheme/private/base-env.rkt | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 11f7a992..d2e869e8 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -13,6 +13,7 @@ (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) @@ -912,4 +913,9 @@ ;; probably the most useful cases [curry (-poly (a b c) (cl->* ((a b . -> . c) a . -> . (b . -> . c)) - ((a b . -> . c) . -> . (a . -> . (b . -> . c)))))] \ No newline at end of file + ((a b . -> . c) . -> . (a . -> . (b . -> . c)))))] +;; mutable pairs +[mcons (-poly (a b) (-> a b (-mpair a b)))] +[mcar (-poly (a b) (-> (-mpair a b) a))] +[mcdr (-poly (a b) (-> (-mpair a b) b))] +[mpair? (make-pred-ty (make-MPairTop))] From eed116763910ddc5bafe9084a9881fc42bd1ddcb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 15 Jun 2010 16:02:16 -0400 Subject: [PATCH 041/198] set-mc[ad]r!, inference, printing, tests for mpairs original commit: 4cc86cc8c808d375f10c2c1fa2e4b54b126a26da --- collects/tests/typed-scheme/succeed/mpair.rkt | 6 ++++++ collects/typed-scheme/infer/infer-unit.rkt | 2 ++ collects/typed-scheme/private/base-env.rkt | 2 ++ collects/typed-scheme/types/printer.rkt | 1 + 4 files changed, 11 insertions(+) create mode 100644 collects/tests/typed-scheme/succeed/mpair.rkt diff --git a/collects/tests/typed-scheme/succeed/mpair.rkt b/collects/tests/typed-scheme/succeed/mpair.rkt new file mode 100644 index 00000000..72475e8e --- /dev/null +++ b/collects/tests/typed-scheme/succeed/mpair.rkt @@ -0,0 +1,6 @@ +#lang typed/racket + +(define: x : (MPairof Integer Integer) (mcons 1 2)) +(set-mcar! x -7) +(mcar x) +(mcdr x) \ No newline at end of file diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 5b5a2d8e..bbd15f9f 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -414,6 +414,8 @@ (cset-meet (cg e e*) (cg e* e))] [((Box: e) (Box: e*)) (cset-meet (cg e e*) (cg e* e))] + [((MPair: s t) (MPair: s* t*)) + (cset-meet* (list (cg s s*) (cg s* s) (cg t t*) (cg t* t)))] [((Channel: e) (Channel: e*)) (cset-meet (cg e e*) (cg e* e))] [((Hashtable: s1 s2) (Hashtable: t1 t2)) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index d2e869e8..c23347ef 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -918,4 +918,6 @@ [mcons (-poly (a b) (-> a b (-mpair a b)))] [mcar (-poly (a b) (-> (-mpair a b) a))] [mcdr (-poly (a b) (-> (-mpair a b) b))] +[set-mcar! (-poly (a b) (-> (-mpair a b) a -Void))] +[set-mcdr! (-poly (a b) (-> (-mpair a b) b -Void))] [mpair? (make-pred-ty (make-MPairTop))] diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index ebcb3196..2ae5a06c 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -209,6 +209,7 @@ [(Result: t (FilterSet: (Top:) (Top:)) (Empty:)) (fp "~a" t)] [(Result: t fs (Empty:)) (fp "(~a : ~a)" t fs)] [(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)] + [(MPair: s t) (fp "(MPairof ~a ~a)" s t)] [(Refinement: parent p? _) (fp "(Refinement ~a ~a)" parent (syntax-e p?))] [(Sequence: ts) From e6d4962b4611380024cea4bbadaf45195bf1ef1f Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 15 Jun 2010 12:27:28 -0400 Subject: [PATCH 042/198] Reimplemented assert as a macro. original commit: 8dfd7d87ecd5d167514f8c7c5468448c6ad86547 --- collects/typed-scheme/private/extra-procs.rkt | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/private/extra-procs.rkt b/collects/typed-scheme/private/extra-procs.rkt index 6cd86438..b4a74b03 100644 --- a/collects/typed-scheme/private/extra-procs.rkt +++ b/collects/typed-scheme/private/extra-procs.rkt @@ -1,8 +1,10 @@ #lang scheme/base (provide assert) -(define (assert v [pred values]) - (unless (pred v) - (error "Assertion failed")) - v) - +(define-syntax assert + (syntax-rules () + ((assert v) + (or v (error "Assertion failed"))) + ((assert v pred) + (let ((val v)) + (if (pred val) val (error "Assertion failed")))))) From e45bc88bfb028146d0e9182ec1e445cfe009794f Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 14 Jun 2010 11:54:05 -0400 Subject: [PATCH 043/198] Moved some indexing functions' type signatures. original commit: 9959f050542aba1faee00202ce5b6b1f3cbf07cc --- .../private/base-env-indexing-abs.rkt | 41 ++++++++++++++++--- collects/typed-scheme/private/base-env.rkt | 31 +------------- 2 files changed, 38 insertions(+), 34 deletions(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index c27598b6..02c04b1c 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -1,19 +1,18 @@ -#lang scheme +#lang racket (require "../utils/utils.rkt" - scheme/tcp - scheme/unsafe/ops + 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]) - scheme/promise scheme/system + 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 scheme) + (for-template racket racket/unsafe/ops) (rename-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym] [-Nat -Nat*])) (provide indexing) @@ -28,6 +27,36 @@ [substring (->opt -String -Nat [-Nat] -String)] [make-string (cl-> [(-Nat) -String] [(-Nat -Char) -String])] [string-set! (-String -Nat -Char . -> . -Void)] + [string-copy! (-String -Nat -String [-Nat -Nat] . ->opt . -Void)] + + [read-string (-Nat [-Input-Port] . ->opt . (Un -String (-val eof)))] + [read-string! (-String [-Input-Port -Nat -Nat] . ->opt . (Un -Nat* (-val eof)))] + [read-bytes (-Nat [-Input-Port] . ->opt . (Un -Bytes (-val eof)))] + + [write-byte (cl-> [(-Nat) -Void] + [(-Nat -Output-Port) -Void])] + [write-string (cl-> [(-String) -Nat*] + [(-String -Output-Port) -Nat*] + [(-String -Output-Port -Nat) -Nat*] + [(-String -Output-Port -Nat -Nat) -Nat*])] + [write-bytes (cl-> [(-Bytes) -Nat*] + [(-Bytes -Output-Port) -Nat*] + [(-Bytes -Output-Port -Nat) -Nat*] + [(-Bytes -Output-Port -Nat -Nat) -Nat*])] + [write-bytes-avail (cl-> [(-Bytes) -Nat*] + [(-Bytes -Output-Port) -Nat*] + [(-Bytes -Output-Port -Nat) -Nat*] + [(-Bytes -Output-Port -Nat -Nat) -Nat*])] + [write-bytes-avail* (cl-> [(-Bytes) (-opt -Nat*)] + [(-Bytes -Output-Port) (-opt -Nat*)] + [(-Bytes -Output-Port -Nat) (-opt -Nat*)] + [(-Bytes -Output-Port -Nat -Nat) (-opt -Nat*)])] + [write-bytes-avail/enable-break (cl-> [(-Bytes) -Nat*] + [(-Bytes -Output-Port) -Nat*] + [(-Bytes -Output-Port -Nat) -Nat*] + [(-Bytes -Output-Port -Nat -Nat) -Nat*])] + + [list-ref (-poly (a) ((-lst a) -Nat . -> . a))] [list-tail (-poly (a) ((-lst a) -Nat . -> . (-lst a)))] @@ -101,6 +130,8 @@ (-poly (a) ((list (-lst a)) -Nat . ->* . (-values (list (-lst a) (-lst a)))))] [vector-ref (-poly (a) ((-vec a) -Nat . -> . a))] + [unsafe-vector-ref (-poly (a) ((-vec a) -Nat . -> . a))] + [unsafe-vector*-ref (-poly (a) ((-vec a) -Nat . -> . a))] [build-vector (-poly (a) (-Nat (-Nat . -> . a) . -> . (-vec a)))] [vector-set! (-poly (a) (-> (-vec a) -Nat a -Void))] [vector-copy! (-poly (a) ((-vec a) -Nat (-vec a) [-Nat -Nat] . ->opt . -Void))] diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index c23347ef..32d55e2a 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -181,7 +181,6 @@ (-> (Un a (-val #f)) a)))] [gensym (->opt [Sym] Sym)] [string-append (->* null -String -String)] -[string-copy! (->opt -String -Nat -String [-Nat -Nat] -Void)] [open-input-string (-> -String -Input-Port)] [open-output-file (->key -Pathlike @@ -602,9 +601,6 @@ [read-byte (cl->* [-> (Un -Byte (-val eof))] [-Input-Port . -> . (Un -Byte (-val eof))])] -[read-string (-Nat [-Input-Port] . ->opt . (Un -String (-val eof)))] -[read-string! (-String [-Input-Port -Nat -Nat] . ->opt . (Un -Nat (-val eof)))] -[read-bytes (-Nat [-Input-Port] . ->opt . (Un -Bytes (-val eof)))] [make-pipe (cl->* [->opt [N] (-values (list -Input-Port -Output-Port))])] [open-output-bytes @@ -754,7 +750,7 @@ [tcp-close (-TCP-Listener . -> . -Void )] [tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] [tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] -[tcp-listen (-Nat [-Nat Univ (-opt -String)] . ->opt . -TCP-Listener)] +[tcp-listen (-Integer [-Integer Univ (-opt -String)] . ->opt . -TCP-Listener)] ;; scheme/bool [boolean=? (B B . -> . B)] @@ -814,8 +810,6 @@ ;; unsafe -[unsafe-vector-ref (-poly (a) ((-vec a) -Nat . -> . a))] -[unsafe-vector*-ref (-poly (a) ((-vec a) -Nat . -> . a))] [unsafe-vector-length (-poly (a) ((-vec a) . -> . -Nat))] [unsafe-vector*-length (-poly (a) ((-vec a) . -> . -Nat))] [unsafe-car (-poly (a b) @@ -875,32 +869,11 @@ [system*/exit-code ((list -Pathlike) -String . ->* . -Integer)] ;; Byte and String Output (Section 12.3 of the Reference) +;; some are now in base-env-indexing-abs.rkt [write-char (cl-> [(-Char) -Void] [(-Char -Output-Port) -Void])] -[write-byte (cl-> [(-Nat) -Void] - [(-Nat -Output-Port) -Void])] [newline (cl-> [() -Void] [(-Output-Port) -Void])] -[write-string (cl-> [(-String) -Nat] - [(-String -Output-Port) -Nat] - [(-String -Output-Port -Nat) -Nat] - [(-String -Output-Port -Nat -Nat) -Nat])] -[write-bytes (cl-> [(-Bytes) -Nat] - [(-Bytes -Output-Port) -Nat] - [(-Bytes -Output-Port -Nat) -Nat] - [(-Bytes -Output-Port -Nat -Nat) -Nat])] -[write-bytes-avail (cl-> [(-Bytes) -Nat] - [(-Bytes -Output-Port) -Nat] - [(-Bytes -Output-Port -Nat) -Nat] - [(-Bytes -Output-Port -Nat -Nat) -Nat])] -[write-bytes-avail* (cl-> [(-Bytes) (-opt -Nat)] - [(-Bytes -Output-Port) (-opt -Nat)] - [(-Bytes -Output-Port -Nat) (-opt -Nat)] - [(-Bytes -Output-Port -Nat -Nat) (-opt -Nat)])] -[write-bytes-avail/enable-break (cl-> [(-Bytes) -Nat] - [(-Bytes -Output-Port) -Nat] - [(-Bytes -Output-Port -Nat) -Nat] - [(-Bytes -Output-Port -Nat -Nat) -Nat])] [write-special (cl-> [(Univ) -Boolean] [(Univ -Output-Port) -Boolean])] ;; Need event type before we can include these From 3900201b884b4363d9979225ecd24a886ad13ba8 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 14 Jun 2010 11:59:00 -0400 Subject: [PATCH 044/198] Rewrote the indexing code. original commit: bb0747f58925c574964234c22bb4ba1d07864e23 --- .../private/base-env-indexing-abs.rkt | 134 +++++++++--------- 1 file changed, 67 insertions(+), 67 deletions(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index 02c04b1c..e7c75642 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -13,58 +13,58 @@ (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) - (rename-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym] [-Nat -Nat*])) + (rename-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym])) (provide indexing) -(define-syntax-rule (indexing -Nat) +(define-syntax-rule (indexing index-type) (make-env - [build-list (-poly (a) (-Nat (-Nat* . -> . a) . -> . (-lst a)))] - [make-list (-poly (a) (-Nat a . -> . (-lst a)))] + [build-list (-poly (a) (index-type (-Nat . -> . a) . -> . (-lst a)))] + [make-list (-poly (a) (index-type a . -> . (-lst a)))] - [string-ref (-> -String -Nat -Char)] - [substring (->opt -String -Nat [-Nat] -String)] - [make-string (cl-> [(-Nat) -String] [(-Nat -Char) -String])] - [string-set! (-String -Nat -Char . -> . -Void)] - [string-copy! (-String -Nat -String [-Nat -Nat] . ->opt . -Void)] + [string-ref (-> -String index-type -Char)] + [substring (->opt -String index-type [index-type] -String)] + [make-string (cl-> [(index-type) -String] [(index-type -Char) -String])] + [string-set! (-String index-type -Char . -> . -Void)] + [string-copy! (-String index-type -String [index-type index-type] . ->opt . -Void)] - [read-string (-Nat [-Input-Port] . ->opt . (Un -String (-val eof)))] - [read-string! (-String [-Input-Port -Nat -Nat] . ->opt . (Un -Nat* (-val eof)))] - [read-bytes (-Nat [-Input-Port] . ->opt . (Un -Bytes (-val eof)))] + [read-string (index-type [-Input-Port] . ->opt . (Un -String (-val eof)))] + [read-string! (-String [-Input-Port index-type index-type] . ->opt . (Un -Nat (-val eof)))] + [read-bytes (index-type [-Input-Port] . ->opt . (Un -Bytes (-val eof)))] - [write-byte (cl-> [(-Nat) -Void] - [(-Nat -Output-Port) -Void])] - [write-string (cl-> [(-String) -Nat*] - [(-String -Output-Port) -Nat*] - [(-String -Output-Port -Nat) -Nat*] - [(-String -Output-Port -Nat -Nat) -Nat*])] - [write-bytes (cl-> [(-Bytes) -Nat*] - [(-Bytes -Output-Port) -Nat*] - [(-Bytes -Output-Port -Nat) -Nat*] - [(-Bytes -Output-Port -Nat -Nat) -Nat*])] - [write-bytes-avail (cl-> [(-Bytes) -Nat*] - [(-Bytes -Output-Port) -Nat*] - [(-Bytes -Output-Port -Nat) -Nat*] - [(-Bytes -Output-Port -Nat -Nat) -Nat*])] - [write-bytes-avail* (cl-> [(-Bytes) (-opt -Nat*)] - [(-Bytes -Output-Port) (-opt -Nat*)] - [(-Bytes -Output-Port -Nat) (-opt -Nat*)] - [(-Bytes -Output-Port -Nat -Nat) (-opt -Nat*)])] - [write-bytes-avail/enable-break (cl-> [(-Bytes) -Nat*] - [(-Bytes -Output-Port) -Nat*] - [(-Bytes -Output-Port -Nat) -Nat*] - [(-Bytes -Output-Port -Nat -Nat) -Nat*])] + [write-byte (cl-> [(index-type) -Void] + [(index-type -Output-Port) -Void])] + [write-string (cl-> [(-String) -Nat] + [(-String -Output-Port) -Nat] + [(-String -Output-Port index-type) -Nat] + [(-String -Output-Port index-type index-type) -Nat])] + [write-bytes (cl-> [(-Bytes) -Nat] + [(-Bytes -Output-Port) -Nat] + [(-Bytes -Output-Port index-type) -Nat] + [(-Bytes -Output-Port index-type index-type) -Nat])] + [write-bytes-avail (cl-> [(-Bytes) -Nat] + [(-Bytes -Output-Port) -Nat] + [(-Bytes -Output-Port index-type) -Nat] + [(-Bytes -Output-Port index-type index-type) -Nat])] + [write-bytes-avail* (cl-> [(-Bytes) (-opt -Nat)] + [(-Bytes -Output-Port) (-opt -Nat)] + [(-Bytes -Output-Port index-type) (-opt -Nat)] + [(-Bytes -Output-Port index-type index-type) (-opt -Nat)])] + [write-bytes-avail/enable-break (cl-> [(-Bytes) -Nat] + [(-Bytes -Output-Port) -Nat] + [(-Bytes -Output-Port index-type) -Nat] + [(-Bytes -Output-Port index-type index-type) -Nat])] - [list-ref (-poly (a) ((-lst a) -Nat . -> . a))] - [list-tail (-poly (a) ((-lst a) -Nat . -> . (-lst a)))] + [list-ref (-poly (a) ((-lst a) index-type . -> . a))] + [list-tail (-poly (a) ((-lst a) index-type . -> . (-lst a)))] [regexp-match (let ([?outp (-opt -Output-Port)] - [N -Nat] - [?N (-opt -Nat)] + [N index-type] + [?N (-opt index-type)] [optlist (lambda (t) (-opt (-lst (-opt t))))] [-StrRx (Un -String -Regexp -PRegexp)] [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] @@ -75,8 +75,8 @@ (-Pattern -InpBts [N ?N ?outp] . ->opt . (optlist -Bytes))))] [regexp-match? (let ([?outp (-opt -Output-Port)] - [N -Nat] - [?N (-opt -Nat)] + [N index-type] + [?N (-opt index-type)] [optlist (lambda (t) (-opt (-lst (-opt t))))] [-StrRx (Un -String -Regexp -PRegexp)] [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] @@ -86,8 +86,8 @@ (-BtsRx -String [N ?N ?outp] . ->opt . -Boolean) (-Pattern -InpBts [N ?N ?outp] . ->opt . -Boolean)))] [regexp-match* - (let ([N -Nat] - [?N (-opt -Nat)] + (let ([N index-type] + [?N (-opt index-type)] [-StrRx (Un -String -Regexp -PRegexp)] [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] [-InpBts (Un -Input-Port -Bytes)]) @@ -97,14 +97,14 @@ (-Pattern -InpBts [N ?N] . ->opt . (-lst -Bytes))))] [regexp-try-match (let ([?outp (-opt -Output-Port)] - [?N (-opt -Nat)] + [?N (-opt index-type)] [optlist (lambda (t) (-opt (-lst (-opt t))))]) - (->opt -Pattern -Input-Port [-Nat ?N ?outp] (optlist -Bytes)))] + (->opt -Pattern -Input-Port [index-type ?N ?outp] (optlist -Bytes)))] [regexp-match-positions (let ([?outp (-opt -Output-Port)] - [N -Nat] - [?N (-opt -Nat)] + [N index-type] + [?N (-opt index-type)] [optlist (lambda (t) (-opt (-lst (-opt t))))] [-StrRx (Un -String -Regexp -PRegexp)] [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] @@ -112,46 +112,46 @@ (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))] [regexp-match-positions* (let ([?outp (-opt -Output-Port)] - [?N (-opt -Nat)] + [?N (-opt index-type)] [optlist (lambda (t) (-opt (-lst (-opt t))))] [-StrRx (Un -String -Regexp -PRegexp)] [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] [-InpBts (Un -Input-Port -Bytes)]) - (->opt -Pattern (Un -String -InpBts) [-Nat ?N ?outp] (-lst (-pair -Nat -Nat))))] + (->opt -Pattern (Un -String -InpBts) [index-type ?N ?outp] (-lst (-pair -Nat -Nat))))] - [take (-poly (a) ((-lst a) -Nat . -> . (-lst a)))] - [drop (-poly (a) ((-lst a) -Nat . -> . (-lst a)))] - [take-right (-poly (a) ((-lst a) -Nat . -> . (-lst a)))] - [drop-right (-poly (a) ((-lst a) -Nat . -> . (-lst a)))] + [take (-poly (a) ((-lst a) index-type . -> . (-lst a)))] + [drop (-poly (a) ((-lst a) index-type . -> . (-lst a)))] + [take-right (-poly (a) ((-lst a) index-type . -> . (-lst a)))] + [drop-right (-poly (a) ((-lst a) index-type . -> . (-lst a)))] [split-at - (-poly (a) ((list (-lst a)) -Nat . ->* . (-values (list (-lst a) (-lst a)))))] + (-poly (a) ((list (-lst a)) index-type . ->* . (-values (list (-lst a) (-lst a)))))] [split-at-right - (-poly (a) ((list (-lst a)) -Nat . ->* . (-values (list (-lst a) (-lst a)))))] + (-poly (a) ((list (-lst a)) index-type . ->* . (-values (list (-lst a) (-lst a)))))] - [vector-ref (-poly (a) ((-vec a) -Nat . -> . a))] - [unsafe-vector-ref (-poly (a) ((-vec a) -Nat . -> . a))] - [unsafe-vector*-ref (-poly (a) ((-vec a) -Nat . -> . a))] - [build-vector (-poly (a) (-Nat (-Nat . -> . a) . -> . (-vec a)))] - [vector-set! (-poly (a) (-> (-vec a) -Nat a -Void))] - [vector-copy! (-poly (a) ((-vec a) -Nat (-vec a) [-Nat -Nat] . ->opt . -Void))] - [make-vector (-poly (a) (cl-> [(-Nat) (-vec -Nat)] - [(-Nat a) (-vec a)]))] + [vector-ref (-poly (a) ((-vec a) index-type . -> . a))] + [unsafe-vector-ref (-poly (a) ((-vec a) index-type . -> . a))] + [unsafe-vector*-ref (-poly (a) ((-vec a) index-type . -> . a))] + [build-vector (-poly (a) (index-type (index-type . -> . a) . -> . (-vec a)))] + [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 index-type)] + [(index-type a) (-vec a)]))] [peek-char - (cl->* [->opt [-Input-Port -Nat] (Un -Char (-val eof))])] + (cl->* [->opt [-Input-Port index-type] (Un -Char (-val eof))])] [peek-byte - (cl->* [->opt [-Input-Port -Nat] (Un -Byte (-val eof))])] + (cl->* [->opt [-Input-Port index-type] (Un -Byte (-val eof))])] ;; string.rkt - [real->decimal-string (N [-Nat] . ->opt . -String)] + [real->decimal-string (N [index-type] . ->opt . -String)] - [random (cl-> [(-Nat) -Nat*] [() -Real])] + [random (cl-> [(index-type) -Nat] [() -Real])] [raise-type-error (cl-> [(Sym -String Univ) (Un)] - [(Sym -String -Nat (-lst Univ)) (Un)])] + [(Sym -String index-type (-lst Univ)) (Un)])] )) \ No newline at end of file From 9eb47ff1a0d3f119c4a3d8acbfb9d5ea33a5d59f Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 15 Jun 2010 17:41:32 -0400 Subject: [PATCH 045/198] Added mutable lists to Typed Scheme. original commit: a31a7b07187573b9f0d9b8b7b9fcaa21bbb50b8f --- collects/typed-scheme/private/base-env.rkt | 20 +++++++++++++++---- .../typed-scheme/private/base-types-new.rkt | 1 + collects/typed-scheme/types/abbrev.rkt | 10 +++++++++- collects/typed-scheme/types/printer.rkt | 4 ++++ 4 files changed, 30 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 32d55e2a..19a1fc43 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -889,8 +889,20 @@ ((a b . -> . c) . -> . (a . -> . (b . -> . c)))))] ;; mutable pairs [mcons (-poly (a b) (-> a b (-mpair a b)))] -[mcar (-poly (a b) (-> (-mpair a b) a))] -[mcdr (-poly (a b) (-> (-mpair a b) b))] -[set-mcar! (-poly (a b) (-> (-mpair a b) a -Void))] -[set-mcdr! (-poly (a b) (-> (-mpair a b) b -Void))] +[mcar (-poly (a b) + (cl->* (-> (-mpair a b) a) + (-> (-mlst a) a)))] +[mcdr (-poly (a b) + (cl->* (-> (-mpair a b) b) + (-> (-mlst a) (-mlst a))))] +[set-mcar! (-poly (a b) + (cl->* (-> (-mpair a b) a -Void) + (-> (-mlst a) a -Void)))] +[set-mcdr! (-poly (a b) + (cl->* (-> (-mpair a b) b -Void) + (-> (-mlst a) (-mlst a) -Void)))] [mpair? (make-pred-ty (make-MPairTop))] +[mlist (-poly (a) (->* (list) a (-mlst a)))] +[mlength (-poly (a) (-> (-mlst a) -Nat))] +[mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))] +[mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))] diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types-new.rkt index 23f0118d..0b9e7b8f 100644 --- a/collects/typed-scheme/private/base-types-new.rkt +++ b/collects/typed-scheme/private/base-types-new.rkt @@ -55,5 +55,6 @@ [Nothing (Un)] [Pairof (-poly (a b) (-pair a b))] [MPairof (-poly (a b) (-mpair a b))] +[MListof (-poly (a) (-mlst a))] [Sequenceof (-poly (a) (-seq a))] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index a4bd73a5..d760dd9d 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -15,7 +15,8 @@ (for-template scheme/base scheme/contract scheme/promise scheme/tcp scheme/flonum)) (provide (all-defined-out) - (rename-out [make-Listof -lst])) + (rename-out [make-Listof -lst] + [make-MListof -mlst])) ;; convenient constructors @@ -36,6 +37,7 @@ (define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec)))) +(define (make-MListof elem) (-mu mlist-rec (*Un (-val null) (-mpair elem mlist-rec)))) (define (-lst* #:tail [tail (-val null)] . args) (for/fold ([tl tail]) ([a (reverse args)]) (-pair a tl))) @@ -62,6 +64,12 @@ [(_ elem-pats) #'(app untuple (? values elem-pats))]))) +(define-match-expander MListof: + (lambda (stx) + (syntax-parse stx + [(_ elem-pat) + #'(Mu: var (Union: (list (Value: '()) (MPair: elem-pat (F: var)))))]))) + (d/c (-result t [f -no-filter] [o -no-obj]) (c:->* (Type/c) (FilterSet? Object?) Result?) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 2ae5a06c..1892423e 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -133,6 +133,10 @@ (fp "(Listof ~a)" elem-ty)] [(Mu: var (Union: (list (Pair: elem-ty (F: var)) (Value: '())))) (fp "(Listof ~a)" elem-ty)] + [(Mu: var (Union: (list (Value: '()) (MPair: elem-ty (F: var))))) + (fp "(MListof ~a)" elem-ty)] + [(Mu: var (Union: (list (MPair: elem-ty (F: var)) (Value: '())))) + (fp "(MListof ~a)" elem-ty)] [(Value: v) (cond [(or (symbol? v) (null? v)) (fp "'~a" v)] [else (fp "~a" v)])] From 90039fecdc2c27951bc921c9d31b78dc36be9f2d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 11:26:33 -0400 Subject: [PATCH 046/198] Try harder to find types for loop variables. - use `find-annotation' more - recognize (let ([x y]) ...) original commit: bdbb6d48e62e8009154a095f1fc5752766ab34fe --- collects/tests/typed-scheme/succeed/for-in-range.rkt | 3 +++ collects/typed-scheme/typecheck/find-annotation.rkt | 8 +++++++- collects/typed-scheme/typecheck/tc-app.rkt | 8 +++++--- 3 files changed, 15 insertions(+), 4 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/for-in-range.rkt diff --git a/collects/tests/typed-scheme/succeed/for-in-range.rkt b/collects/tests/typed-scheme/succeed/for-in-range.rkt new file mode 100644 index 00000000..213e14dd --- /dev/null +++ b/collects/tests/typed-scheme/succeed/for-in-range.rkt @@ -0,0 +1,3 @@ +#lang typed/racket + +(for: ([i : Integer (in-range 10 0 -1)]) i) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/find-annotation.rkt b/collects/typed-scheme/typecheck/find-annotation.rkt index ceb9b79a..48b5612f 100644 --- a/collects/typed-scheme/typecheck/find-annotation.rkt +++ b/collects/typed-scheme/typecheck/find-annotation.rkt @@ -45,13 +45,19 @@ ;; expr id -> type or #f ;; if there is a binding in stx of the form: -;; (let ([x (reverse name)]) e) +;; (let ([x (reverse name)]) e) or +;; (let ([x name]) e) ;; where x has a type annotation, return that annotation, otherwise #f (define (find-annotation stx name) (define (find s) (find-annotation s name)) (define (match? b) (syntax-parse b #:literals (#%plain-app reverse) + [c:lv-clause + #:with n:id #'c.e + #:with (v) #'(c.v ...) + #:fail-unless (free-identifier=? name #'n) #f + (or (type-annotation #'v) (lookup-type/lexical #'v #:fail (lambda _ #f)))] [c:lv-clause #:with (#%plain-app reverse n:id) #'c.e #:with (v) #'(c.v ...) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index aef7db1e..d68d056c 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -235,12 +235,14 @@ (tc/rec-lambda/check form args body lp (cons acc-ty ts) expected) expected)] ;; special case when argument needs inference - [_ + [(_ (body*) _) (let ([ts (for/list ([ac (syntax->list actuals)] [f (syntax->list args)]) - (let ([infer-t (type-annotation f #:infer #t)]) + (let* ([infer-t (or (type-annotation f #:infer #t) + (find-annotation #'body* f))]) (if infer-t - (check-below (tc-expr/t ac) infer-t) + (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) expected)])) From 6b89ef5f82d0efb695dfe2904efb6638e280f337 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 11:33:51 -0400 Subject: [PATCH 047/198] base-types-new -> base-types original commit: 77e4bbb5eb5e568db8478d0e102b1a0f6ece50f9 --- collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt | 4 ++-- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 2 +- collects/typed-scheme/main.rkt | 2 +- .../private/{base-types-new.rkt => base-types.rkt} | 0 collects/typed-scheme/private/for-clauses.rkt | 2 +- collects/typed-scheme/private/prims.rkt | 2 +- collects/typed/racket/base.rkt | 2 +- collects/typed/scheme/base.rkt | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) rename collects/typed-scheme/private/{base-types-new.rkt => base-types.rkt} (100%) 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 155a8026..81390435 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt @@ -5,8 +5,8 @@ (rep type-rep) (rename-in (types comparison subtype union utils convenience) [Un t:Un] [-> t:->]) - (private base-types-new base-types-extra colon) - (for-template (private base-types-new base-types-extra base-env colon)) + (private base-types base-types-extra colon) + (for-template (private base-types base-types-extra base-env colon)) (private parse-type) rackunit) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 82a987df..d522b497 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -25,7 +25,7 @@ (env type-env) (private base-env base-env-numeric base-env-indexing)) - (for-template (private base-env base-types-new base-types-extra + (for-template (private base-env base-types base-types-extra base-env-numeric base-env-indexing)) (for-syntax syntax/kerncase syntax/parse)) diff --git a/collects/typed-scheme/main.rkt b/collects/typed-scheme/main.rkt index 0e907ace..c135bc51 100644 --- a/collects/typed-scheme/main.rkt +++ b/collects/typed-scheme/main.rkt @@ -4,7 +4,7 @@ (providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app) (except "private/prims.rkt") - (except "private/base-types-new.rkt") + (except "private/base-types.rkt") (except "private/base-types-extra.rkt")) (basics #%module-begin #%top-interaction diff --git a/collects/typed-scheme/private/base-types-new.rkt b/collects/typed-scheme/private/base-types.rkt similarity index 100% rename from collects/typed-scheme/private/base-types-new.rkt rename to collects/typed-scheme/private/base-types.rkt diff --git a/collects/typed-scheme/private/for-clauses.rkt b/collects/typed-scheme/private/for-clauses.rkt index 54013522..305bb2f4 100644 --- a/collects/typed-scheme/private/for-clauses.rkt +++ b/collects/typed-scheme/private/for-clauses.rkt @@ -3,7 +3,7 @@ (require syntax/parse "annotate-classes.rkt" (for-template racket/base - "base-types-new.rkt")) + "base-types.rkt")) (provide (all-defined-out)) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index d2263605..4905f204 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -48,7 +48,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (except-in mzlib/contract ->) (only-in mzlib/contract [-> c->]) mzlib/struct - "base-types-new.rkt" + "base-types.rkt" "base-types-extra.rkt") (define-for-syntax (ignore stx) (syntax-property stx 'typechecker:ignore #t)) diff --git a/collects/typed/racket/base.rkt b/collects/typed/racket/base.rkt index 6f7c5c75..b728ae5f 100644 --- a/collects/typed/racket/base.rkt +++ b/collects/typed/racket/base.rkt @@ -4,7 +4,7 @@ (providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct) (except typed-scheme/private/prims) - (except typed-scheme/private/base-types-new) + (except typed-scheme/private/base-types) (except typed-scheme/private/base-types-extra)) (basics #%module-begin #%top-interaction diff --git a/collects/typed/scheme/base.rkt b/collects/typed/scheme/base.rkt index fa662f89..2a751ed8 100644 --- a/collects/typed/scheme/base.rkt +++ b/collects/typed/scheme/base.rkt @@ -4,7 +4,7 @@ (providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct) (except typed-scheme/private/prims) - (except typed-scheme/private/base-types-new) + (except typed-scheme/private/base-types) (except typed-scheme/private/base-types-extra)) (basics #%module-begin #%top-interaction From d31b37acc11f85195337755c1b8f05cffc1ec0e7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 12:50:30 -0400 Subject: [PATCH 048/198] handle multiple body expression properly original commit: 0262ef681ac4394f9c2f8f19836777ee1fcc7a56 --- collects/typed-scheme/typecheck/tc-app.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index d68d056c..f1ffb5c3 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -235,11 +235,11 @@ (tc/rec-lambda/check form args body lp (cons acc-ty ts) expected) expected)] ;; special case when argument needs inference - [(_ (body*) _) + [(_ (body* ...) _) (let ([ts (for/list ([ac (syntax->list actuals)] [f (syntax->list args)]) (let* ([infer-t (or (type-annotation f #:infer #t) - (find-annotation #'body* f))]) + (find-annotation #'(begin body* ...) f))]) (if infer-t (begin (check-below (tc-expr/t ac) infer-t) infer-t) From 808861859657156f4a0719cf0d786dabbdb59150 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 15:18:04 -0400 Subject: [PATCH 049/198] Fix contract for structs original commit: 02238a7c6d713e9e210ab9efee994eb98c843284 --- collects/typed-scheme/rep/type-rep.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index a824bba0..5c9df275 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -218,7 +218,7 @@ #; [flds (listof (cons/c Type/c boolean?))] [proc (or/c #f Function?)] - [poly? boolean?] + [poly? (or/c #f (listof symbol?))] [pred-id identifier?] [cert procedure?] [acc-ids (listof identifier?)] From b67fd7f9f1e1a29b01f021e7ca75bc822627594f Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 16 Jun 2010 17:19:25 -0400 Subject: [PATCH 050/198] Got rid of a reference to the non-existent channel/c. original commit: c4e035dd67d44da53fb17003ad8342ed5fbdf6dd --- collects/typed-scheme/private/type-contract.rkt | 2 -- 1 file changed, 2 deletions(-) diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt index 914043ce..26b5b0d7 100644 --- a/collects/typed-scheme/private/type-contract.rkt +++ b/collects/typed-scheme/private/type-contract.rkt @@ -131,8 +131,6 @@ #`(vectorof #,(t->c t))] [(Box: t) #`(box/c #,(t->c t))] - [(Channel: t) - #`(channel/c #,(t->c t))] [(Pair: t1 t2) #`(cons/c #,(t->c t1) #,(t->c t2))] [(Opaque: p? cert) From f14d2fd415120b5e0ca7d6a8ef1855db243b19cf Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 17 Jun 2010 11:16:27 -0400 Subject: [PATCH 051/198] Added types for thread mailbox operations. Can't have typed mailboxes, though. original commit: cc796a9f9a1e0284dfd21328323cbedce416870c --- collects/typed-scheme/private/base-env.rkt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 19a1fc43..f0f3b830 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -294,6 +294,10 @@ [thread-running? (-Thread . -> . B)] [thread-dead? (-Thread . -> . B)] [thread-wait (-Thread . -> . -Void)] +[thread-send (-poly (a) (-Thread Univ [(-> a)] . ->opt . (Un -Void (-val #f) a)))] +[thread-receive (-> Univ)] +[thread-try-receive (-> Univ)] +[thread-rewind-receive (-> (-lst Univ) -Void)] [reverse (-poly (a) (-> (-lst a) (-lst a)))] [append (-poly (a) (->* (list) (-lst a) (-lst a)))] From 55a3f635546647e4296bc05ab9969847ab79e743 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 17 Jun 2010 12:32:42 -0400 Subject: [PATCH 052/198] Added types for some bitwise operations. original commit: 07c1f1e94f05cbbecd6d7606d725c0217f1d4a33 --- .../typed-scheme/private/base-env-numeric.rkt | 17 +++++++++++++++++ collects/typed-scheme/private/base-env.rkt | 14 -------------- 2 files changed, 17 insertions(+), 14 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 56885801..7d6aa00a 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -133,6 +133,23 @@ [quotient/remainder (cl->* (-Nat -Nat . -> . (-values (list -Nat -Nat))) (-Integer -Integer . -> . (-values (list -Integer -Integer))))] +[arithmetic-shift (cl->* (-Nat -Nat . -> . -Nat) + (-Integer -Integer . -> . -Integer))] +[bitwise-and (cl->* (null -Nat . ->* . -Nat) + (null -Integer . ->* . -Integer))] +[bitwise-ior (cl->* (null -Nat . ->* . -Nat) + (null -Integer . ->* . -Integer))] +[bitwise-not (cl->* (null -Nat . ->* . -Nat) + (null -Integer . ->* . -Integer))] +[bitwise-xor (cl->* (null -Nat . ->* . -Nat) + (null -Integer . ->* . -Integer))] +[bitwise-bit-set? (-> -Integer -Integer B)] +[bitwise-bit-field (-> -Integer -Integer -Integer -Integer)] +[integer-length (-> -Integer -Nat)] + +[abs (cl->* (-Integer . -> . -Nat) + (-Real . -> . -Real))] + ;; exactness [exact->inexact (cl->* (-Real . -> . -Flonum) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index f0f3b830..d381bc32 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -465,20 +465,6 @@ [match:error ((list) Univ . ->* . (Un))] -[arithmetic-shift (cl->* (-Nat -Nat . -> . -Nat) - (-Integer -Integer . -> . -Integer))] -[bitwise-and (cl->* (null -Nat . ->* . -Nat) - (null -Integer . ->* . -Integer))] -[bitwise-ior (cl->* (null -Nat . ->* . -Nat) - (null -Integer . ->* . -Integer))] -[bitwise-not (cl->* (null -Nat . ->* . -Nat) - (null -Integer . ->* . -Integer))] -[bitwise-xor (cl->* (null -Nat . ->* . -Nat) - (null -Integer . ->* . -Integer))] - -[abs (cl->* (-Integer . -> . -Nat) - (-Real . -> . -Real))] - [file-exists? (-Pathlike . -> . B)] [string->symbol (-String . -> . Sym)] [symbol->string (Sym . -> . -String)] From 361fee5e5971cd9199c4b92f8915fe664a381d34 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 17 Jun 2010 14:09:07 -0400 Subject: [PATCH 053/198] Fixed the type of unsafe-car and unsafe-cdr. original commit: b39f686e7eb67a6d3dac96fcc94cc2480aa083f2 --- collects/typed-scheme/private/base-env.rkt | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index d381bc32..a8a22634 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -803,11 +803,14 @@ [unsafe-vector-length (-poly (a) ((-vec a) . -> . -Nat))] [unsafe-vector*-length (-poly (a) ((-vec a) . -> . -Nat))] [unsafe-car (-poly (a b) - (cl->* - (->acc (list (-pair a b)) a (list -car))))] + (cl->* + (->acc (list (-pair a b)) a (list -car)) + (->* (list (-lst a)) a)))] [unsafe-cdr (-poly (a b) - (cl->* - (->acc (list (-pair a b)) b (list -cdr))))] + (cl->* + (->acc (list (-pair a b)) b (list -cdr)) + (->* (list (-lst a)) (-lst a))))] + ;; scheme/vector [vector-count (-polydots (a b) From ec41142ab40e8261ec86a29c7ffd7c933e39af20 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 14 Jun 2010 13:05:12 -0400 Subject: [PATCH 054/198] Turned indexing back to using integers rather than naturals. original commit: 60c3067ddb9b187855c81eabd6c5e89d74ebcbff --- collects/typed-scheme/private/base-env-indexing.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env-indexing.rkt b/collects/typed-scheme/private/base-env-indexing.rkt index e345ab7e..23b72c05 100644 --- a/collects/typed-scheme/private/base-env-indexing.rkt +++ b/collects/typed-scheme/private/base-env-indexing.rkt @@ -5,7 +5,7 @@ (for-syntax (types abbrev) (env init-envs) (r:infer infer-dummy infer) "base-env-indexing-abs.rkt")) -(define-for-syntax e (parameterize ([infer-param infer]) (indexing -Nat))) +(define-for-syntax e (parameterize ([infer-param infer]) (indexing -Integer))) (begin-for-syntax (initialize-type-env e)) From af2fa50318fdfacee97396cc0410fb1645c7f2de Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 17 Jun 2010 12:13:50 -0400 Subject: [PATCH 055/198] Added type signatures for some byte-string functions. original commit: ecb614849c30cc437b2cb7004321bc9e88fba8fa --- collects/typed-scheme/private/base-env.rkt | 24 +++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index a8a22634..140ec67a 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -559,14 +559,35 @@ ((-HT a b) -Integer . -> . b))] [bytes (->* (list) -Integer -Bytes)] +[bytes? (make-pred-ty -Bytes)] [make-bytes (cl-> [(-Integer -Integer) -Bytes] [(-Integer) -Bytes])] +[bytes->immutable-bytes (-> -Bytes -Bytes)] +[byte? (make-pred-ty -Nat)] [bytes-ref (-> -Bytes -Integer -Nat)] [bytes-set! (-> -Bytes -Integer -Integer -Void)] [bytes-append (->* (list) -Bytes -Bytes)] [subbytes (cl-> [(-Bytes -Integer) -Bytes] [(-Bytes -Integer -Integer) -Bytes])] [bytes-length (-> -Bytes -Nat)] +[bytes-copy (-> -Bytes -Bytes)] +[bytes-copy! (-Bytes -Integer -Bytes [-Integer -Integer] . ->opt . -Void)] +[bytes-fill! (-> -Bytes -Integer -Void)] [unsafe-bytes-length (-> -Bytes -Nat)] +[bytes->list (-> -Bytes (-lst -Nat))] +[list->bytes (-> (-lst -Integer) -Bytes)] +[bytes* (list -Bytes) -Bytes B)] +[bytes>? (->* (list -Bytes) -Bytes B)] +[bytes=? (->* (list -Bytes) -Bytes B)] +[bytes->string/utf-8 (-Bytes [(Un (-val #f) -Char) -Integer -Integer] . ->opt . -String)] +[bytes->string/locale (-Bytes [(Un (-val #f) -Char) -Integer -Integer] . ->opt . -String)] +[bytes->string/latin-1 (-Bytes [(Un (-val #f) -Char) -Integer -Integer] . ->opt . -String)] +[string->bytes/utf-8 (-String [(Un (-val #f) -Integer) -Integer -Integer] . ->opt . -Bytes)] +[string->bytes/locale (-String [(Un (-val #f) -Integer) -Integer -Integer] . ->opt . -Bytes)] +[string->bytes/latin-1 (-String [(Un (-val #f) -Integer) -Integer -Integer] . ->opt . -Bytes)] +[string-utf-8-length (-String [-Integer -Integer] . ->opt . -Nat)] +[bytes-utf-8-length (-Bytes [(Un (-val #f) -Char) -Integer -Integer] . ->opt . -Nat)] +[bytes-utf-8-ref (-Bytes [-Integer (Un (-val #f) -Char) -Integer -Integer] . ->opt . -Char)] +[bytes-utf-8-index (-Bytes [-Integer (Un (-val #f) -Char) -Integer -Integer] . ->opt . -Nat)] [read-bytes-line (->opt [-Input-Port Sym] (Un -Bytes (-val eof)))] [open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)] @@ -578,11 +599,8 @@ [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)] -[bytes->string/utf-8 (-> -Bytes -String)] -[string->bytes/utf-8 (-> -String -Bytes)] [force (-poly (a) (-> (-Promise a) a))] -[bytes* (list -Bytes) -Bytes B)] [regexp-replace* (cl->* (-Pattern -String -String . -> . -String) (-Pattern (Un -Bytes -String) (Un -Bytes -String) . -> . -Bytes))] From a4b8973528e014ec2891a2e85bf540335908a997 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 18 Jun 2010 15:20:08 -0400 Subject: [PATCH 056/198] Added the type of the 1 literals in expressions of the form (- x 1) to the type table. original commit: 5d835ded47e51e29a86a457e97f87f88561fe1d8 --- collects/typed-scheme/typecheck/tc-app.rkt | 3 ++- collects/typed-scheme/typecheck/tc-expr-unit.rkt | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index f1ffb5c3..ff4e3f68 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -13,7 +13,7 @@ ;; end fixme (for-syntax syntax/parse scheme/base (utils tc-utils)) (private type-annotation) - (types utils abbrev union subtype resolve convenience) + (types utils abbrev union subtype resolve convenience type-table) (utils tc-utils) (only-in srfi/1 alist-delete) (except-in (env type-environments) extend) @@ -544,6 +544,7 @@ [_ (int-err "bad expected: ~a" expected)])] ;; special case for `-' used like `sub1' [(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1))) + (add-typeof-expr #'arg2 -Nat) (match-let ([(tc-result1: t) (single-value #'v)]) (if (subtype t -ExactPositiveInteger) (ret -Nat) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 6a102aca..8ebd4156 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -384,7 +384,7 @@ (and (identifier? #'name*) (free-identifier=? #'name #'name*)) (match expected [(tc-result1: t) - (with-lexical-env/extend (list #'name) (list t) (tc-expr/check/internal #'expr expected))] + (with-lexical-env/extend (list #'name) (list t) (tc-expr/check #'expr expected))] [(tc-results: ts) (tc-error/expr #:return (ret (Un)) "Expected ~a values, but got only 1" (length ts))])] [(letrec-values ([(name ...) expr] ...) . body) From 034e27a280ad71220bb9c0a431ade2d1efdf90c7 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 17 Jun 2010 19:02:23 -0400 Subject: [PATCH 057/198] The optimizer now promotes integers to floats when they are used as arguments to a function whose result is a float. original commit: 5e901b9ef28a9d48f41fb05e7e4be57b34897180 --- collects/typed-scheme/private/optimize.rkt | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 7d65e5a7..e34c5b65 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -3,7 +3,7 @@ (require syntax/parse (for-template scheme/base scheme/flonum scheme/unsafe/ops) "../utils/utils.rkt" unstable/match scheme/match unstable/syntax (rep type-rep) - (types abbrev type-table utils)) + (types abbrev type-table utils subtype)) (provide optimize) (define-syntax-class float-opt-expr @@ -12,6 +12,20 @@ [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) #:with opt #'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 + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -Integer (lambda (x y) (subtype y x)))) #t] [_ #f]) + #:with opt #'(->fl e.opt)) + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) + #:with opt #'e.opt)) + (define-syntax-class float-binary-op #:literals (+ - * / = <= < > >= min max fl+ fl- fl* fl/ fl= fl<= fl< fl> fl>= flmin flmax) @@ -63,8 +77,10 @@ (begin (log-optimization "unary float" #'op) #'(op.unsafe f.opt))) ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments - (pattern (#%plain-app op:float-binary-op f1:float-opt-expr f2:float-opt-expr fs:float-opt-expr ...) - #:with opt + (pattern (~and res (#%plain-app op:float-binary-op f1:float-arg-expr f2:float-arg-expr fs:float-arg-expr ...)) + #:when (match (type-of #'res) + [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) + #:with opt (begin (log-optimization "binary float" #'op) (for/fold ([o #'f1.opt]) ([e (syntax->list #'(f2.opt fs.opt ...))]) From cfce17b8d1acc0d37d2e382a7f5423437e9ecd52 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 18 Jun 2010 20:23:56 -0400 Subject: [PATCH 058/198] Fix to make-vector's type. original commit: 1e2c50ec242c130df1a02e7bee6734d2806f8aa7 --- collects/typed-scheme/private/base-env-indexing-abs.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index e7c75642..e2e73e9b 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -135,7 +135,7 @@ [build-vector (-poly (a) (index-type (index-type . -> . a) . -> . (-vec a)))] [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 index-type)] + [make-vector (-poly (a) (cl-> [(index-type) (-vec -Nat)] [(index-type a) (-vec a)]))] [peek-char @@ -154,4 +154,4 @@ [(Sym -String index-type (-lst Univ)) (Un)])] )) - \ No newline at end of file + From a4cec9ce13bb653e06708778441c7bda428dfca7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 15:57:13 -0400 Subject: [PATCH 059/198] Fix error message for 1-arg apply original commit: 1e15ce1f3299d235cd72eeb171f7224099fba41a --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 1 + collects/typed-scheme/typecheck/tc-app.rkt | 6 +++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index d522b497..47bb0db8 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -812,6 +812,7 @@ ([j : Natural (+ i 'a) (+ j i)]) ((>= j 10)) #f)] + [tc-err (apply +)] [tc-e/t (let ([x eof]) (if (procedure? x) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index ff4e3f68..45012175 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -257,7 +257,11 @@ ;; produces the first n-1 elements of the list, and the last element (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))]) (values f (car r)))) - (define-values (fixed-args tail) (split (syntax->list args))) + (define-values (fixed-args tail) + (let ([args* (syntax->list args)]) + (if (null? args*) + (tc-error "apply requires a final list argument, given only a function argument of type ~a" (match f-ty [(tc-result1: t) t])) + (split args*)))) (match f-ty [(tc-result1: (Function: (list (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...)) ...))) From c903ffe15c2f332aaee2d410adbb88ce3b98241e Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 18 Jun 2010 19:09:41 -0400 Subject: [PATCH 060/198] Fix use of add-type-expr from commit 5d835ded. original commit: 0aae2c866f2906c1b4111aff438d3f931afa43f7 --- collects/typed-scheme/typecheck/tc-app.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 45012175..b981f24e 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -548,7 +548,7 @@ [_ (int-err "bad expected: ~a" expected)])] ;; special case for `-' used like `sub1' [(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1))) - (add-typeof-expr #'arg2 -Nat) + (add-typeof-expr #'arg2 (ret -Nat)) (match-let ([(tc-result1: t) (single-value #'v)]) (if (subtype t -ExactPositiveInteger) (ret -Nat) From 3f49f996dee80e38b12e7287136d052cbbc290e7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 21 Jun 2010 15:39:40 -0400 Subject: [PATCH 061/198] Refactor provide handling. - use id-tables instead of lists - smarter iteration - prepare for eliminating declarations when not needed, but don't do it yet original commit: 4925e7e51f487e3e9dcc3646a28cd30bf334cd02 --- collects/typed-scheme/env/init-envs.rkt | 16 +- .../typed-scheme/typecheck/def-export.rkt | 27 +++ .../typecheck/provide-handling.rkt | 188 +++++++----------- .../typed-scheme/typecheck/tc-toplevel.rkt | 34 +++- 4 files changed, 141 insertions(+), 124 deletions(-) create mode 100644 collects/typed-scheme/typecheck/def-export.rkt diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt index 9fbf1a51..72c7d8be 100644 --- a/collects/typed-scheme/env/init-envs.rkt +++ b/collects/typed-scheme/env/init-envs.rkt @@ -4,7 +4,7 @@ "type-env.rkt" "type-name-env.rkt" "type-alias-env.rkt" - unstable/struct + unstable/struct racket/dict (rep type-rep object-rep filter-rep rep-utils) (for-template (rep type-rep object-rep filter-rep) (types union) @@ -80,7 +80,7 @@ (show-sharing #f) (booleans-as-true/false #f)) (with-syntax ([registers (filter (lambda (x) x) (type-name-env-map f))]) - #'(begin (begin-for-syntax . registers))))) + #'(begin-for-syntax . registers)))) (define (talias-env-init-code) (define (f id ty) @@ -91,18 +91,20 @@ (show-sharing #f) (booleans-as-true/false #f)) (with-syntax ([registers (filter (lambda (x) x) (type-alias-env-map f))]) - #'(begin (begin-for-syntax . registers))))) + #'(begin-for-syntax . registers)))) -(define (env-init-code) +(define (env-init-code syntax-provide? provide-tbl def-tbl) (define (f id ty) - (if (bound-in-this-module id) + (if (and (bound-in-this-module id) + ;; if there are no syntax provides, then we only need this identifier if it's provided + #;(or syntax-provide? (dict-ref provide-tbl id #f))) #`(register-type #'#,id #,(datum->syntax #'here (print-convert ty))) #f)) (parameterize ((current-print-convert-hook converter) (show-sharing #f) (booleans-as-true/false #f)) - (with-syntax ([registers (filter (lambda (x) x) (type-env-map f))]) - #'(begin (begin-for-syntax . registers))))) + (with-syntax ([registers (filter values (type-env-map f))]) + #'(begin-for-syntax . registers)))) diff --git a/collects/typed-scheme/typecheck/def-export.rkt b/collects/typed-scheme/typecheck/def-export.rkt new file mode 100644 index 00000000..acf624d6 --- /dev/null +++ b/collects/typed-scheme/typecheck/def-export.rkt @@ -0,0 +1,27 @@ +#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"))) +(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) + #'(define-syntax export-id + (if (unbox typed-context?) + (renamer #'id #:alt #'cnt-id) + (renamer #'cnt-id)))] + [(def-export export-id:identifier id:identifier cnt-id:identifier #:alias) + #'(define-syntax export-id + (if (unbox typed-context?) + (begin + (add-alias #'export-id #'id) + (renamer #'id #:alt #'cnt-id)) + (renamer #'cnt-id)))])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/provide-handling.rkt b/collects/typed-scheme/typecheck/provide-handling.rkt index 504cfb1c..48734be0 100644 --- a/collects/typed-scheme/typecheck/provide-handling.rkt +++ b/collects/typed-scheme/typecheck/provide-handling.rkt @@ -9,16 +9,14 @@ (private typed-renaming) (rep type-rep) (utils tc-utils) + (for-syntax syntax/parse racket/base) racket/contract/private/provide unstable/list - unstable/debug + unstable/debug syntax/id-table racket/dict unstable/syntax scheme/struct-info scheme/match - "def-binding.rkt" syntax/parse) + "def-binding.rkt" syntax/parse + (for-template scheme/base "def-export.rkt" scheme/contract)) -(require (for-template scheme/base - scheme/contract)) - -(provide remove-provides provide? generate-prov - get-alternate) +(provide remove-provides provide? generate-prov get-alternate) (define (provide? form) (syntax-parse form @@ -29,21 +27,13 @@ (define (remove-provides forms) (filter (lambda (e) (not (provide? e))) (syntax->list forms))) -(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)))) - -;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key -(define mapping (make-free-identifier-mapping)) - (define (mem? i vd) (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] [else #f])) -;; generate-contract-defs : listof[def-binding] listof[def-binding] id -> syntax -> syntax -;; val-defs: define-values in this module -;; stx-defs: define-syntaxes in this module +;; generate-contract-defs : dict[id -> def-binding] dict[id -> id] id -> syntax +;; defs: defines in this module +;; provs: provides in this module ;; pos-blame-id: a #%variable-reference for the module ;; internal-id : the id being provided @@ -52,105 +42,79 @@ ;; anything already recorded in the mapping is given an empty (begin) and the already-recorded id ;; otherwise, we will map internal-id to the fresh id in `mapping' -(define ((generate-prov stx-defs val-defs pos-blame-id) form) +(define (generate-prov defs provs pos-blame-id) + ;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key + (define mapping (make-free-id-table)) + ;; mk : id [id] -> (values syntax id) (define (mk internal-id [new-id (generate-temporary internal-id)]) + (define (mk-untyped-syntax b defn-id internal-id) + (match b + [(def-struct-stx-binding _ (? struct-info? si)) + (match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)]) + (let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e) + (mk e) + (values #'(begin) e))) + (list* type-desc constr pred super accs))]) + (with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids]) + (if (identifier? i) + #`(syntax #,i) + i))]) + #`(begin + #,@defns + (define-syntax #,defn-id + (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))] + [_ + #`(define-syntax #,defn-id + (lambda (stx) + (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))])) (cond ;; if it's already done, do nothing - [(free-identifier-mapping-get mapping internal-id - ;; if it wasn't there, put it in, and skip this case - (lambda () - (free-identifier-mapping-put! mapping internal-id new-id) - #f)) - => (lambda (mapped-id) - (values #'(begin) mapped-id))] - [(mem? internal-id val-defs) + [(dict-ref mapping internal-id + ;; if it wasn't there, put it in, and skip this case + (λ () (dict-set! mapping internal-id new-id) #f)) + => (λ (mapped-id) (values #'(begin) mapped-id))] + [(dict-ref defs internal-id #f) => - (lambda (b) - (values - (with-syntax ([id internal-id]) - (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t) - => - (lambda (cnt) - (with-syntax ([(cnt-id) (generate-temporaries #'(id))] - [export-id new-id] - [module-source pos-blame-id] - [the-contract (generate-temporary 'generated-contract)]) - #`(begin - (define the-contract #,cnt) - (define-syntax cnt-id - (make-provide/contract-transformer - (quote-syntax the-contract) - (quote-syntax id) - (quote-syntax out-id) - (quote-syntax module-source))) - (define-syntax export-id - (if (unbox typed-context?) - (renamer #'id #:alt #'cnt-id) - (renamer #'cnt-id))))))] - [else - (with-syntax ([(error-id) (generate-temporaries #'(id))] - [export-id new-id]) - #`(begin - (define-syntax error-id - (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))) - (define-syntax export-id - (if (unbox typed-context?) - (renamer #'id #:alt #'error-id) - (renamer #'error-id)))))])) - new-id))] - [(mem? internal-id stx-defs) - => - (lambda (b) - (define (mk-untyped-syntax defn-id internal-id) - (match b - [(struct def-struct-stx-binding (_ (? struct-info? si))) - (match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)]) - (let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e) - (mk e) - (values #'(begin) e))) - (list* type-desc constr pred super accs))]) - (with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids]) - (if (identifier? i) - #`(syntax #,i) - i))]) - #`(begin - #,@defns - (define-syntax #,defn-id - (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))] - [_ - #`(define-syntax #,defn-id - (lambda (stx) - (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))])) - (with-syntax* ([id internal-id] - [export-id new-id] - [(untyped-id) (generate-temporaries #'(id))]) - (values - #`(begin - #,(mk-untyped-syntax #'untyped-id internal-id) - (define-syntax export-id - (if (unbox typed-context?) - (begin - (add-alias #'export-id #'id) - (renamer #'id #:alt #'untyped-id)) - (renamer #'untyped-id)))) - new-id)))] + (match-lambda + [(def-binding _ (app (λ (ty) (type->contract ty (λ () #f) #:out #t)) (? values cnt))) + (values + (with-syntax* ([id internal-id] + [cnt-id (generate-temporary #'id)] + [export-id new-id] + [module-source pos-blame-id] + [the-contract (generate-temporary 'generated-contract)]) + #`(begin + (define the-contract #,cnt) + (define-syntax cnt-id + (make-provide/contract-transformer + (quote-syntax the-contract) + (quote-syntax id) + (quote-syntax out-id) + (quote-syntax module-source))) + (def-export export-id id cnt-id))) + new-id)] + [(def-binding id ty) + (values + (with-syntax* ([id internal-id] + [error-id (generate-temporary #'id)] + [export-id new-id]) + #'(begin + (define-syntax (error-id stx) + (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))) + (def-export export-id id error-id))) + new-id)] + [(and b (def-stx-binding _)) + (with-syntax* ([id internal-id] + [export-id new-id] + [untyped-id (generate-temporary #'id)] + [def (mk-untyped-syntax b #'untyped-id internal-id)]) + (values + #`(begin def (def-export export-id id untyped-id #:alias)) + new-id))])] ;; otherwise, not defined in this module, not our problem [else (values #'(begin) internal-id)])) - ;; do-one : id [id] -> syntax - (define (do-one internal-id [external-id internal-id]) + ;; do-one : id id -> syntax + (for/list ([(internal-id external-id) (in-dict provs)]) (define-values (defs id) (mk internal-id)) - #`(begin #,defs (provide (rename-out [#,id #,external-id])))) - (syntax-parse form #:literals (#%provide) - [(#%provide form ...) - (for/list ([f (syntax->list #'(form ...))]) - (parameterize ([current-orig-stx f]) - (syntax-parse f - [i:id - (do-one #'i)] - [((~datum rename) in out) - (do-one #'in #'out)] - [((~datum protect) . _) - (tc-error "provide: protect not supported by Typed Scheme")] - [_ (int-err "unknown provide form")])))] - [_ (int-err "non-provide form! ~a" (syntax->datum form))])) + #`(begin #,defs (provide (rename-out [#,id #,external-id]))))) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index da080236..fde65f83 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -19,6 +19,7 @@ "provide-handling.rkt" "def-binding.rkt" (prefix-in c: racket/contract) + racket/dict (for-template "internal-forms.rkt" unstable/location @@ -259,24 +260,47 @@ ;; do pass 1, and collect the defintions (define defs (apply append (filter list? (map tc-toplevel/pass1 forms)))) ;; separate the definitions into structures we'll handle for provides - (define stx-defs (filter def-stx-binding? defs)) - (define val-defs (filter def-binding? defs)) + (define def-tbl + (for/fold ([h (make-immutable-free-id-table)]) + ([def (in-list defs)]) + (dict-set h (binding-name def) def))) ;; typecheck the expressions and the rhss of defintions (for-each tc-toplevel/pass2 forms) ;; check that declarations correspond to definitions (check-all-registered-types) ;; report delayed errors (report-all-errors) + (define syntax-provide? #f) + (define provide-tbl + (for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)]) + (syntax-parse p #:literals (#%provide) + [(#%provide form ...) + (for/fold ([h h]) ([f (syntax->list #'(form ...))]) + (parameterize ([current-orig-stx f]) + (syntax-parse f + [i:id + (when (def-stx-binding? (dict-ref def-tbl #'i #f)) + (set! syntax-provide? #t)) + (dict-set h #'i #'i)] + [((~datum rename) in out) + (when (def-stx-binding? (dict-ref def-tbl #'in #f)) + (set! syntax-provide? #t)) + (dict-set h #'in #'out)] + [((~datum protect) . _) + (tc-error "provide: protect not supported by Typed Scheme")] + [_ (int-err "unknown provide form")])))] + [_ (int-err "non-provide form! ~a" (syntax->datum p))]))) ;; compute the new provides (with-syntax* ([the-variable-reference (generate-temporary #'blame)] - [((new-provs ...) ...) (map (generate-prov stx-defs val-defs #'the-variable-reference) provs)]) + [(new-provs ...) + (generate-prov def-tbl provide-tbl #'the-variable-reference)]) #`(begin (define the-variable-reference (quote-module-path)) - #,(env-init-code) + #,(env-init-code syntax-provide? provide-tbl def-tbl) #,(tname-env-init-code) #,(talias-env-init-code) - (begin new-provs ... ...))))) + (begin new-provs ...))))) ;; typecheck a whole module ;; syntax -> syntax From f581c7796dd198efd643cca4bd8caa507d3db852 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 21 May 2010 17:29:26 -0400 Subject: [PATCH 062/198] Refactor environments. - mapping stored as dict - use id tables for identifiers - use env-filter instead of filter - eliminate spurious use of conses original commit: 647c4eef5940fde0395f9a19496244acab5f62b2 --- collects/typed-scheme/env/lexical-env.rkt | 3 +- collects/typed-scheme/env/type-env.rkt | 3 + .../typed-scheme/env/type-environments.rkt | 58 +++++++++---------- collects/typed-scheme/private/parse-type.rkt | 5 +- collects/typed-scheme/typecheck/tc-envops.rkt | 2 +- 5 files changed, 37 insertions(+), 34 deletions(-) diff --git a/collects/typed-scheme/env/lexical-env.rkt b/collects/typed-scheme/env/lexical-env.rkt index deef63f3..7dc17e4a 100644 --- a/collects/typed-scheme/env/lexical-env.rkt +++ b/collects/typed-scheme/env/lexical-env.rkt @@ -3,6 +3,7 @@ (require "../utils/utils.rkt" "type-environments.rkt" "type-env.rkt" + unstable/mutated-vars syntax/id-table (only-in scheme/contract ->* -> or/c any/c listof cons/c) (utils tc-utils) (only-in (rep type-rep) Type/c) @@ -16,7 +17,7 @@ [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (env?) . ->* . env?)]) ;; the current lexical environment -(define lexical-env (make-parameter (make-empty-env free-identifier=?))) +(define lexical-env (make-parameter (make-empty-env (make-immutable-free-id-table)))) ;; run code in a new env (define-syntax-rule (with-lexical-env e . b) diff --git a/collects/typed-scheme/env/type-env.rkt b/collects/typed-scheme/env/type-env.rkt index 0cb028b8..369f6cfd 100644 --- a/collects/typed-scheme/env/type-env.rkt +++ b/collects/typed-scheme/env/type-env.rkt @@ -1,5 +1,8 @@ #lang scheme/base +;; Top-level type environment +;; maps identifiers to their types, updated by mutation + (require "../utils/utils.rkt" syntax/id-table (utils tc-utils) diff --git a/collects/typed-scheme/env/type-environments.rkt b/collects/typed-scheme/env/type-environments.rkt index 2254d948..f71dae5c 100644 --- a/collects/typed-scheme/env/type-environments.rkt +++ b/collects/typed-scheme/env/type-environments.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/contract +(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 (except-in (r:utils tc-utils) make-env) @@ -15,8 +15,8 @@ dotted-env initial-tvar-env env-map + make-empty-env env-filter - env-vals env-keys+vals env-props replace-props @@ -24,58 +24,60 @@ ;; 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 ([eq? (any/c any/c . -> . boolean?)] [l (listof pair?)] [props (listof Filter/c)]) #:transparent) - -(define (env-vals e) - (map cdr (env-l e))) - -(define (env-keys+vals e) - (env-l e)) +(r:d-s/c env ([l (and/c (not/c dict-mutable?) dict?)] [props (listof Filter/c)]) #:transparent) (define (env-filter f e) (match e - [(struct env (eq? l props)) - (make-env eq? (filter f l) props)])) + [(struct env (l props)) + (make-env (for/fold ([h l]) + ([(k v) (in-dict l)] + #:when (not (f (cons k v)))) + (dict-remove h k)) + props)])) -(define (make-empty-env p?) (make-env p? null null)) +(r:d/c (make-empty-env dict) + (dict? . -> . env?) + (make-env dict null)) + +(define (env-keys+vals e) + (match e + [(env l _) (for/list ([(k v) (in-dict l)]) (cons k v))])) ;; the initial type variable environment - empty ;; this is used in the parsing of types -(define initial-tvar-env (make-empty-env eq?)) +(define initial-tvar-env (make-empty-env #hasheq())) ;; a parameter for the current type variables (define current-tvars (make-parameter initial-tvar-env)) ;; the environment for types of ... variables -(define dotted-env (make-parameter (make-empty-env free-identifier=?))) +(define dotted-env (make-parameter (make-empty-env (make-immutable-free-id-table)))) (r:d/c (env-map f e) - ((pair? . -> . pair?) env? . -> . env?) - (make-env (env-eq? e) (map f (env-l e)) (env-props e))) + ((any/c any/c . -> . any/c) env? . -> . env?) + (make-env (dict-map f (env-l e)) (env-props e))) ;; extend that works on single arguments (define (extend e k v) (match e - [(struct env (f l p)) (make-env f (cons (cons k v) l) p)] + [(env l p) (make-env (dict-set l k v) p)] [_ (int-err "extend: expected environment, got ~a" e)])) (define (extend-env ks vs e) (match e - [(struct env (f l p)) (make-env f (append (map cons ks vs) l) p)] + [(env l p) (make-env (for/fold ([h l]) + ([k (in-list ks)] [v (in-list vs)]) (dict-set h k v)) + p)] [_ (int-err "extend-env: expected environment, got ~a" e)])) (define (replace-props e props) (match e - [(struct env (f l p)) - (make-env f l props)])) + [(env l p) + (make-env l props)])) (define (lookup e key fail) (match e - [(struct env (f? l p)) - (let loop ([l l]) - (cond [(null? l) (fail key)] - [(f? (caar l) key) (cdar l)] - [else (loop (cdr l))]))] + [(env l p) (dict-ref l key (λ () (fail key)))] [_ (int-err "lookup: expected environment, got ~a" e)])) @@ -87,12 +89,10 @@ (extend-env ks vs env)] [(or (list? ks) (list? vs)) (int-err "not both lists in extend/values: ~a ~a" ks vs)] - [else (extend-env (list ks) (list vs) env)])) + [else (extend env ks vs)])) env kss vss)) ;; run code in an extended dotted env (define-syntax with-dotted-env/extend (syntax-rules () - [(_ i t v . b) (parameterize ([dotted-env (extend/values (list i) (list (cons t v)) (dotted-env))]) . b)])) - -(r:p/c [make-empty-env ((-> any/c any/c any/c) . -> . env?)]) + [(_ i t v . b) (parameterize ([dotted-env (extend (dotted-env) i (cons t v))]) . b)])) diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index 1232d7ee..799a26c2 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -239,8 +239,7 @@ (syntax-e #'bound))))))] [(dom:expr ... rest:expr _:ddd (~and kw t:->) rng) (add-type-name-reference #'kw) - (let ([bounds (filter (compose Dotted? cdr) - (env-keys+vals (current-tvars)))]) + (let ([bounds (env-keys+vals (env-filter (compose Dotted? cdr) (current-tvars)))]) (when (null? bounds) (tc-error/stx stx "No type variable bound with ... in scope for ... type")) (unless (null? (cdr bounds)) @@ -363,7 +362,7 @@ (syntax-e #'bound))))] [((~and kw values) tys ... dty _:ddd) (add-type-name-reference #'kw) - (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) + (let ([bounds (env-keys+vals (env-filter (compose Dotted? cdr) (current-tvars)))]) (when (null? bounds) (tc-error/stx stx "No type variable bound with ... in scope for ... type")) (unless (null? (cdr bounds)) diff --git a/collects/typed-scheme/typecheck/tc-envops.rkt b/collects/typed-scheme/typecheck/tc-envops.rkt index 274a52bb..ce4b5f31 100644 --- a/collects/typed-scheme/typecheck/tc-envops.rkt +++ b/collects/typed-scheme/typecheck/tc-envops.rkt @@ -70,7 +70,7 @@ (define-values (props atoms) (combine-props fs (env-props env) flag)) (for/fold ([Γ (replace-props env (append atoms props))]) ([f atoms]) (match f - [(Bot:) (set-box! flag #f) (env-map (lambda (x) (cons (car x) (Un))) Γ)] + [(Bot:) (set-box! flag #f) (env-map (lambda (k v) (Un)) Γ)] [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x)) (update-type/lexical (lambda (x t) (let ([new-t (update t f)]) (when (type-equal? new-t (Un)) From 8676d0ac03766c2e4affcd39221996ae64b2de1c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 21 May 2010 17:44:15 -0400 Subject: [PATCH 063/198] Stratify environments to only include props when needed. original commit: 7e9763cf14cd180db251e48fc864b23768897442 --- collects/typed-scheme/env/lexical-env.rkt | 6 +-- .../typed-scheme/env/type-environments.rkt | 50 ++++++++++++------- 2 files changed, 35 insertions(+), 21 deletions(-) diff --git a/collects/typed-scheme/env/lexical-env.rkt b/collects/typed-scheme/env/lexical-env.rkt index 7dc17e4a..4d0ebe25 100644 --- a/collects/typed-scheme/env/lexical-env.rkt +++ b/collects/typed-scheme/env/lexical-env.rkt @@ -13,11 +13,11 @@ (provide lexical-env with-lexical-env with-lexical-env/extend with-update-type/lexical with-lexical-env/extend/props) (p/c - [lookup-type/lexical ((identifier?) (env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))] - [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (env?) . ->* . env?)]) + [lookup-type/lexical ((identifier?) (lex-env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))] + [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (lex-env?) . ->* . env?)]) ;; the current lexical environment -(define lexical-env (make-parameter (make-empty-env (make-immutable-free-id-table)))) +(define lexical-env (make-parameter (make-empty-lex-env (make-immutable-free-id-table)))) ;; run code in a new env (define-syntax-rule (with-lexical-env e . b) diff --git a/collects/typed-scheme/env/type-environments.rkt b/collects/typed-scheme/env/type-environments.rkt index f71dae5c..3d12aa60 100644 --- a/collects/typed-scheme/env/type-environments.rkt +++ b/collects/typed-scheme/env/type-environments.rkt @@ -20,28 +20,43 @@ env-keys+vals env-props replace-props - with-dotted-env/extend) + with-dotted-env/extend + lex-env? make-empty-lex-env) ;; 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?)] [props (listof Filter/c)]) #:transparent) +(r:d-s/c env ([l (and/c (not/c dict-mutable?) dict?)]) #:transparent) +(r:d-s/c (lex-env env) ([props (listof Filter/c)]) #:transparent) + +(define (mk-env orig dict) + (match orig + [(lex-env _ p) (lex-env dict p)] + [_ (env dict)])) (define (env-filter f e) (match e - [(struct env (l props)) - (make-env (for/fold ([h l]) - ([(k v) (in-dict l)] - #:when (not (f (cons k v)))) - (dict-remove h k)) - props)])) + [(env l) + (mk-env e + (for/fold ([h l]) + ([(k v) (in-dict l)] + #:when (not (f (cons k v)))) + (dict-remove h k)))])) (r:d/c (make-empty-env dict) (dict? . -> . env?) - (make-env dict null)) + (env dict)) + +(r:d/c (make-empty-lex-env dict) + (dict? . -> . lex-env?) + (lex-env dict null)) + +(r:d/c (env-props e) + (lex-env? . -> . (listof Filter/c)) + (lex-env-props e)) (define (env-keys+vals e) (match e - [(env l _) (for/list ([(k v) (in-dict l)]) (cons k v))])) + [(env l) (for/list ([(k v) (in-dict l)]) (cons k v))])) ;; the initial type variable environment - empty ;; this is used in the parsing of types @@ -55,29 +70,28 @@ (r:d/c (env-map f e) ((any/c any/c . -> . any/c) env? . -> . env?) - (make-env (dict-map f (env-l e)) (env-props e))) + (mk-env e (dict-map f (env-l e)))) ;; extend that works on single arguments (define (extend e k v) (match e - [(env l p) (make-env (dict-set l k v) p)] + [(env l) (mk-env e (dict-set l k v))] [_ (int-err "extend: expected environment, got ~a" e)])) (define (extend-env ks vs e) (match e - [(env l p) (make-env (for/fold ([h l]) - ([k (in-list ks)] [v (in-list vs)]) (dict-set h k v)) - p)] + [(env l) (mk-env e (for/fold ([h l]) + ([k (in-list ks)] [v (in-list vs)]) (dict-set h k v)))] [_ (int-err "extend-env: expected environment, got ~a" e)])) (define (replace-props e props) (match e - [(env l p) - (make-env l props)])) + [(lex-env l p) + (lex-env l props)])) (define (lookup e key fail) (match e - [(env l p) (dict-ref l key (λ () (fail key)))] + [(env l) (dict-ref l key (λ () (fail key)))] [_ (int-err "lookup: expected environment, got ~a" e)])) From 021e1146cbbe1083b609e39cce981665a99442e5 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 21 May 2010 18:20:47 -0400 Subject: [PATCH 064/198] More environment refactoring. - rationalize naming of files - split files by env constructed original commit: 50f93b9ed7abeb1d4e687078cb5fef6976d008aa --- .../unit-tests/parse-type-tests.rkt | 2 +- .../typed-scheme/unit-tests/subtype-tests.rkt | 2 +- .../unit-tests/typecheck-tests.rkt | 4 +- .../env/{type-env.rkt => global-env.rkt} | 0 collects/typed-scheme/env/init-envs.rkt | 2 +- collects/typed-scheme/env/lexical-env.rkt | 17 ++++--- collects/typed-scheme/env/tvar-env.rkt | 15 +++++++ ...-environments.rkt => type-env-structs.rkt} | 45 ++++++------------- collects/typed-scheme/infer/infer-unit.rkt | 2 +- collects/typed-scheme/private/parse-type.rkt | 2 +- .../typed-scheme/private/type-annotation.rkt | 2 +- collects/typed-scheme/private/with-types.rkt | 5 ++- collects/typed-scheme/tc-setup.rkt | 4 +- collects/typed-scheme/typecheck/tc-app.rkt | 2 +- collects/typed-scheme/typecheck/tc-envops.rkt | 2 +- .../typed-scheme/typecheck/tc-expr-unit.rkt | 2 +- collects/typed-scheme/typecheck/tc-if.rkt | 2 +- .../typed-scheme/typecheck/tc-lambda-unit.rkt | 2 +- .../typed-scheme/typecheck/tc-let-unit.rkt | 2 +- .../typed-scheme/typecheck/tc-structs.rkt | 2 +- .../typed-scheme/typecheck/tc-toplevel.rkt | 4 +- collects/typed-scheme/typed-scheme.rkt | 2 +- 22 files changed, 63 insertions(+), 59 deletions(-) rename collects/typed-scheme/env/{type-env.rkt => global-env.rkt} (100%) create mode 100644 collects/typed-scheme/env/tvar-env.rkt rename collects/typed-scheme/env/{type-environments.rkt => type-env-structs.rkt} (65%) 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 81390435..5174bbda 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt @@ -1,7 +1,7 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base) (utils tc-utils) - (env type-alias-env type-environments type-name-env init-envs) + (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:->]) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt index 6248771a..2851efd5 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt @@ -3,7 +3,7 @@ (require "test-utils.ss" (types subtype convenience union) (rep type-rep) - (env init-envs type-environments) + (env init-envs type-env-structs) (r:infer infer infer-dummy) rackunit (for-syntax scheme/base)) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 47bb0db8..3ab510d6 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -17,12 +17,12 @@ [-> t:->]) (utils tc-utils utils) unstable/mutated-vars - (env type-name-env type-environments init-envs) + (env type-name-env type-env-structs init-envs) rackunit rackunit/text-ui syntax/parse (for-syntax (utils tc-utils) (typecheck typechecker) - (env type-env) + (env global-env) (private base-env base-env-numeric base-env-indexing)) (for-template (private base-env base-types base-types-extra diff --git a/collects/typed-scheme/env/type-env.rkt b/collects/typed-scheme/env/global-env.rkt similarity index 100% rename from collects/typed-scheme/env/type-env.rkt rename to collects/typed-scheme/env/global-env.rkt diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt index 72c7d8be..c5c8e737 100644 --- a/collects/typed-scheme/env/init-envs.rkt +++ b/collects/typed-scheme/env/init-envs.rkt @@ -1,7 +1,7 @@ #lang scheme/base (provide (all-defined-out)) (require "../utils/utils.rkt" - "type-env.rkt" + "global-env.rkt" "type-name-env.rkt" "type-alias-env.rkt" unstable/struct racket/dict diff --git a/collects/typed-scheme/env/lexical-env.rkt b/collects/typed-scheme/env/lexical-env.rkt index 4d0ebe25..24e74d34 100644 --- a/collects/typed-scheme/env/lexical-env.rkt +++ b/collects/typed-scheme/env/lexical-env.rkt @@ -1,8 +1,15 @@ #lang scheme/base +;; this environment maps *lexical* variables to types +;; it also contains the proposition environment + +;; these environments are unified in "Logical Types for Scheme" +;; but split here for performance + (require "../utils/utils.rkt" - "type-environments.rkt" - "type-env.rkt" + "type-env-structs.rkt" + "global-env.rkt" + "dotted-env.rkt" unstable/mutated-vars syntax/id-table (only-in scheme/contract ->* -> or/c any/c listof cons/c) (utils tc-utils) @@ -13,11 +20,11 @@ (provide lexical-env with-lexical-env with-lexical-env/extend with-update-type/lexical with-lexical-env/extend/props) (p/c - [lookup-type/lexical ((identifier?) (lex-env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))] - [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (lex-env?) . ->* . env?)]) + [lookup-type/lexical ((identifier?) (prop-env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))] + [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (prop-env?) . ->* . env?)]) ;; the current lexical environment -(define lexical-env (make-parameter (make-empty-lex-env (make-immutable-free-id-table)))) +(define lexical-env (make-parameter (make-empty-prop-env (make-immutable-free-id-table)))) ;; run code in a new env (define-syntax-rule (with-lexical-env e . b) diff --git a/collects/typed-scheme/env/tvar-env.rkt b/collects/typed-scheme/env/tvar-env.rkt new file mode 100644 index 00000000..f457e70c --- /dev/null +++ b/collects/typed-scheme/env/tvar-env.rkt @@ -0,0 +1,15 @@ +#lang racket/base + +;; this environment maps type variables names (symbols) +;; to types representing the type variable +;; technically, the mapped-to type is unnecessary, but it's convenient to have it around? maybe? + +(require "type-env-structs.rkt") +(provide (all-defined-out)) + +;; the initial type variable environment - empty +;; this is used in the parsing of types +(define initial-tvar-env (make-empty-env #hasheq())) + +;; a parameter for the current type variables +(define current-tvars (make-parameter initial-tvar-env)) \ No newline at end of file diff --git a/collects/typed-scheme/env/type-environments.rkt b/collects/typed-scheme/env/type-env-structs.rkt similarity index 65% rename from collects/typed-scheme/env/type-environments.rkt rename to collects/typed-scheme/env/type-env-structs.rkt index 3d12aa60..1d9047b9 100644 --- a/collects/typed-scheme/env/type-environments.rkt +++ b/collects/typed-scheme/env/type-env-structs.rkt @@ -3,34 +3,29 @@ (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 - (except-in (r:utils tc-utils) make-env) - #;(r:typecheck tc-metafunctions)) + (except-in (r:utils tc-utils) make-env)) -(provide current-tvars - extend +(provide extend env? lookup extend-env extend/values - dotted-env - initial-tvar-env env-map make-empty-env env-filter env-keys+vals env-props replace-props - with-dotted-env/extend - lex-env? make-empty-lex-env) + prop-env? make-empty-prop-env) ;; 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 (lex-env env) ([props (listof Filter/c)]) #:transparent) +(r:d-s/c (prop-env env) ([props (listof Filter/c)]) #:transparent) (define (mk-env orig dict) (match orig - [(lex-env _ p) (lex-env dict p)] + [(prop-env _ p) (prop-env dict p)] [_ (env dict)])) (define (env-filter f e) @@ -46,27 +41,17 @@ (dict? . -> . env?) (env dict)) -(r:d/c (make-empty-lex-env dict) - (dict? . -> . lex-env?) - (lex-env dict null)) +(r:d/c (make-empty-prop-env dict) + (dict? . -> . prop-env?) + (prop-env dict null)) (r:d/c (env-props e) - (lex-env? . -> . (listof Filter/c)) - (lex-env-props e)) + (prop-env? . -> . (listof Filter/c)) + (prop-env-props e)) (define (env-keys+vals e) (match e - [(env l) (for/list ([(k v) (in-dict l)]) (cons k v))])) - -;; the initial type variable environment - empty -;; this is used in the parsing of types -(define initial-tvar-env (make-empty-env #hasheq())) - -;; a parameter for the current type variables -(define current-tvars (make-parameter initial-tvar-env)) - -;; the environment for types of ... variables -(define dotted-env (make-parameter (make-empty-env (make-immutable-free-id-table)))) + [(env l) (for/list ([(k v) (in-dict l)]) (cons k v))])) (r:d/c (env-map f e) ((any/c any/c . -> . any/c) env? . -> . env?) @@ -86,8 +71,8 @@ (define (replace-props e props) (match e - [(lex-env l p) - (lex-env l props)])) + [(prop-env l p) + (prop-env l props)])) (define (lookup e key fail) (match e @@ -106,7 +91,3 @@ [else (extend env ks vs)])) env kss vss)) -;; run code in an extended dotted env -(define-syntax with-dotted-env/extend - (syntax-rules () - [(_ i t v . b) (parameterize ([dotted-env (extend (dotted-env) i (cons t v))]) . b)])) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index bbd15f9f..72ea4682 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -9,7 +9,7 @@ "env/type-name-env.rkt") make-env) (except-in (path-up "types/utils.rkt") Dotted) - (only-in (path-up "env/type-environments.rkt") lookup current-tvars) + (only-in (path-up "env/type-env-structs.rkt" "env/tvar-env.rkt") lookup current-tvars) "constraint-structs.rkt" "signatures.rkt" scheme/match diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index 799a26c2..093ac674 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -6,7 +6,7 @@ (utils tc-utils stxclass-util) syntax/stx (prefix-in c: scheme/contract) syntax/parse - (env type-environments type-name-env type-alias-env lexical-env) + (env type-env-structs tvar-env dotted-env type-name-env type-alias-env lexical-env) scheme/match unstable/debug (for-template scheme/base "colon.ss") ;; needed at this phase for tests diff --git a/collects/typed-scheme/private/type-annotation.rkt b/collects/typed-scheme/private/type-annotation.rkt index 7109f5dd..7bb90cb7 100644 --- a/collects/typed-scheme/private/type-annotation.rkt +++ b/collects/typed-scheme/private/type-annotation.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" (rep type-rep) (utils tc-utils) - (env type-env) + (env global-env) (except-in (types subtype union convenience resolve utils) -> ->*) (private parse-type) (only-in scheme/contract listof ->) diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-scheme/private/with-types.rkt index db090578..e5cd04f6 100644 --- a/collects/typed-scheme/private/with-types.rkt +++ b/collects/typed-scheme/private/with-types.rkt @@ -12,8 +12,9 @@ "private/parse-type.rkt" "private/type-contract.rkt" "typecheck/typechecker.rkt" - "env/type-environments.rkt" - "env/type-env.rkt" + "env/type-env-structs.rkt" + "env/global-env.rkt" + "env/tvar-env.rkt" "infer/infer.rkt" "utils/tc-utils.rkt" "types/utils.rkt" diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt index f4e04141..26c67c12 100644 --- a/collects/typed-scheme/tc-setup.rkt +++ b/collects/typed-scheme/tc-setup.rkt @@ -7,7 +7,7 @@ (private type-contract) (types utils convenience) (typecheck typechecker provide-handling tc-toplevel) - (env type-environments type-name-env type-alias-env) + (env tvar-env type-name-env type-alias-env) (r:infer infer) (utils tc-utils) (rep type-rep) @@ -57,4 +57,4 @@ [expanded-module-stx fully-expanded-stx]) (let ([result (checker fully-expanded-stx)]) (do-time "Typechecking Done") - . body))))))) \ No newline at end of file + . body))))))) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index b981f24e..839633f6 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -16,7 +16,7 @@ (types utils abbrev union subtype resolve convenience type-table) (utils tc-utils) (only-in srfi/1 alist-delete) - (except-in (env type-environments) extend) + (except-in (env type-env-structs tvar-env) extend) (rep type-rep filter-rep object-rep) (r:infer infer) '#%paramz diff --git a/collects/typed-scheme/typecheck/tc-envops.rkt b/collects/typed-scheme/typecheck/tc-envops.rkt index ce4b5f31..33410c7f 100644 --- a/collects/typed-scheme/typecheck/tc-envops.rkt +++ b/collects/typed-scheme/typecheck/tc-envops.rkt @@ -9,7 +9,7 @@ (rep type-rep object-rep) (utils tc-utils) (types resolve) - (only-in (env type-environments lexical-env) env? update-type/lexical env-map env-props replace-props) + (only-in (env type-env-structs lexical-env) env? update-type/lexical env-map env-props replace-props) scheme/contract scheme/match mzlib/trace unstable/debug unstable/struct (typecheck tc-metafunctions) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 8ebd4156..65ba6a06 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -11,7 +11,7 @@ (only-in (infer infer) restrict) (except-in (utils tc-utils stxclass-util)) (env lexical-env) - (only-in (env type-environments) lookup current-tvars extend-env) + (only-in (env type-env-structs tvar-env) lookup current-tvars extend-env) racket/private/class-internal unstable/debug (except-in syntax/parse id) (only-in srfi/1 split-at)) diff --git a/collects/typed-scheme/typecheck/tc-if.rkt b/collects/typed-scheme/typecheck/tc-if.rkt index aa50b85b..288d9de5 100644 --- a/collects/typed-scheme/typecheck/tc-if.rkt +++ b/collects/typed-scheme/typecheck/tc-if.rkt @@ -6,7 +6,7 @@ (rep type-rep filter-rep object-rep) (rename-in (types convenience subtype union utils comparison remove-intersect abbrev filter-ops) [remove *remove]) - (env lexical-env type-environments) + (env lexical-env type-env-structs) (r:infer infer) (utils tc-utils) (typecheck tc-envops tc-metafunctions) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt index f2438b08..cfad4d11 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt @@ -13,7 +13,7 @@ [make-arr* make-arr]) (private type-annotation) (types abbrev utils) - (env type-environments lexical-env) + (env type-env-structs lexical-env dotted-env tvar-env) (utils tc-utils) unstable/debug scheme/match) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.rkt b/collects/typed-scheme/typecheck/tc-let-unit.rkt index 23cf379a..32c6c355 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-let-unit.rkt @@ -4,7 +4,7 @@ (require "signatures.rkt" "tc-metafunctions.rkt" "tc-subst.rkt" (types utils convenience) (private type-annotation parse-type) - (env lexical-env type-alias-env type-env type-environments) + (env lexical-env type-alias-env global-env type-env-structs) (rep type-rep) syntax/free-vars mzlib/trace unstable/debug diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index f73d7844..a4945ca3 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -4,7 +4,7 @@ (except-in (rep type-rep free-variance) Dotted) (private parse-type) (types convenience utils union resolve abbrev) - (env type-env type-environments type-name-env) + (env global-env type-env-structs type-name-env tvar-env) (utils tc-utils) "def-binding.rkt" syntax/kerncase diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index fde65f83..03569cac 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -13,8 +13,8 @@ (rep type-rep) (types utils convenience) (private parse-type type-annotation type-contract) - (env type-env init-envs type-name-env type-alias-env lexical-env) - unstable/mutated-vars syntax/id-table + (env global-env init-envs type-name-env type-alias-env lexical-env) + unstable/mutated-vars syntax/id-table (utils tc-utils) "provide-handling.rkt" "def-binding.rkt" diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index b9b4a326..15c9d817 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -8,7 +8,7 @@ (private type-contract optimize) (types utils convenience) (typecheck typechecker provide-handling tc-toplevel) - (env type-environments type-name-env type-alias-env) + (env type-name-env type-alias-env) (r:infer infer) (utils tc-utils) (rep type-rep) From 54a57ab177381172300c879bff9e851774fd1b2f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 24 May 2010 15:39:51 -0700 Subject: [PATCH 065/198] First attempts at adding ListDots (and, incidentally, List*) types. original commit: 40dbb6389cd22c6f6dff42a20bdf23e32b2ba0d2 --- .../typed-scheme/private/base-types-extra.rkt | 2 +- collects/typed-scheme/private/parse-type.rkt | 43 +++++++++++++++++-- collects/typed-scheme/rep/type-rep.rkt | 11 +++++ collects/typed-scheme/types/abbrev.rkt | 3 ++ collects/typed-scheme/types/printer.rkt | 2 + 5 files changed, 57 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/base-types-extra.rkt b/collects/typed-scheme/private/base-types-extra.rkt index 43ba28ad..5e8eef63 100644 --- a/collects/typed-scheme/private/base-types-extra.rkt +++ b/collects/typed-scheme/private/base-types-extra.rkt @@ -13,7 +13,7 @@ ;; special type names that are not bound to particular types (define-other-types -> U Rec All Opaque Vector - Parameterof List Class Values Instance Refinement + Parameterof List List* Class Values Instance Refinement pred) (provide (rename-out [All ∀] diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index 093ac674..6e2c4f3e 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -6,7 +6,7 @@ (utils tc-utils stxclass-util) syntax/stx (prefix-in c: scheme/contract) syntax/parse - (env type-env-structs tvar-env dotted-env type-name-env type-alias-env lexical-env) + (env type-env-structs tvar-env type-name-env type-alias-env lexical-env) scheme/match unstable/debug (for-template scheme/base "colon.ss") ;; needed at this phase for tests @@ -111,7 +111,7 @@ (parameterize ([current-orig-stx stx]) (syntax-parse stx - #:literals (t:Class t:Refinement t:Instance t:List cons t:pred t:-> : case-lambda + #:literals (t:Class t:Refinement t:Instance t:List t:List* cons t:pred t:-> : case-lambda t:Rec t:U t:All t:Opaque t:Parameter t:Vector quote) [t #:declare t (3d Type?) @@ -148,7 +148,10 @@ (make-Instance v)))] [((~and kw t:List) ts ...) (add-type-name-reference #'kw) - (-Tuple (map parse-type (syntax->list #'(ts ...))))] + (parse-list-type stx)] + [((~and kw t:List*) ts ... t) + (add-type-name-reference #'kw) + (-Tuple* (map parse-type (syntax->list #'(ts ...))) (parse-type #'t))] [((~and kw t:Vector) ts ...) (add-type-name-reference #'kw) (make-HeterogenousVector (map parse-type (syntax->list #'(ts ...))))] @@ -346,6 +349,40 @@ (-val (syntax-e #'t))] [_ (tc-error "not a valid type: ~a" (syntax->datum stx))]))) +(define (parse-list-type stx) + (parameterize ([current-orig-stx stx]) + (syntax-parse stx #:literals (t:List) + [((~and kw t:List) tys ... dty :ddd/bound) + (add-type-name-reference #'kw) + (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))]) + (if (not (Dotted? var)) + (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." (syntax-e #'bound)) + (-Tuple* (map parse-type (syntax->list #'(tys ...))) + (make-ListDots + (parameterize ([current-tvars (extend-env (list (syntax-e #'bound)) + (list (make-DottedBoth (make-F (syntax-e #'bound)))) + (current-tvars))]) + (parse-type #'dty)) + (syntax-e #'bound)))))] + [((~and kw t:List) tys ... dty _:ddd) + (add-type-name-reference #'kw) + (let ([bounds (env-keys+vals (env-filter (compose Dotted? cdr) (current-tvars)))]) + (when (null? bounds) + (tc-error/stx stx "No type variable bound with ... in scope for ... type")) + (unless (null? (cdr bounds)) + (tc-error/stx stx "Cannot infer bound for ... type")) + (match-let ([(cons var (struct Dotted (t))) (car bounds)]) + (-Tuple* (map parse-type (syntax->list #'(tys ...))) + (make-ListDots + (parameterize ([current-tvars (extend-env (list var) + (list (make-DottedBoth t)) + (current-tvars))]) + (parse-type #'dty)) + var))))] + [((~and kw t:List) tys ...) + (add-type-name-reference #'kw) + (-Tuple (map parse-type (syntax->list #'(tys ...))))]))) + (define (parse-values-type stx) (parameterize ([current-orig-stx stx]) (syntax-parse stx #:literals (values t:All) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 5c9df275..b1f825fe 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -66,6 +66,11 @@ ;; left and right are Types (dt Pair ([left Type/c] [right Type/c]) [#:key 'pair]) +;; dotted list -- after expansion, becomes normal Pair-based list type +(dt ListDots ([dty Type/c] [dbound (or/c symbol? natural-number/c)]) + [#:frees (λ (f) (f dty))] + [#:fold-rhs (*ListDots (type-rec-id dty) dbound)]) + ;; *mutable* pairs - distinct from regular pairs ;; left and right are Types (dt MPair ([left Type/c] [right Type/c]) [#:key 'mpair]) @@ -442,6 +447,9 @@ (*ValuesDots (map sb rs) (sb dty) (if (eq? dbound name) (+ count outer) dbound))] + [#:ListDots dty dbound + (*ListDots (sb dty) + (if (eq? dbound name) (+ count outer) dbound))] [#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))] [#:PolyDots n body* (let ([body (remove-scopes n body*)]) @@ -490,6 +498,9 @@ (*ValuesDots (map sb rs) (sb dty) (if (eqv? dbound (+ count outer)) (F-n image) dbound))] + [#:ListDots dty dbound + (*ListDots (sb dty) + (if (eqv? dbound (+ count outer)) (F-n image) dbound))] [#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))] [#:PolyDots n body* (let ([body (remove-scopes n body*)]) diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index d760dd9d..c2608c17 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -45,6 +45,9 @@ (define (-Tuple l) (foldr -pair (-val '()) l)) +(define (-Tuple* l b) + (foldr -pair b l)) + (define (untuple t) (match (resolve t) [(Value: '()) null] diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 1892423e..ebfe3388 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -171,6 +171,8 @@ [(Channel: e) (fp "(Channelof ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] [(Pair: l r) (fp "(Pairof ~a ~a)" l r)] + [(ListDots: dty dbound) + (fp "(List ~a ...~a~a)" dty (if (special-dots-printing?) "" " ") dbound)] [(F: nm) (fp "~a" nm)] ;; FIXME [(Values: (list v)) (fp "~a" v)] From 28ff44d0f2003871014426780d82ec9e41f141fd Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 24 May 2010 14:22:23 -0400 Subject: [PATCH 066/198] Add subtyping for dotted lists with the same bound. original commit: 62fb6f93110e9ed23ed0b979af5b3c1608f088e7 --- collects/typed-scheme/types/subtype.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index d03769bb..36c939c1 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -295,6 +295,9 @@ [((Pair: a d) (Pair: a* d*)) (let ([A1 (subtype* A0 a a*)]) (and A1 (subtype* A1 d d*)))] + ;; recur structurally on dotted lists, assuming same bounds + [((ListDots: s-dty dbound) (ListDots: t-dty dbound)) + (subtype* A0 s-dty t-dty)] ;; quantification over two types preserves subtyping [((Poly: ns b1) (Poly: ms b2)) (=> unmatch) From 2ecc5d35d414c6b2b629dcf555bae71b607b44e6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 14:39:54 -0400 Subject: [PATCH 067/198] Substitution for (List T ...) original commit: 310bdf352980f9c629ccfa8d2a4365dd8f23cd0c --- collects/typed-scheme/types/utils.rkt | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/types/utils.rkt b/collects/typed-scheme/types/utils.rkt index 68d6452c..f32aae39 100644 --- a/collects/typed-scheme/types/utils.rkt +++ b/collects/typed-scheme/types/utils.rkt @@ -36,7 +36,8 @@ ;; substitute : Type Name Type -> Type -(define (substitute image name target #:Un [Un (get-union-maker)]) +(d/c (substitute image name target #:Un [Un (get-union-maker)]) + ((Type/c symbol? Type?) (#:Un procedure?) . ->* . Type?) (define (sb t) (substitute image name t)) (if (hash-ref (free-vars* target) name #f) (type-case (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb)) @@ -58,14 +59,29 @@ (begin (when (eq? name dbound) (int-err "substitute used on ... variable ~a in type ~a" name target)) - (make-ValuesDots (map sb types) (sb dty) dbound))]) + (make-ValuesDots (map sb types) (sb dty) dbound))] + [#:ListDots dty dbound + (begin + (when (eq? name dbound) + (int-err "substitute used on ... variable ~a in type ~a" name target)) + (make-ListDots (sb dty) dbound))]) target)) +;; implements angle bracket substitution from the formalism ;; substitute-dots : Listof[Type] Option[type] Name Type -> Type -(define (substitute-dots images rimage name target) +(d/c (substitute-dots images rimage name target) + ((listof Type/c) (or/c #f Type/c) symbol? Type? . -> . Type?) (define (sb t) (substitute-dots images rimage name t)) (if (hash-ref (free-vars* target) name #f) (type-case (#:Type sb #:Filter (sub-f sb)) target + [#:ListDots dty dbound + (if (eq? name dbound) + ;; 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]) + (make-Pair (substitute img name expanded) t))) + (make-ListDots (sb dty) dbound))] [#:ValuesDots types dty dbound (if (eq? name dbound) (make-Values @@ -98,7 +114,7 @@ (map sb kws)))]) target)) -;; implements sd from the formalism +;; implements curly brace substitution from the formalism ;; substitute-dotted : Type Name Name Type -> Type (define (substitute-dotted image image-bound name target) (define (sb t) (substitute-dotted image image-bound name t)) @@ -109,6 +125,9 @@ (make-ValuesDots (map sb types) (sb dty) (if (eq? name dbound) image-bound dbound))] + [#:ListDots dty dbound + (make-ListDots (sb dty) + (if (eq? name dbound) image-bound dbound))] [#:F name* (if (eq? name* name) image From fd9b2469310bace183bad022886afcfa72ea49a5 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 14:51:48 -0400 Subject: [PATCH 068/198] Initial ListDots test. original commit: e40d1824b0b3717a1c2454ebc87257abca352a8a --- collects/tests/typed-scheme/succeed/list-dots.rkt | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 collects/tests/typed-scheme/succeed/list-dots.rkt diff --git a/collects/tests/typed-scheme/succeed/list-dots.rkt b/collects/tests/typed-scheme/succeed/list-dots.rkt new file mode 100644 index 00000000..5ad1d38f --- /dev/null +++ b/collects/tests/typed-scheme/succeed/list-dots.rkt @@ -0,0 +1,6 @@ +#lang typed/racket + +(: f (All (a ...) ((List a ...) -> (List a ... a)))) +(define (f x) x) + +(ann (values (inst f String Number Boolean)) String) From dfe4211df82d7c90a1d6f49209e9d804de49d70d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 17:01:36 -0400 Subject: [PATCH 069/198] Handle simple inference of ListDots. original commit: 71939d282694485805316a02563083a6882a4fa8 --- collects/typed-scheme/infer/infer-unit.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 72ea4682..abad6da9 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -409,7 +409,10 @@ (move-vars-to-dmap new-cset dbound vars))] [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound)) (when (memq dbound X) (fail! ss ts)) - (cgen/list V X (cons s-dty ss) (cons t-dty ts))] + (cgen/list V X (cons s-dty ss) (cons t-dty ts))] + [((ListDots: s-dty dbound) (ListDots: t-dty dbound)) + (when (memq dbound X) (fail! S T)) + (cgen V X s-dty t-dty)] [((Vector: e) (Vector: e*)) (cset-meet (cg e e*) (cg e* e))] [((Box: e) (Box: e*)) From d91f1e99988c25c80d7b3537092146a1295215c9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 17:02:47 -0400 Subject: [PATCH 070/198] Change type of ... rest args to have (List T ...) types. original commit: 4cbeb0b2f00e652ce15e5638e15ca83a131b3b8b --- .../tests/typed-scheme/succeed/list-dots.rkt | 5 +++- .../typed-scheme/typecheck/tc-lambda-unit.rkt | 29 +++++++++---------- 2 files changed, 17 insertions(+), 17 deletions(-) diff --git a/collects/tests/typed-scheme/succeed/list-dots.rkt b/collects/tests/typed-scheme/succeed/list-dots.rkt index 5ad1d38f..a6fe64aa 100644 --- a/collects/tests/typed-scheme/succeed/list-dots.rkt +++ b/collects/tests/typed-scheme/succeed/list-dots.rkt @@ -3,4 +3,7 @@ (: f (All (a ...) ((List a ...) -> (List a ... a)))) (define (f x) x) -(ann (values (inst f String Number Boolean)) String) +(: g (All (a ...) (a ... -> (List a ...)))) +(define (g . x) x) + +(g 7 7 7) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt index cfad4d11..056689e8 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt @@ -13,7 +13,7 @@ [make-arr* make-arr]) (private type-annotation) (types abbrev utils) - (env type-env-structs lexical-env dotted-env tvar-env) + (env type-env-structs lexical-env tvar-env) (utils tc-utils) unstable/debug scheme/match) @@ -87,15 +87,15 @@ [(not rest) (check-body)] [drest - (with-dotted-env/extend - rest (car drest) (cdr drest) + (with-lexical-env/extend + (list rest) (list (make-ListDots (car drest) (cdr drest))) (check-body))] [(dotted? rest) => (lambda (b) (let ([dty (get-type rest #:default Univ)]) - (with-dotted-env/extend - rest dty b + (with-lexical-env/extend + (list rest) (list (make-ListDots dty b)) (check-body))))] [else (let ([rest-type (cond @@ -148,17 +148,14 @@ (current-tvars))]) (get-type #'rest #:default Univ))]) (with-lexical-env/extend - arg-list - arg-types - (parameterize ([dotted-env (extend-env (list #'rest) - (list (cons rest-type bound)) - (dotted-env))]) - (make-lam-result - (map list arg-list arg-types) - null - #f - (cons #'rest (cons rest-type bound)) - (tc-exprs (syntax->list body)))))))] + (cons #'rest arg-list) + (cons (make-ListDots rest-type bound) arg-types) + (make-lam-result + (map list arg-list arg-types) + null + #f + (cons #'rest (cons rest-type bound)) + (tc-exprs (syntax->list body))))))] [else (let ([rest-type (get-type #'rest #:default Univ)]) (with-lexical-env/extend From 4f2a1130760d6a542b4072ea692fa78911c71cab Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 27 May 2010 17:03:38 -0400 Subject: [PATCH 071/198] Eliminate expressions with dotted pre-types. - Now looks for (List T ...) types. - special handling of `map', `andmap', `ormap' when list arg is dotted - remove tc-dots-unit original commit: 4c3f279ab910de4fc5a059e48025d7118c97129b --- collects/typed-scheme/typecheck/tc-app.rkt | 140 ++++++++++-------- .../typed-scheme/typecheck/typechecker.rkt | 4 +- 2 files changed, 79 insertions(+), 65 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 839633f6..b26f8e5e 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -3,7 +3,7 @@ (require (rename-in "../utils/utils.rkt" [infer r:infer]) "signatures.rkt" "tc-metafunctions.rkt" "tc-app-helper.rkt" "find-annotation.rkt" - "tc-subst.rkt" + "tc-subst.rkt" (prefix-in c: scheme/contract) syntax/parse scheme/match mzlib/trace scheme/list unstable/sequence unstable/debug ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy @@ -25,7 +25,7 @@ "internal-forms.rkt" scheme/base scheme/bool '#%paramz (only-in racket/private/class-internal make-object do-make-object))) -(import tc-expr^ tc-lambda^ tc-dots^ tc-let^) +(import tc-expr^ tc-lambda^ tc-let^) (export tc-app^) @@ -264,55 +264,48 @@ (split args*)))) (match f-ty + ;; apply of simple function [(tc-result1: (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")) - (let ([arg-tys (map tc-expr/t fixed-args)]) + (match-let ([arg-tys (map tc-expr/t fixed-args)] + [(tc-result1: tail-ty) (single-value tail)]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) - (cond [(null? doms*) - (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda _ (values (tc-expr/t tail) #f))]) - (tc/dots tail))]) - (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 tail-bound))))] - [(and (car rests*) - (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda _ (values #f #f))]) - (tc/dots tail))]) - (and tail-ty - (subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty)) - (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) - (printf/log "Non-poly apply, ... arg\n") - (do-ret (car rngs*))] - [(and (car rests*) - (let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)]) - (tc-expr/t tail))]) - (and tail-ty - (subtype (apply -lst* arg-tys #:tail tail-ty) - (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))))) - - (printf/log (if (memq (syntax->datum f) '(+ - * / max min)) - "Simple arithmetic non-poly apply\n" - "Simple non-poly apply\n")) - (do-ret (car rngs*))] - [(and (car drests*) - (let-values ([(tail-ty tail-bound) - (with-handlers ([exn:fail? (lambda (e) (values #f #f))]) - (tc/dots tail))]) - (and tail-ty - (eq? (cdr (car drests*)) tail-bound) - (subtypes arg-tys (car doms*)) - (subtype tail-ty (car (car drests*)))))) - (printf/log "Non-poly apply, ... arg\n") - (do-ret (car rngs*))] - [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr 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)))] + ;; 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 + (subtype (apply -lst* arg-tys #:tail tail-ty) + (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))) + (do-ret (car rngs*))] + ;; the function expects a dotted rest arg, so make sure we have a ListDots + [(and (car drests*) + (match tail-ty + [(ListDots: tail-ty tail-bound) + ;; the check that it's the same bound + (and (eq? (cdr (car drests*)) tail-bound) + ;; and that the types are correct + (subtypes arg-tys (car doms*)) + (subtype tail-ty (car (car drests*))))] + [_ #f])) + (do-ret (car rngs*))] + ;; otherwise, nothing worked, move on to the next case + [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)] - [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) - (tc/dots tail))]) + [(tail-ty tail-bound) (match (tc-expr/t tail) + [(ListDots: tail-ty tail-bound) + (values tail-ty tail-bound)] + [t (values t #f)])]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty @@ -363,8 +356,10 @@ [(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)] - [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) - (tc/dots tail))]) + [(tail-ty tail-bound) (match (tc-expr/t tail) + [(ListDots: tail-ty tail-bound) + (values tail-ty tail-bound)] + [t (values t #f)])]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty @@ -453,7 +448,7 @@ (syntax-parse form #:literals (#%plain-app #%plain-lambda letrec-values quote values apply k:apply not list list* call-with-values do-make-object make-object cons - andmap ormap reverse extend-parameterization vector-ref) + map andmap ormap reverse extend-parameterization vector-ref) [(#%plain-app extend-parameterization pmz args ...) (let loop ([args (syntax->list #'(args ...))]) (if (null? args) (ret Univ) @@ -637,20 +632,37 @@ (check-do-make-object #'cl #'args #'() #'())] [(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...)) (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))] + [(#%plain-app (~literal map) f arg) + (match (single-value #'arg) + ;; if the argument is a ListDots + [(tc-result1: (ListDots: t bound)) + (match (parameterize ([current-tvars (extend-env (list bound) + (list (make-DottedBoth (make-F bound))) + (current-tvars))]) + ;; just check that the function applies successfully to the element type + (tc/funapp #'f #'(arg) (tc-expr #'f) (list (ret t)) expected)) + [(tc-result1: t) (ret (make-ListDots t bound))] + [(tc-results: ts) + (tc-error/expr #:return (ret (Un)) + "Expected one value, but got ~a" (-values ts))])] + ;; otherwise, if it's not a ListDots, defer to the regular function typechecking + [res + (tc/funapp #'map #'(f arg) (single-value #'map) (list (tc-expr #'f) res) expected)])] ;; ormap/andmap of ... argument - [(#%plain-app (~or (~literal andmap) (~literal ormap)) f arg) - #:attr ty+bound - (with-handlers ([exn:fail? (lambda _ #f)]) - (let-values ([(ty bound) (tc/dots #'arg)]) - (list ty bound))) - #:when (attribute ty+bound) - (match-let ([(list ty bound) (attribute ty+bound)]) - (parameterize ([current-tvars (extend-env (list bound) - (list (make-DottedBoth (make-F bound))) - (current-tvars))]) - (match-let* ([ft (tc-expr #'f)] - [(tc-result1: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)]) - (ret (Un (-val #f) t)))))] + [(#%plain-app (~and fun (~or (~literal andmap) (~literal ormap))) f arg) + ;; check the arguments + (match-let* ([arg-ty (single-value #'arg)] + [ft (tc-expr #'f)]) + (match (match arg-ty + ;; if the argument is a ListDots + [(tc-result1: (ListDots: t bound)) + ;; just check that the function applies successfully to the element type + (tc/funapp #'f #'(arg) ft (list (ret (substitute Univ bound t))) expected)] + ;; otherwise ... + [_ #f]) + [(tc-result1: t) (ret (Un (-val #f) t))] + ;; if it's not a ListDots, defer to the regular function typechecking + [_ (tc/funapp #'fun #'(f arg) (single-value #'fun) (list ft arg-ty) expected)]))] ;; special case for `delay' [(#%plain-app mp1 @@ -780,6 +792,7 @@ (poly-fail t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))])) (define (tc/funapp f-stx args-stx ftype0 argtys expected) + ;(syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results?) . -> . 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: (list (Result: t-r lf-r lo-r) ...)) rest #f kws)))))) @@ -866,7 +879,8 @@ ;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? -(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) +(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?) ;(printf "got to here 0~a~n" args-stx) (match* (ftype0 argtys) ;; we check that all kw args are optional @@ -900,7 +914,7 @@ (open-Result r o-a t-a))) (ret t-r f-r o-r)))] [((arr: _ _ _ drest '()) _) - (int-err "funapp with drest args NYI")] + (int-err "funapp with drest args ~a NYI" drest)] [((arr: _ _ _ _ kws) _) - (int-err "funapp with keyword args NYI")])) + (int-err "funapp with keyword args ~a NYI" kws)])) diff --git a/collects/typed-scheme/typecheck/typechecker.rkt b/collects/typed-scheme/typecheck/typechecker.rkt index 1434e0b9..90c46d4e 100644 --- a/collects/typed-scheme/typecheck/typechecker.rkt +++ b/collects/typed-scheme/typecheck/typechecker.rkt @@ -8,10 +8,10 @@ define-values/invoke-unit/infer link) "signatures.rkt" "tc-if.rkt" "tc-lambda-unit.rkt" "tc-app.rkt" - "tc-let-unit.rkt" "tc-dots-unit.rkt" + "tc-let-unit.rkt" "tc-expr-unit.rkt" "check-subforms-unit.rkt") (provide-signature-elements tc-expr^ check-subforms^) (define-values/invoke-unit/infer - (link tc-if@ tc-lambda@ tc-dots@ tc-app@ tc-let@ tc-expr@ check-subforms@)) + (link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@)) From 92c48f65211c6fe68fe124539006df4fb0207bca Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 May 2010 11:53:54 -0400 Subject: [PATCH 072/198] Subtyping between (List T ... a) and (Listof T[Any/a]) original commit: fd5a662ccc7aa2fbc3f29974c075dcabf2a870fe --- collects/tests/typed-scheme/succeed/list-dots.rkt | 9 +++++++++ collects/typed-scheme/types/subtype.rkt | 2 ++ 2 files changed, 11 insertions(+) diff --git a/collects/tests/typed-scheme/succeed/list-dots.rkt b/collects/tests/typed-scheme/succeed/list-dots.rkt index a6fe64aa..4b3ac8b8 100644 --- a/collects/tests/typed-scheme/succeed/list-dots.rkt +++ b/collects/tests/typed-scheme/succeed/list-dots.rkt @@ -7,3 +7,12 @@ (define (g . x) x) (g 7 7 7) + +(: h (All (a ...) (a ... -> (Listof Any)))) +(define (h . x) x) + +(: h2 (All (a ...) ((Pair String a) ... -> (Listof (Pair String Any))))) +(define (h2 . x) x) + +(: h3 (All (a ...) ((Pair String a) ... -> (Listof Any)))) +(define (h3 . x) x) diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index 36c939c1..7b5d91de 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -298,6 +298,8 @@ ;; recur structurally on dotted lists, assuming same bounds [((ListDots: s-dty dbound) (ListDots: t-dty dbound)) (subtype* A0 s-dty t-dty)] + [((ListDots: s-dty dbound) (Listof: t-elem)) + (subtype* A0 (substitute Univ dbound s-dty) t-elem)] ;; quantification over two types preserves subtyping [((Poly: ns b1) (Poly: ms b2)) (=> unmatch) From db8c6934814bfb1e96e385393c933b657190a625 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 May 2010 12:08:44 -0400 Subject: [PATCH 073/198] Inference for passing ListDots as Listof. original commit: a2af89bafd3d79587c87425488833e07465f5fc5 --- collects/tests/typed-scheme/succeed/list-dots.rkt | 3 +++ collects/typed-scheme/infer/infer-unit.rkt | 12 ++++++++---- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/collects/tests/typed-scheme/succeed/list-dots.rkt b/collects/tests/typed-scheme/succeed/list-dots.rkt index 4b3ac8b8..83ed511b 100644 --- a/collects/tests/typed-scheme/succeed/list-dots.rkt +++ b/collects/tests/typed-scheme/succeed/list-dots.rkt @@ -16,3 +16,6 @@ (: h3 (All (a ...) ((Pair String a) ... -> (Listof Any)))) (define (h3 . x) x) + +(: h4 (All (a ...) (a ... -> Number))) +(define (h4 . x) (length x)) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index abad6da9..cf7bfe66 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -250,7 +250,7 @@ (cset-meet* (list arg-mapping darg-mapping ret-mapping)))])] [(_ _) (fail! S T)])) -;; determine constraints on the variables in X that would make T a supertype of S +;; determine constraints on the variables in X that would make S a subtype of T ;; the resulting constraints will not mention V (define (cgen V X S T) (define (cg S T) (cgen V X S T)) @@ -364,6 +364,13 @@ (cg t t*)] [((Hashtable: k v) (Sequence: (list k* v*))) (cgen/list V X (list k v) (list k* v*))] + ;; must be above mu unfolding + [((ListDots: s-dty dbound) (Listof: t-elem)) + (when (memq dbound X) (fail! S T)) + (cgen V X (substitute Univ dbound s-dty) t-elem)] + [((ListDots: s-dty dbound) (ListDots: t-dty dbound)) + (when (memq dbound X) (fail! S T)) + (cgen V X s-dty t-dty)] ;; if we have two mu's, we rename them to have the same variable ;; and then compare the bodies [((Mu-unsafe: s) (Mu-unsafe: t)) @@ -410,9 +417,6 @@ [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound)) (when (memq dbound X) (fail! ss ts)) (cgen/list V X (cons s-dty ss) (cons t-dty ts))] - [((ListDots: s-dty dbound) (ListDots: t-dty dbound)) - (when (memq dbound X) (fail! S T)) - (cgen V X s-dty t-dty)] [((Vector: e) (Vector: e*)) (cset-meet (cg e e*) (cg e* e))] [((Box: e) (Box: e*)) From 341f6d82e6e9951e1f6a96903611119e0743aae6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 May 2010 12:26:30 -0400 Subject: [PATCH 074/198] Generalize ListDots to Listof in inference of loop var types. original commit: f7b59f78e9212c03e950729944e7a9eb9370f363 --- collects/tests/typed-scheme/succeed/apply-dots-list.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/tests/typed-scheme/succeed/apply-dots-list.rkt b/collects/tests/typed-scheme/succeed/apply-dots-list.rkt index 85af5196..ec5c25fe 100644 --- a/collects/tests/typed-scheme/succeed/apply-dots-list.rkt +++ b/collects/tests/typed-scheme/succeed/apply-dots-list.rkt @@ -1,4 +1,3 @@ - ;; Change the lang to scheme for untyped version #lang typed-scheme From 33bbcb17bc830c31aa8ec668097db2fd61aa7208 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 May 2010 12:45:32 -0400 Subject: [PATCH 075/198] Remove dotted-env. original commit: a9c34dae6a83b296f79a9d432db3e9cfb5f6288c --- collects/typed-scheme/env/lexical-env.rkt | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/collects/typed-scheme/env/lexical-env.rkt b/collects/typed-scheme/env/lexical-env.rkt index 24e74d34..1445435d 100644 --- a/collects/typed-scheme/env/lexical-env.rkt +++ b/collects/typed-scheme/env/lexical-env.rkt @@ -9,7 +9,6 @@ (require "../utils/utils.rkt" "type-env-structs.rkt" "global-env.rkt" - "dotted-env.rkt" unstable/mutated-vars syntax/id-table (only-in scheme/contract ->* -> or/c any/c listof cons/c) (utils tc-utils) @@ -41,14 +40,7 @@ ;; find the type of identifier i, looking first in the lexical env, then in the top-level env ;; identifer -> Type (define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f]) - (lookup env i - (lambda (i) (lookup-type - i (lambda () - (cond [(lookup (dotted-env) i (lambda _ #f)) - => - (lambda (a) - (-lst (substitute Univ (cdr a) (car a))))] - [else ((or fail lookup-fail) i)])))))) + (lookup env i (λ (i) (lookup-type i (λ () ((or fail lookup-fail) i)))))) ;; refine the type of i in the lexical env ;; (identifier type -> type) identifier -> environment From 72f1d63d90f58814c45015eba98c63fc7c0ffbb7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 May 2010 13:54:00 -0400 Subject: [PATCH 076/198] Properly compute Dotted variance for ListDots and ValuesDots. original commit: 0fb1ac66bd03748767a30c41ec69207b9349e1bf --- collects/typed-scheme/rep/type-rep.rkt | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index b1f825fe..985685c9 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -68,7 +68,12 @@ ;; dotted list -- after expansion, becomes normal Pair-based list type (dt ListDots ([dty Type/c] [dbound (or/c symbol? natural-number/c)]) - [#:frees (λ (f) (f dty))] + [#:frees (if (symbol? dbound) + (fix-bound (free-vars* dty) dbound) + (free-vars* dty)) + (if (number? dbound) + (fix-bound (free-idxs* dty) dbound) + (free-idxs* dty))] [#:fold-rhs (*ListDots (type-rec-id dty) dbound)]) ;; *mutable* pairs - distinct from regular pairs @@ -157,7 +162,12 @@ [#:fold-rhs (*Values (map type-rec-id rs))]) (dt ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)]) - [#:frees (λ (f) (combine-frees (map f (cons dty rs))))] + [#:frees (if (symbol? dbound) + (fix-bound (combine-frees (map free-vars* (cons dty rs))) dbound) + (combine-frees (map free-vars* (cons dty rs)))) + (if (number? dbound) + (fix-bound (combine-frees (map free-idxs* (cons dty rs))) dbound) + (combine-frees (map free-idxs* (cons dty rs))))] [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)]) ;; arr is NOT a Type From 1e98e1c1fd415efb9a9497989f0769e51fa8428d Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 May 2010 14:11:32 -0400 Subject: [PATCH 077/198] Add index-env. - Remove Dotted and DottedBoth values from tvar-env - Abstract env extension and lookup for tvar/index-env - Abstract index inference - Remove pointless parameterizations original commit: d570006db81dda68e69b7058fd3edfb68cc3d042 --- collects/typed-scheme/env/index-env.rkt | 31 ++++ collects/typed-scheme/env/tvar-env.rkt | 13 +- collects/typed-scheme/infer/infer-unit.rkt | 9 +- collects/typed-scheme/private/parse-type.rkt | 156 +++++++----------- collects/typed-scheme/private/with-types.rkt | 2 - collects/typed-scheme/tc-setup.rkt | 2 - collects/typed-scheme/typecheck/tc-app.rkt | 16 +- .../typed-scheme/typecheck/tc-expr-unit.rkt | 11 +- .../typed-scheme/typecheck/tc-lambda-unit.rkt | 49 ++---- .../typed-scheme/typecheck/tc-structs.rkt | 8 +- collects/typed-scheme/types/utils.rkt | 18 +- 11 files changed, 143 insertions(+), 172 deletions(-) create mode 100644 collects/typed-scheme/env/index-env.rkt diff --git a/collects/typed-scheme/env/index-env.rkt b/collects/typed-scheme/env/index-env.rkt new file mode 100644 index 00000000..c2237755 --- /dev/null +++ b/collects/typed-scheme/env/index-env.rkt @@ -0,0 +1,31 @@ +#lang racket/base + +;; this implements the Theta environment from the TOPLAS paper + +;; this environment maps type variables names (symbols) +;; to types representing the type variable +;; technically, the mapped-to type is unnecessary, but it's convenient to have it around? maybe? + +(require racket/require "type-env-structs.rkt" (path-up "utils/tc-utils.rkt" "rep/type-rep.rkt")) +(provide (all-defined-out)) + +;; the initial type variable environment - empty +;; this is used in the parsing of types +(define initial-index-env (make-empty-env #hasheq())) + +;; a parameter for the current type variables +(define current-indexes (make-parameter initial-index-env)) + +;; takes a single index +(define-syntax-rule (extend-indexes index . body) + (parameterize ([current-indexes (extend (current-indexes) index (make-F index))]) . body)) + +(define (bound-index? v) (lookup (current-indexes) v (lambda (_) #f))) + +(define (infer-index stx) + (define bounds (env-keys+vals (current-indexes))) + (when (null? bounds) + (tc-error/stx stx "No type variable bound with ... in scope for ... type")) + (unless (null? (cdr bounds)) + (tc-error/stx stx "Cannot infer bound for ... type")) + (car (car bounds))) \ No newline at end of file diff --git a/collects/typed-scheme/env/tvar-env.rkt b/collects/typed-scheme/env/tvar-env.rkt index f457e70c..dbe26849 100644 --- a/collects/typed-scheme/env/tvar-env.rkt +++ b/collects/typed-scheme/env/tvar-env.rkt @@ -1,10 +1,13 @@ #lang racket/base +;; this implements the Delta environment from the TOPLAS paper +;; (as well as every other paper on System F) + ;; this environment maps type variables names (symbols) ;; to types representing the type variable ;; technically, the mapped-to type is unnecessary, but it's convenient to have it around? maybe? -(require "type-env-structs.rkt") +(require racket/require "type-env-structs.rkt" (path-up "rep/type-rep.rkt")) (provide (all-defined-out)) ;; the initial type variable environment - empty @@ -12,4 +15,10 @@ (define initial-tvar-env (make-empty-env #hasheq())) ;; a parameter for the current type variables -(define current-tvars (make-parameter initial-tvar-env)) \ No newline at end of file +(define current-tvars (make-parameter initial-tvar-env)) + +;; takes a list of vars +(define-syntax-rule (extend-tvars vars . body) + (parameterize ([current-tvars (extend-env vars (map make-F vars) (current-tvars))]) . body)) + +(define (bound-tvar? v) (lookup (current-tvars) v (lambda (_) #f))) \ No newline at end of file diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index cf7bfe66..92c35874 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -6,10 +6,9 @@ "utils/utils.rkt" "utils/tc-utils.rkt" "rep/free-variance.rkt" "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/rep-utils.rkt" "types/convenience.rkt" "types/union.rkt" "types/subtype.rkt" "types/remove-intersect.rkt" "types/resolve.rkt" - "env/type-name-env.rkt") + "env/type-name-env.rkt" "env/index-env.rkt" "env/tvar-env.rkt") make-env) - (except-in (path-up "types/utils.rkt") Dotted) - (only-in (path-up "env/type-env-structs.rkt" "env/tvar-env.rkt") lookup current-tvars) + (path-up "types/utils.rkt") "constraint-structs.rkt" "signatures.rkt" scheme/match @@ -272,14 +271,14 @@ [((F: (? (lambda (e) (memq e X)) v)) S) (when (match S [(F: v*) - (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))] + (and (bound-index? v*) (not (bound-tvar? v*)))] [_ #f]) (fail! S T)) (singleton (Un) v (var-demote S V))] [(S (F: (? (lambda (e) (memq e X)) v))) (when (match S [(F: v*) - (just-Dotted? (lookup (current-tvars) v* (lambda _ #f)))] + (and (bound-index? v*) (not (bound-tvar? v*)))] [_ #f]) (fail! S T)) (singleton (var-promote S V) v Univ)] diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index 6e2c4f3e..ee9cd9dd 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -6,7 +6,7 @@ (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) + (env type-env-structs tvar-env type-name-env type-alias-env lexical-env index-env) scheme/match unstable/debug (for-template scheme/base "colon.ss") ;; needed at this phase for tests @@ -69,17 +69,15 @@ (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 ...)))] - [tvars (map make-F vars)] - [v (syntax-e #'v)] - [tv (make-Dotted (make-F v))]) + [v (syntax-e #'v)]) (add-type-name-reference #'kw) - (parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))]) - (make-PolyDots (append vars (list v)) (parse-all-body #'t))))] + (extend-indexes v + (extend-tvars vars + (make-PolyDots (append vars (list v)) (parse-all-body #'t)))))] [((~and kw t:All) (vars:id ...) . t) - (let* ([vars (map syntax-e (syntax->list #'(vars ...)))] - [tvars (map make-F vars)]) + (let* ([vars (map syntax-e (syntax->list #'(vars ...)))]) (add-type-name-reference #'kw) - (parameterize ([current-tvars (extend-env vars tvars (current-tvars))]) + (extend-tvars vars (make-Poly vars (parse-all-body #'t))))] [(t:All (_:id ...) _ _ _ ...) (tc-error "All: too many forms in body of All type")] [(t:All . rest) (tc-error "All: bad syntax")])) @@ -179,10 +177,7 @@ (let* ([var (syntax-e #'x)] [tvar (make-F var)]) (add-type-name-reference #'kw) - (parameterize ([current-tvars (extend-env - (list var) - (list tvar) - (current-tvars))]) + (extend-tvars (list var) (let ([t (parse-type #'t)]) (if (memq var (fv t)) (make-Mu var t) @@ -223,41 +218,27 @@ #:kws (attribute kws.Keyword))))] [(dom:expr ... rest:expr :ddd/bound (~and kw t:->) rng) (add-type-name-reference #'kw) - (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))]) - (if (not (Dotted? var)) - (tc-error/stx #'bound - "Used a type variable (~a) not bound with ... as a bound on a ..." - (syntax-e #'bound)) - (make-Function - (list - (make-arr-dots (map parse-type (syntax->list #'(dom ...))) - (parse-values-type #'rng) - (parameterize - ([current-tvars - (extend-env - (list (syntax-e #'bound)) - (list (make-DottedBoth (make-F (syntax-e #'bound)))) - (current-tvars))]) - (parse-type #'rest)) - (syntax-e #'bound))))))] + (let* ([bnd (syntax-e #'bound)]) + (unless (bound-index? bnd) + (tc-error/stx #'bound + "Used a type variable (~a) not bound with ... as a bound on a ..." + bnd)) + (make-Function + (list + (make-arr-dots (map parse-type (syntax->list #'(dom ...))) + (parse-values-type #'rng) + (extend-tvars (list bnd) + (parse-type #'rest)) + bnd))))] [(dom:expr ... rest:expr _:ddd (~and kw t:->) rng) (add-type-name-reference #'kw) - (let ([bounds (env-keys+vals (env-filter (compose Dotted? cdr) (current-tvars)))]) - (when (null? bounds) - (tc-error/stx stx "No type variable bound with ... in scope for ... type")) - (unless (null? (cdr bounds)) - (tc-error/stx stx "Cannot infer bound for ... type")) - (match-let ([(cons var (struct Dotted (t))) (car bounds)]) - (make-Function - (list - (make-arr-dots (map parse-type (syntax->list #'(dom ...))) - (parse-values-type #'rng) - (parameterize ([current-tvars - (extend-env (list var) - (list (make-DottedBoth t)) - (current-tvars))]) - (parse-type #'rest)) - var)))))] + (let ([var (infer-index stx)]) + (make-Function + (list + (make-arr-dots (map parse-type (syntax->list #'(dom ...))) + (parse-values-type #'rng) + (extend-tvars (list var) (parse-type #'rest)) + var))))] #| ;; has to be below the previous one [(dom:expr ... (~and kw t:->) rng) (add-type-name-reference #'kw) @@ -275,14 +256,13 @@ [id:identifier (cond ;; if it's a type variable, we just produce the corresponding reference (which is in the HT) - [(lookup (current-tvars) (syntax-e #'id) (lambda (_) #f)) - => - (lambda (e) (cond [(DottedBoth? e) (Dotted-t e)] - [(Dotted? e) - (tc-error - "Type variable ~a must be used with ..." - (syntax-e #'id))] - [else e]))] + [(bound-tvar? (syntax-e #'id)) + (make-F (syntax-e #'id))] + ;; if it was in current-indexes, produce a better error msg + [(bound-index? (syntax-e #'id)) + (tc-error + "Type variable ~a must be used with ..." + (syntax-e #'id))] ;; if it's a type alias, we expand it (the expanded type is stored in the HT) [(lookup-type-alias #'id parse-type (lambda () #f)) => @@ -354,31 +334,24 @@ (syntax-parse stx #:literals (t:List) [((~and kw t:List) tys ... dty :ddd/bound) (add-type-name-reference #'kw) - (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))]) - (if (not (Dotted? var)) - (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." (syntax-e #'bound)) - (-Tuple* (map parse-type (syntax->list #'(tys ...))) - (make-ListDots - (parameterize ([current-tvars (extend-env (list (syntax-e #'bound)) - (list (make-DottedBoth (make-F (syntax-e #'bound)))) - (current-tvars))]) - (parse-type #'dty)) - (syntax-e #'bound)))))] + (let ([var (syntax-e #'bound)]) + (unless (bound-index? var) + (if (bound-tvar? var) + (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." var) + (tc-error/stx #'bound "Type variable ~a is unbound" var))) + (-Tuple* (map parse-type (syntax->list #'(tys ...))) + (make-ListDots + (extend-tvars (list var) + (parse-type #'dty)) + var)))] [((~and kw t:List) tys ... dty _:ddd) (add-type-name-reference #'kw) - (let ([bounds (env-keys+vals (env-filter (compose Dotted? cdr) (current-tvars)))]) - (when (null? bounds) - (tc-error/stx stx "No type variable bound with ... in scope for ... type")) - (unless (null? (cdr bounds)) - (tc-error/stx stx "Cannot infer bound for ... type")) - (match-let ([(cons var (struct Dotted (t))) (car bounds)]) - (-Tuple* (map parse-type (syntax->list #'(tys ...))) + (let ([var (infer-index stx)]) + (-Tuple* (map parse-type (syntax->list #'(tys ...))) (make-ListDots - (parameterize ([current-tvars (extend-env (list var) - (list (make-DottedBoth t)) - (current-tvars))]) + (extend-tvars (list var) (parse-type #'dty)) - var))))] + var)))] [((~and kw t:List) tys ...) (add-type-name-reference #'kw) (-Tuple (map parse-type (syntax->list #'(tys ...))))]))) @@ -388,29 +361,22 @@ (syntax-parse stx #:literals (values t:All) [((~and kw values) tys ... dty :ddd/bound) (add-type-name-reference #'kw) - (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))]) - (if (not (Dotted? var)) - (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." (syntax-e #'bound)) - (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) - (parameterize ([current-tvars (extend-env (list (syntax-e #'bound)) - (list (make-DottedBoth (make-F (syntax-e #'bound)))) - (current-tvars))]) - (parse-type #'dty)) - (syntax-e #'bound))))] + (let ([var (syntax-e #'bound)]) + (unless (bound-index? var) + (if (bound-tvar? var) + (tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." var) + (tc-error/stx #'bound "Type variable ~a is unbound" var))) + (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) + (extend-tvars (list var) + (parse-type #'dty)) + var))] [((~and kw values) tys ... dty _:ddd) (add-type-name-reference #'kw) - (let ([bounds (env-keys+vals (env-filter (compose Dotted? cdr) (current-tvars)))]) - (when (null? bounds) - (tc-error/stx stx "No type variable bound with ... in scope for ... type")) - (unless (null? (cdr bounds)) - (tc-error/stx stx "Cannot infer bound for ... type")) - (match-let ([(cons var (struct Dotted (t))) (car bounds)]) - (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) - (parameterize ([current-tvars (extend-env (list var) - (list (make-DottedBoth t)) - (current-tvars))]) + (let ([var (infer-index stx)]) + (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) + (extend-tvars (list var) (parse-type #'dty)) - var)))] + var))] [((~and kw values) tys ...) (add-type-name-reference #'kw) (-values (map parse-type (syntax->list #'(tys ...))))] diff --git a/collects/typed-scheme/private/with-types.rkt b/collects/typed-scheme/private/with-types.rkt index e5cd04f6..601bdb38 100644 --- a/collects/typed-scheme/private/with-types.rkt +++ b/collects/typed-scheme/private/with-types.rkt @@ -71,8 +71,6 @@ [infer-param infer] ;; do we report multiple errors [delay-errors? #t] - ;; this parameter is for parsing types - [current-tvars initial-tvar-env] ;; this parameter is just for printing types ;; this is a parameter to avoid dependency issues [current-type-names diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt index 26c67c12..66d1ea32 100644 --- a/collects/typed-scheme/tc-setup.rkt +++ b/collects/typed-scheme/tc-setup.rkt @@ -36,8 +36,6 @@ [infer-param infer] ;; do we report multiple errors [delay-errors? #t] - ;; this parameter is for parsing types - [current-tvars initial-tvar-env] ;; this parameter is just for printing types ;; this is a parameter to avoid dependency issues [current-type-names diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index b26f8e5e..84f6004b 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -16,7 +16,7 @@ (types utils abbrev union subtype resolve convenience type-table) (utils tc-utils) (only-in srfi/1 alist-delete) - (except-in (env type-env-structs tvar-env) extend) + (except-in (env type-env-structs tvar-env index-env) extend) (rep type-rep filter-rep object-rep) (r:infer infer) '#%paramz @@ -410,11 +410,10 @@ (not (eq? tail-bound (cdr (car drests*)))) (= (length (car doms*)) (length arg-tys)) - (parameterize ([current-tvars (extend-env (list tail-bound (cdr (car drests*))) - (list (make-DottedBoth (make-F tail-bound)) - (make-DottedBoth (make-F (cdr (car drests*))))) - (current-tvars))]) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))) + (extend-tvars (list tail-bound (cdr (car drests*))) + (extend-indexes (cdr (car drests*)) + ;; don't need to add tail-bound - it must already be an index + (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))))) => (lambda (substitution) (define drest-bound (cdr (car drests*))) (do-ret (substitute-dotted (cadr (assq drest-bound substitution)) @@ -636,9 +635,8 @@ (match (single-value #'arg) ;; if the argument is a ListDots [(tc-result1: (ListDots: t bound)) - (match (parameterize ([current-tvars (extend-env (list bound) - (list (make-DottedBoth (make-F bound))) - (current-tvars))]) + + (match (extend-tvars (list bound) ;; just check that the function applies successfully to the element type (tc/funapp #'f #'(arg) (tc-expr #'f) (list (ret t)) expected)) [(tc-result1: t) (ret (make-ListDots t bound))] diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 65ba6a06..84c4d0d0 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -10,8 +10,7 @@ (rep type-rep) (only-in (infer infer) restrict) (except-in (utils tc-utils stxclass-util)) - (env lexical-env) - (only-in (env type-env-structs tvar-env) lookup current-tvars extend-env) + (env lexical-env type-env-structs tvar-env index-env) racket/private/class-internal unstable/debug (except-in syntax/parse id) (only-in srfi/1 split-at)) @@ -118,15 +117,11 @@ (let-values ([(all-but-last last-stx) (split-last (syntax->list inst))]) (match (syntax-e last-stx) [(cons last-ty-stx (? identifier? last-id-stx)) - (unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f))) + (unless (bound-index? (syntax-e last-id-stx)) (tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx))) (if (= (length all-but-last) (sub1 (PolyDots-n ty))) (let* ([last-id (syntax-e last-id-stx)] - [last-ty - (parameterize ([current-tvars (extend-env (list last-id) - (list (make-DottedBoth (make-F last-id))) - (current-tvars))]) - (parse-type last-ty-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" ty (sub1 (PolyDots-n ty)) (length all-but-last)))] diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt index 056689e8..66494e60 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt @@ -13,7 +13,7 @@ [make-arr* make-arr]) (private type-annotation) (types abbrev utils) - (env type-env-structs lexical-env tvar-env) + (env type-env-structs lexical-env tvar-env index-env) (utils tc-utils) unstable/debug scheme/match) @@ -138,14 +138,11 @@ [(dotted? #'rest) => (lambda (bound) - (unless (Dotted? (lookup (current-tvars) bound - (lambda _ (tc-error/stx #'rest - "Bound on ... type (~a) was not in scope" bound)))) - (tc-error "Bound on ... type (~a) is not an appropriate type variable" bound)) - (let ([rest-type (parameterize ([current-tvars - (extend-env (list bound) - (list (make-DottedBoth (make-F bound))) - (current-tvars))]) + (unless (bound-index? bound) + (if (bound-tvar? bound) + (tc-error "Bound on ... type (~a) is not an appropriate type variable" bound) + (tc-error/stx #'rest "Bound on ... type (~a) was not in scope" bound))) + (let ([rest-type (extend-tvars (list bound) (get-type #'rest #:default Univ))]) (with-lexical-env/extend (cons #'rest arg-list) @@ -252,9 +249,7 @@ "Expected a polymorphic function without ..., but given function had ...")) (or (and p (map syntax-e (syntax->list p))) ns))] - [literal-tvars tvars] - [new-tvars (map make-F literal-tvars)] - [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) + [ty (extend-tvars tvars (maybe-loop form formals bodies (ret expected*)))]) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) t)] @@ -268,31 +263,23 @@ (values var dvar)] [_ (tc-error "Expected a polymorphic function with ..., but given function had no ...")]) (values ns dvar)))]) - (let* ([literal-tvars tvars] - [new-tvars (map make-F literal-tvars)] - [ty (parameterize ([current-tvars (extend-env (cons dotted literal-tvars) - (cons (make-Dotted (make-F dotted)) - new-tvars) - (current-tvars))]) - (maybe-loop form formals bodies (ret expected*)))]) - t))] + ;; check the body for side effect + (extend-indexes dotted + (extend-tvars tvars + (maybe-loop form formals bodies (ret expected*)))) + t)] [#f (match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda))) [(list tvars ... dotted-var '...) - (let* ([literal-tvars tvars] - [new-tvars (map make-F literal-tvars)] - [ty (parameterize ([current-tvars (extend-env (cons dotted-var literal-tvars) - (cons (make-Dotted (make-F dotted-var)) new-tvars) - (current-tvars))]) - (tc/mono-lambda/type formals bodies #f))]) - (make-PolyDots (append literal-tvars (list dotted-var)) ty))] + (let* ([ty (extend-indexes dotted-var + (extend-tvars tvars + (tc/mono-lambda/type formals bodies #f)))]) + (make-PolyDots (append tvars (list dotted-var)) ty))] [tvars - (let* ([literal-tvars tvars] - [new-tvars (map make-F literal-tvars)] - [ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))]) + (let* ([ty (extend-tvars tvars (tc/mono-lambda/type formals bodies #f))]) ;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty) - (make-Poly literal-tvars ty))])] + (make-Poly tvars ty))])] [(tc-result1: t) (unless (check-below (tc/plambda form formals bodies #f) t) (tc-error/expr #:return expected diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index a4945ca3..828f36ff 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -181,10 +181,10 @@ ;; parse the types (define types ;; add the type parameters of this structure to the tvar env - (parameterize ([current-tvars (extend-env tvars new-tvars (current-tvars))] - [current-poly-struct `#s(poly ,nm ,new-tvars)]) - ;; parse the field types - (map parse-type tys))) + (extend-tvars tvars + (parameterize ([current-poly-struct `#s(poly ,nm ,new-tvars)]) + ;; parse the field types + (map parse-type tys)))) ;; instantiate the parent if necessary, with new-tvars (define concrete-parent (if (Poly? parent) diff --git a/collects/typed-scheme/types/utils.rkt b/collects/typed-scheme/types/utils.rkt index f32aae39..024b7b66 100644 --- a/collects/typed-scheme/types/utils.rkt +++ b/collects/typed-scheme/types/utils.rkt @@ -5,6 +5,7 @@ (require (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) (only-in (rep free-variance) combine-frees) + (env index-env tvar-env) scheme/match scheme/list mzlib/trace @@ -25,9 +26,6 @@ effects-equal? tc-result-t unfold - (struct-out Dotted) - (struct-out DottedBoth) - just-Dotted? tc-error/expr lookup-fail lookup-type-fail @@ -48,7 +46,7 @@ (begin (when (and (pair? drest) (eq? name (cdr drest)) - (just-Dotted? name)) + (not (bound-tvar? name))) (int-err "substitute used on ... variable ~a in type ~a" name target)) (make-arr (map sb dom) (sb rng) @@ -57,12 +55,12 @@ (map sb kws)))] [#:ValuesDots types dty dbound (begin - (when (eq? name dbound) + (when (and (eq? name dbound) (not (bound-tvar? name))) (int-err "substitute used on ... variable ~a in type ~a" name target)) (make-ValuesDots (map sb types) (sb dty) dbound))] [#:ListDots dty dbound (begin - (when (eq? name dbound) + (when (and (eq? name dbound) (not (bound-tvar? name))) (int-err "substitute used on ... variable ~a in type ~a" name target)) (make-ListDots (sb dty) dbound))]) target)) @@ -299,14 +297,6 @@ ;; fv/list : Listof[Type] -> Listof[Name] (define (fv/list ts) (hash-map (combine-frees (map free-vars* ts)) (lambda (k v) k))) -;; t is (make-F v) -(define-struct Dotted (t)) -(define-struct (DottedBoth Dotted) ()) - -(define (just-Dotted? S) - (and (Dotted? S) - (not (DottedBoth? S)))) - (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)) return) From 78b767252db29ef88f28d7685abc493fb8432190 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 May 2010 15:27:49 -0400 Subject: [PATCH 078/198] Refactor test harness. original commit: e9f8cc9aca6a67a9b56f0ba9dd202f0fa2669ab6 --- collects/tests/typed-scheme/run.rkt | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-scheme/run.rkt index f2ff3c10..c462e3d9 100644 --- a/collects/tests/typed-scheme/run.rkt +++ b/collects/tests/typed-scheme/run.rkt @@ -1,7 +1,15 @@ -#lang racket/base -(require racket/vector) +#lang racket +(require racket/vector racket/gui/dynamic) (require "main.ss") (current-namespace (make-base-namespace)) -(unless (= 0 (go/text (vector-member "unit" (current-command-line-arguments)))) +(define exec (make-parameter go/text)) +(define unit-only? (make-parameter #f)) +(command-line + #:once-each + ["--unit" "run just the unit tests" (unit-only? #t)] + ["--gui" "run using the gui" + (current-namespace ((gui-dynamic-require 'make-gui-namespace))) + (exec go)]) +(unless (= 0 ((exec) (unit-only?))) (error "Typed Scheme Tests did not pass.")) From 38e065db7f8359e3745fd779c77a67b6ec3f021a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 May 2010 16:00:37 -0400 Subject: [PATCH 079/198] Change type variable environments from hash tables to sets. original commit: 12384c6c3fd14020c99018d51058240f4258074d --- .../typed-scheme/unit-tests/parse-type-tests.rkt | 4 ++-- collects/typed-scheme/env/index-env.rkt | 12 ++++++------ collects/typed-scheme/env/tvar-env.rkt | 8 ++++---- 3 files changed, 12 insertions(+), 12 deletions(-) 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 5174bbda..ac32ab7e 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.rkt @@ -1,5 +1,6 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base) + racket/set (utils tc-utils) (env type-alias-env type-env-structs tvar-env type-name-env init-envs) (rep type-rep) @@ -105,8 +106,7 @@ [(Listof Number) (make-Listof N)] - [a (-v a) (extend-env (list 'a) (list (-v a)) - initial-tvar-env)] + [a (-v a) (set-add initial-tvar-env 'a)] [(All (a ...) (a ... -> Number)) (-polydots (a) ((list) [a a] . ->... . N))] diff --git a/collects/typed-scheme/env/index-env.rkt b/collects/typed-scheme/env/index-env.rkt index c2237755..4a6218ec 100644 --- a/collects/typed-scheme/env/index-env.rkt +++ b/collects/typed-scheme/env/index-env.rkt @@ -6,26 +6,26 @@ ;; to types representing the type variable ;; technically, the mapped-to type is unnecessary, but it's convenient to have it around? maybe? -(require racket/require "type-env-structs.rkt" (path-up "utils/tc-utils.rkt" "rep/type-rep.rkt")) +(require racket/require racket/set (path-up "utils/tc-utils.rkt")) (provide (all-defined-out)) ;; the initial type variable environment - empty ;; this is used in the parsing of types -(define initial-index-env (make-empty-env #hasheq())) +(define initial-index-env (seteq)) ;; a parameter for the current type variables (define current-indexes (make-parameter initial-index-env)) ;; takes a single index (define-syntax-rule (extend-indexes index . body) - (parameterize ([current-indexes (extend (current-indexes) index (make-F index))]) . body)) + (parameterize ([current-indexes (set-add (current-indexes) index)]) . body)) -(define (bound-index? v) (lookup (current-indexes) v (lambda (_) #f))) +(define (bound-index? v) (set-member? (current-indexes) v)) (define (infer-index stx) - (define bounds (env-keys+vals (current-indexes))) + (define bounds (set-map (current-indexes) values)) (when (null? bounds) (tc-error/stx stx "No type variable bound with ... in scope for ... type")) (unless (null? (cdr bounds)) (tc-error/stx stx "Cannot infer bound for ... type")) - (car (car bounds))) \ No newline at end of file + (car bounds)) \ No newline at end of file diff --git a/collects/typed-scheme/env/tvar-env.rkt b/collects/typed-scheme/env/tvar-env.rkt index dbe26849..88e933e0 100644 --- a/collects/typed-scheme/env/tvar-env.rkt +++ b/collects/typed-scheme/env/tvar-env.rkt @@ -7,18 +7,18 @@ ;; to types representing the type variable ;; technically, the mapped-to type is unnecessary, but it's convenient to have it around? maybe? -(require racket/require "type-env-structs.rkt" (path-up "rep/type-rep.rkt")) +(require racket/set) (provide (all-defined-out)) ;; the initial type variable environment - empty ;; this is used in the parsing of types -(define initial-tvar-env (make-empty-env #hasheq())) +(define initial-tvar-env (seteq)) ;; a parameter for the current type variables (define current-tvars (make-parameter initial-tvar-env)) ;; takes a list of vars (define-syntax-rule (extend-tvars vars . body) - (parameterize ([current-tvars (extend-env vars (map make-F vars) (current-tvars))]) . body)) + (parameterize ([current-tvars (foldr (λ (v s) (set-add s v)) (current-tvars) vars)]) . body)) -(define (bound-tvar? v) (lookup (current-tvars) v (lambda (_) #f))) \ No newline at end of file +(define (bound-tvar? v) (set-member? (current-tvars) v)) \ No newline at end of file From b3b2b264a9b9c2545363733d22f399a01d709d0f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 May 2010 17:23:10 -0400 Subject: [PATCH 080/198] Special case for (apply values ListDots) original commit: a93aecbed74672948b598a960f667d3240f86031 --- collects/typed-scheme/typecheck/tc-app.rkt | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 84f6004b..e34275b9 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -567,10 +567,10 @@ (ret -Boolean (make-FilterSet f- f+))])] ;; (apply values l) gets special handling [(#%plain-app apply values e) - (cond [(with-handlers ([exn:fail? (lambda _ #f)]) - (untuple (tc-expr/t #'e))) - => ret] - [else (tc/apply #'values #'(e))])] + (match (single-value #'e) + [(tc-result1: (ListDots: dty dbound)) (values->tc-results (make-ValuesDots null dty dbound) #f)] + [(tc-result1: (List: ts)) (ret ts)] + [_ (tc/apply #'values #'(e))])] ;; rewrite this so that it takes advantages of all the special cases [(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (#%plain-app apply . args)) expected)] ;; handle apply specially From d37f9f7d54b23176e1e5947cfbad712cbe65ee69 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 1 Jun 2010 13:54:20 -0400 Subject: [PATCH 081/198] Switch to using functional hash tables for free variables. original commit: b787c7766c3cac9a5054d6a76ec5de1a78a540c2 --- collects/typed-scheme/rep/free-variance.rkt | 66 ++++++++------------- collects/typed-scheme/rep/rep-utils.rkt | 6 +- collects/typed-scheme/rep/type-rep.rkt | 4 +- 3 files changed, 29 insertions(+), 47 deletions(-) diff --git a/collects/typed-scheme/rep/free-variance.rkt b/collects/typed-scheme/rep/free-variance.rkt index 41fc238c..3e9471d9 100644 --- a/collects/typed-scheme/rep/free-variance.rkt +++ b/collects/typed-scheme/rep/free-variance.rkt @@ -5,33 +5,30 @@ mzlib/etc scheme/contract) (provide Covariant Contravariant Invariant Constant Dotted - combine-frees flip-variances without-below unless-in-table empty-hash-table + combine-frees flip-variances without-below unless-in-table fix-bound make-invariant variance?) ;; this file contains support for calculating the free variables/indexes of types ;; actual computation is done in rep-utils.rkt and type-rep.rkt (define-values (Covariant Contravariant Invariant Constant Dotted) (let () - (define-struct Variance () #:inspector #f) - (define-struct (Covariant Variance) () #:inspector #f) - (define-struct (Contravariant Variance) () #:inspector #f) - (define-struct (Invariant Variance) () #:inspector #f) - (define-struct (Constant Variance) () #:inspector #f) + (define-struct Variance () #:transparent) + (define-struct (Covariant Variance) () #:transparent) + (define-struct (Contravariant Variance) () #:transparent) + (define-struct (Invariant Variance) () #:transparent) + (define-struct (Constant Variance) () #:transparent) ;; not really a variance, but is disjoint with the others - (define-struct (Dotted Variance) () #:inspector #f) + (define-struct (Dotted Variance) () #:transparent) (values (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted)))) (define (variance? e) (memq e (list Covariant Contravariant Invariant Constant Dotted))) -(define empty-hash-table (make-immutable-hasheq null)) - ;; frees = HT[Idx,Variance] where Idx is either Symbol or Number ;; (listof frees) -> frees (define (combine-frees freess) - (define ht (make-hasheq)) - (define (combine-var v w) + (define ((combine-var v) w) (cond [(eq? v w) v] [(eq? v Dotted) w] @@ -39,50 +36,35 @@ [(eq? v Constant) w] [(eq? w Constant) v] [else Invariant])) - (for* ([old-ht (in-list freess)] - [(sym var) (in-hash old-ht)]) - (let* ([sym-var (hash-ref ht sym (lambda () #f))]) - (if sym-var - (hash-set! ht sym (combine-var var sym-var)) - (hash-set! ht sym var)))) - ht) + (for*/fold ([ht #hasheq()]) + ([old-ht (in-list freess)] + [(sym var) (in-hash old-ht)]) + (hash-update ht sym (combine-var var) var))) ;; given a set of free variables, change bound to ... ;; (if bound wasn't free, this will add it as Dotted ;; appropriately so that things that expect to see ;; it as "free" will -- fixes the case where the ;; dotted pre-type base doesn't use the bound). -(define (fix-bound vs bound) - (define vs* (hash-map* (lambda (k v) v) vs)) - (hash-set! vs* bound Dotted) - vs*) +(define (fix-bound vs bound) + (hash-set vs bound Dotted)) ;; frees -> frees (define (flip-variances vs) - (hash-map* - (lambda (k v) - (evcase v - [Covariant Contravariant] - [Contravariant Covariant] - [v v])) - vs)) + (for/hasheq ([(k v) (in-hash vs)]) + (values k (evcase v + [Covariant Contravariant] + [Contravariant Covariant] + [v v])))) (define (make-invariant vs) - (hash-map* - (lambda (k v) Invariant) - vs)) - -(define (hash-map* f ht) - (define new-ht (make-hasheq)) - (for ([(k v) (in-hash ht)]) - (hash-set! new-ht k (f k v))) - new-ht) + (for/hasheq ([(k v) (in-hash vs)]) + (values k Invariant))) (define (without-below n frees) - (define new-ht (make-hasheq)) - (for ([(k v) (in-hash frees)]) - (when (>= k n) (hash-set! new-ht k v))) - new-ht) + (for/hasheq ([(k v) (in-hash frees)] + #:when (>= k n)) + (values k v))) (define-syntax (unless-in-table stx) (syntax-case stx () diff --git a/collects/typed-scheme/rep/rep-utils.rkt b/collects/typed-scheme/rep/rep-utils.rkt index ade55c9f..8432cf57 100644 --- a/collects/typed-scheme/rep/rep-utils.rkt +++ b/collects/typed-scheme/rep/rep-utils.rkt @@ -47,7 +47,7 @@ (define (combiner f flds) (syntax-parse flds - [() #'empty-hash-table] + [() #'#hasheq()] [(e) #`(#,f e)] [(e ...) #`(combine-frees (list (#,f e) ...))])) (define-splicing-syntax-class frees-pat @@ -55,8 +55,8 @@ #:attributes (f1 f2) (pattern (~seq f1:expr f2:expr)) (pattern #f - #:with f1 #'empty-hash-table - #:with f2 #'empty-hash-table) + #:with f1 #'#hasheq() + #:with f2 #'#hasheq()) (pattern e:expr #:with f1 #'(e Rep-free-vars) #:with f2 #'(e Rep-free-idxs))) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 985685c9..3fffd5ab 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -43,11 +43,11 @@ ;; i is an nat (dt B ([i natural-number/c]) - [#:frees empty-hash-table (make-immutable-hasheq (list (cons i Covariant)))] + [#:frees #hasheq() (make-immutable-hasheq (list (cons i Covariant)))] [#:fold-rhs #:base]) ;; n is a Name -(dt F ([n symbol?]) [#:frees (make-immutable-hasheq (list (cons n Covariant))) empty-hash-table] [#:fold-rhs #:base]) +(dt F ([n symbol?]) [#:frees (make-immutable-hasheq (list (cons n Covariant))) #hasheq()] [#:fold-rhs #:base]) ;; id is an Identifier (dt Name ([id identifier?]) [#:intern (hash-id id)] [#:frees #f] [#:fold-rhs #:base]) From 9d6132fa0ef882b1ed92403f69713cdf4eedf7e7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 1 Jun 2010 13:54:43 -0400 Subject: [PATCH 082/198] Add case to be fixed original commit: fe9395fdbf0dcf8e64bdfaf247845c7858e35423 --- collects/typed-scheme/typecheck/tc-expr-unit.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 84c4d0d0..8a55e2d3 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -238,6 +238,8 @@ (unless (subtype t1 t2) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) expected] + [((tc-results: ts fs os dty dbound) (tc-results: ts* fs* os* dty* dbound*)) + (int-err "dotted types in check-below nyi: ~a ~a" dty dty*)] [(a b) (int-err "unexpected input for check-below: ~a ~a" a b)])) (define (tc-expr/check/type form expected) From fbd795c01e364549979dafed62b4869aded69061 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 1 Jun 2010 16:30:04 -0400 Subject: [PATCH 083/198] Re-enable the printer here. original commit: 7b2de5373380a0bc833215dd9d3beed87fa686c3 --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 3ab510d6..25a881d3 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -62,6 +62,7 @@ [(_ e) #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] + [custom-printer #t] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) (parameterize ([mutated-vars (find-mutated-vars ex)]) @@ -72,6 +73,7 @@ [(_ e) #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] + [custom-printer #t] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) (parameterize ([mutated-vars (find-mutated-vars ex)]) From 0d7111128c76a68e956f6b7ccf889cdb2b620541 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 1 Jun 2010 16:30:41 -0400 Subject: [PATCH 084/198] Refactor free variables. - free-idxs no longer holds free de Bruijn indexes This information is not needed, and not stored anywhere - free-idxs holds free *index* variables, in the sense of the TOPLAS submission original commit: 662f982b724e7194f5729a9894fc642f06e7910f --- collects/typed-scheme/rep/rep-utils.rkt | 6 +- collects/typed-scheme/rep/type-rep.rkt | 97 +++++++++++-------------- collects/typed-scheme/types/utils.rkt | 12 +-- 3 files changed, 52 insertions(+), 63 deletions(-) diff --git a/collects/typed-scheme/rep/rep-utils.rkt b/collects/typed-scheme/rep/rep-utils.rkt index 8432cf57..3f789813 100644 --- a/collects/typed-scheme/rep/rep-utils.rkt +++ b/collects/typed-scheme/rep/rep-utils.rkt @@ -130,7 +130,7 @@ #,(quasisyntax/loc #'nm (defintern (nm.*maker . flds.fs) flds.maker intern? #:extra-args - frees.f1 frees.f2 #:syntax [orig-stx #f] + frees.f1 frees.f2 #:syntax [orig-stx #f] #,@(if key? (list #'key-expr) null))))) provides))]))) @@ -247,8 +247,8 @@ [Rep-free-idxs free-idxs*])) (p/c (struct Rep ([seq exact-nonnegative-integer?] - [free-vars (hash/c symbol? variance?)] - [free-idxs (hash/c exact-nonnegative-integer? variance?)] + [free-vars (hash/c symbol? variance?)] + [free-idxs (hash/c symbol? variance?)] [stx (or/c #f syntax?)])) [replace-syntax (Rep? syntax? . -> . Rep?)]) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 3fffd5ab..1b616544 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -41,11 +41,12 @@ ;; this is ONLY used when a type error ocurrs (dt Error () [#:frees #f] [#:fold-rhs #:base]) +;; de Bruijn indexes - should never appear outside of this file +;; bound type variables ;; i is an nat -(dt B ([i natural-number/c]) - [#:frees #hasheq() (make-immutable-hasheq (list (cons i Covariant)))] - [#:fold-rhs #:base]) +(dt B ([i natural-number/c]) [#:frees #f] [#:fold-rhs #:base]) +;; free type variables ;; n is a Name (dt F ([n symbol?]) [#:frees (make-immutable-hasheq (list (cons n Covariant))) #hasheq()] [#:fold-rhs #:base]) @@ -57,8 +58,7 @@ ;; stx is the syntax of the pair of parens (dt App ([rator Type/c] [rands (listof Type/c)] [stx (or/c #f syntax?)]) [#:intern (list rator rands)] - [#:frees (combine-frees (map free-vars* (cons rator rands))) - (combine-frees (map free-idxs* (cons rator rands)))] + [#:frees (λ (f) (combine-frees (map f (cons rator rands))))] [#:fold-rhs (*App (type-rec-id rator) (map type-rec-id rands) stx)]) @@ -69,39 +69,44 @@ ;; dotted list -- after expansion, becomes normal Pair-based list type (dt ListDots ([dty Type/c] [dbound (or/c symbol? natural-number/c)]) [#:frees (if (symbol? dbound) - (fix-bound (free-vars* dty) dbound) + (hash-remove (free-vars* dty) dbound) (free-vars* dty)) - (if (number? dbound) - (fix-bound (free-idxs* dty) dbound) + (if (symbol? dbound) + (hash-set (free-idxs* dty) dbound Covariant) (free-idxs* dty))] [#:fold-rhs (*ListDots (type-rec-id dty) dbound)]) ;; *mutable* pairs - distinct from regular pairs ;; left and right are Types -(dt MPair ([left Type/c] [right Type/c]) [#:key 'mpair]) +(dt MPair ([left Type/c] [right Type/c]) + [#:frees (λ (f) (make-invariant (combine-frees (list (f left) (f right)))))] + [#:key 'mpair]) ;; elem is a Type (dt Vector ([elem Type/c]) - [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] + [#:frees (λ (f) (make-invariant (f elem)))] [#:key 'vector]) ;; elems are all Types (dt HeterogenousVector ([elems (listof Type/c)]) - [#:frees (make-invariant (combine-frees (map free-vars* elems))) (make-invariant (combine-frees (map free-idxs* elems)))] + [#:frees (λ (f) (make-invariant (combine-frees (map f elems))))] [#:key 'vector] [#:fold-rhs (*HeterogenousVector (map type-rec-id elems))]) ;; elem is a Type -(dt Box ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] - [#:key 'box]) +(dt Box ([elem Type/c]) + [#:frees (λ (f) (make-invariant (f elem)))] + [#:key 'box]) ;; elem is a Type -(dt Channel ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))] +(dt Channel ([elem Type/c]) + [#:frees (λ (f) (make-invariant (f elem)))] [#:key 'channel]) ;; name is a Symbol (not a Name) -(dt Base ([name symbol?] [contract syntax?]) [#:frees #f] [#:fold-rhs #:base] [#:intern name] +(dt Base ([name symbol?] [contract syntax?]) + [#:frees #f] [#:fold-rhs #:base] [#:intern name] [#:key (case name [(Number Integer) 'number] [(Boolean) 'boolean] @@ -111,9 +116,9 @@ [else #f])]) ;; body is a Scope -(dt Mu ([body (scope-depth 1)]) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))] +(dt Mu ([body (scope-depth 1)]) #:no-provide [#:frees (λ (f) (f body))] [#:fold-rhs (*Mu (*Scope (type-rec-id (Scope-t body))))] - [#:key (Type-key body)]) + [#:key (Type-key body)]) ;; n is how many variables are bound here ;; body is a Scope @@ -122,7 +127,7 @@ [body (scope-depth n)]) (#:syntax [stx (or/c #f syntax?)]) [result Poly?])] - [#:frees (free-vars* body) (without-below n (free-idxs* body))] + [#:frees (λ (f) (f body))] [#:fold-rhs (let ([body* (remove-scopes n body)]) (*Poly n (add-scopes n (type-rec-id body*))))] [#:key (Type-key body)]) @@ -136,7 +141,7 @@ (#:syntax [stx (or/c #f syntax?)]) [result PolyDots?])] [#:key (Type-key body)] - [#:frees (free-vars* body) (without-below n (free-idxs* body))] + [#:frees (λ (f) (f body))] [#:fold-rhs (let ([body* (remove-scopes n body)]) (*PolyDots n (add-scopes n (type-rec-id body*))))]) @@ -163,10 +168,10 @@ (dt ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)]) [#:frees (if (symbol? dbound) - (fix-bound (combine-frees (map free-vars* (cons dty rs))) dbound) + (hash-remove (combine-frees (map free-vars* (cons dty rs))) dbound) (combine-frees (map free-vars* (cons dty rs)))) - (if (number? dbound) - (fix-bound (combine-frees (map free-idxs* (cons dty rs))) dbound) + (if (symbol? dbound) + (hash-set (combine-frees (map free-idxs* (cons dty rs))) dbound Covariant) (combine-frees (map free-idxs* (cons dty rs))))] [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)]) @@ -184,10 +189,10 @@ dom)) (match drest [(cons t (? symbol? bnd)) - (list (fix-bound (flip-variances (free-vars* t)) bnd))] - [(cons t (? number? bnd)) + (list (hash-remove (flip-variances (free-vars* t)) bnd))] + [(cons t _) (list (flip-variances (free-vars* t)))] - [#f null]) + [_ null]) (list (free-vars* rng)))) (combine-frees (append (map (compose flip-variances free-idxs*) @@ -196,10 +201,10 @@ dom)) (match drest [(cons t (? symbol? bnd)) + (list (hash-set (flip-variances (free-idxs* t)) bnd Contravariant))] + [(cons t _) (list (flip-variances (free-idxs* t)))] - [(cons t (? number? bnd)) - (list (fix-bound (flip-variances (free-idxs* t)) bnd))] - [#f null]) + [_ null]) (list (free-idxs* rng))))] [#:fold-rhs (*arr (map type-rec-id dom) (type-rec-id rng) @@ -215,8 +220,7 @@ ;; arities : Listof[arr] (dt Function ([arities (listof arr/c)]) [#:key 'procedure] - [#:frees (combine-frees (map free-vars* arities)) - (combine-frees (map free-idxs* arities))] + [#:frees (λ (f) (combine-frees (map f arities)))] [#:fold-rhs (*Function (map type-rec-id arities))]) @@ -230,8 +234,6 @@ (dt Struct ([name symbol?] [parent (or/c #f Struct? Name?)] [flds (listof Type/c)] - #; - [flds (listof (cons/c Type/c boolean?))] [proc (or/c #f Function?)] [poly? (or/c #f (listof symbol?))] [pred-id identifier?] @@ -239,19 +241,12 @@ [acc-ids (listof identifier?)] [maker-id identifier?]) [#:intern (list name parent flds proc)] - [#:frees (combine-frees (map free-vars* (append (if proc (list proc) null) - (if parent (list parent) null) - - flds #;(map car flds)))) - (combine-frees (map free-idxs* (append (if proc (list proc) null) - (if parent (list parent) null) - flds #;(map car flds))))] + [#:frees (λ (f) (combine-frees (map f (append (if proc (list proc) null) + (if parent (list parent) null) + flds))))] [#:fold-rhs (*Struct name (and parent (type-rec-id parent)) (map type-rec-id flds) - #; - (for/list ([(t m?) (in-pairs (in-list flds))]) - (cons (type-rec-id t) m?)) (and proc (type-rec-id proc)) poly? pred-id @@ -290,8 +285,7 @@ (and sorted? (type Type (d/c (substitute-dots images rimage name target) - ((listof Type/c) (or/c #f Type/c) symbol? Type? . -> . Type?) + ((listof Type/c) (or/c #f (cons/c Type/c symbol?)) symbol? Type? . -> . Type?) (define (sb t) (substitute-dots images rimage name t)) - (if (hash-ref (free-vars* target) name #f) + (if (or (hash-ref (free-idxs* target) name #f) (hash-ref (free-vars* target) name #f)) (type-case (#:Type sb #:Filter (sub-f sb)) target [#:ListDots dty dbound (if (eq? name dbound) @@ -95,7 +95,7 @@ (make-ValuesDots (map sb types) (sb dty) dbound))] [#:arr dom rng rest drest kws (if (and (pair? drest) - (eq? name (cdr drest))) + (eq? name (cdr drest))) (make-arr (append (map sb dom) ;; We need to recur first, just to expand out any dotted usages of this. @@ -116,7 +116,7 @@ ;; substitute-dotted : Type Name Name Type -> Type (define (substitute-dotted image image-bound name target) (define (sb t) (substitute-dotted image image-bound name t)) - (if (hash-ref (free-vars* target) name #f) + (if (hash-ref (free-idxs* target) name #f) (type-case (#:Type sb #:Filter (sub-f sb)) target [#:ValuesDots types dty dbound @@ -135,7 +135,7 @@ (sb rng) (and rest (sb rest)) (and drest - (cons (sb (car drest)) + (cons (substitute image (cdr drest) (sb (car drest))) (if (eq? name (cdr drest)) image-bound (cdr drest)))) (map sb kws))]) target)) @@ -325,4 +325,4 @@ (define to-be-abstr (make-weak-hash)) -(provide to-be-abstr) \ No newline at end of file +(provide to-be-abstr) From 9b93ec46d3710d9638948cde47a809f5c00c1e0e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 2 Jun 2010 12:46:03 -0400 Subject: [PATCH 085/198] Fix free index computation when the body refers to the bound. original commit: e8a591d2915c54fdf5b674d9859b7ebc7b13dd73 --- collects/typed-scheme/rep/type-rep.rkt | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 1b616544..4e9b861a 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -72,7 +72,7 @@ (hash-remove (free-vars* dty) dbound) (free-vars* dty)) (if (symbol? dbound) - (hash-set (free-idxs* dty) dbound Covariant) + (combine-frees (list (make-immutable-hasheq (list (cons dbound Covariant))) (free-idxs* dty))) (free-idxs* dty))] [#:fold-rhs (*ListDots (type-rec-id dty) dbound)]) @@ -171,7 +171,7 @@ (hash-remove (combine-frees (map free-vars* (cons dty rs))) dbound) (combine-frees (map free-vars* (cons dty rs)))) (if (symbol? dbound) - (hash-set (combine-frees (map free-idxs* (cons dty rs))) dbound Covariant) + (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)]) @@ -201,7 +201,8 @@ dom)) (match drest [(cons t (? symbol? bnd)) - (list (hash-set (flip-variances (free-idxs* t)) bnd Contravariant))] + (list (make-immutable-hasheq (list (cons bnd Contravariant))) + (flip-variances (free-idxs* t)))] [(cons t _) (list (flip-variances (free-idxs* t)))] [_ null]) From d26ad0e2137068f9e3ea01e27edf99cc1cee61e8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 2 Jun 2010 12:47:43 -0400 Subject: [PATCH 086/198] Change inference to take into account index vs regular vars. original commit: 99e499a503b8b319bc0e512b698e5543634e3654 --- collects/typed-scheme/infer/infer-unit.rkt | 23 +++++-------- collects/typed-scheme/infer/signatures.rkt | 38 +++++++++++++++++++--- collects/typed-scheme/typecheck/tc-app.rkt | 4 +-- collects/typed-scheme/types/utils.rkt | 5 +-- 4 files changed, 47 insertions(+), 23 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 92c35874..ad372fa7 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -3,12 +3,11 @@ (require scheme/require (except-in (path-up - "utils/utils.rkt" "utils/tc-utils.rkt" + "utils/utils.rkt" "utils/tc-utils.rkt" "types/utils.rkt" "rep/free-variance.rkt" "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/rep-utils.rkt" "types/convenience.rkt" "types/union.rkt" "types/subtype.rkt" "types/remove-intersect.rkt" "types/resolve.rkt" "env/type-name-env.rkt" "env/index-env.rkt" "env/tvar-env.rkt") make-env) - (path-up "types/utils.rkt") "constraint-structs.rkt" "signatures.rkt" scheme/match @@ -499,26 +498,28 @@ (cset-meet* (for/list ([s S] [t T]) (cgen V X s t)))) ;; X : variables to infer +;; Y : indices to infer ;; S : actual argument types ;; T : formal argument types ;; R : result type ;; must-vars : variables that must be in the substitution +;; must-idxs : index variables that must be in the substitution ;; expected : boolean ;; returns a substitution ;; if R is #f, we don't care about the substituion ;; just return a boolean result -(define (infer X S T R must-vars [expected #f]) +(define (infer X Y S T R must-vars must-idxs [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) - (let ([cs (cgen/list null X S T)]) + (let ([cs (cgen/list null X Y S T)]) (if (not expected) - (subst-gen cs R must-vars) - (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) + (subst-gen cs R (append must-vars must-idxs)) + (subst-gen (cset-meet cs (cgen null X Y R expected)) R must-vars))))) ;; like infer, but T-var is the vararg type: -(define (infer/vararg X S T T-var R must-vars [expected #f]) +(define (infer/vararg X Y S T T-var R must-vars must-idxs [expected #f]) (define new-T (if T-var (extend S T T-var) T)) (and ((length S) . >= . (length T)) - (infer X S new-T R must-vars expected))) + (infer X Y S new-T R must-vars must-idxs expected))) ;; like infer, but dotted-var is the bound on the ... ;; and T-dotted is the repeated type @@ -538,10 +539,4 @@ (subst-gen cs R must-vars) (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) -(define (infer/simple S T R) - (infer (fv/list T) S T R)) - -(define (i s t r) - (infer/simple (list s) (list t) r)) - ;(trace cgen) diff --git a/collects/typed-scheme/infer/signatures.rkt b/collects/typed-scheme/infer/signatures.rkt index 4dcf72ab..f9b80aa5 100644 --- a/collects/typed-scheme/infer/signatures.rkt +++ b/collects/typed-scheme/infer/signatures.rkt @@ -1,6 +1,7 @@ -#lang scheme/base -(require scheme/unit scheme/contract "constraint-structs.rkt" "../utils/utils.rkt") -(require (rep type-rep) (utils unit-utils)) +#lang racket/base +(require racket/unit racket/contract racket/require + "constraint-structs.rkt" + (path-up "utils/utils.rkt" "utils/unit-utils.rkt" "rep/type-rep.rkt")) (provide (all-defined-out)) (define-signature dmap^ @@ -29,13 +30,40 @@ ([cnt restrict (Type? Type? . -> . Type?)])) (define-signature infer^ - ([cnt infer (((listof symbol?) (listof Type?) (listof Type?) Type? (listof symbol?)) ((or/c #f Type?)) . ->* . any)] - [cnt infer/vararg (((listof symbol?) + ([cnt infer ((;; variables from the forall + (listof symbol?) + ;; indexes from the forall + (listof symbol?) + ;; actual argument types from call site + (listof Type?) + ;; domain + (listof Type?) + ;; range + Type? + ;; free variables + (listof symbol?) + ;; free indexes + (listof symbol?)) + ;; optional expected type + ((or/c #f Type?)) + . ->* . any)] + [cnt infer/vararg ((;; variables from the forall + (listof symbol?) + ;; indexes from the forall + (listof symbol?) + ;; actual argument types from call site (listof Type?) + ;; domain (listof Type?) + ;; rest (or/c #f Type?) + ;; range Type? + ;; free variables + (listof symbol?) + ;; free indexes (listof symbol?)) + ;; [optional] expected type ((or/c #f Type?)) . ->* . any)] [cnt infer/dots (((listof symbol?) symbol? diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index e34275b9..87fa124a 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -824,11 +824,11 @@ [else (= (length dom) (length argtys))])) ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) ;; note that we have to use argtys-t here, since argtys is a list of tc-results - (lambda (dom rng rest drest a) + (lambda (dom rng rest drest a) (if drest (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) #:expected (and expected (tc-results->values expected))) - (infer/vararg vars argtys-t dom rest rng (fv rng) + (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng (fv rng) (fi rng) (and expected (tc-results->values expected))))) t argtys expected)] ;; regular polymorphic functions without dotted rest, and without mandatory keyword args diff --git a/collects/typed-scheme/types/utils.rkt b/collects/typed-scheme/types/utils.rkt index f38b77d7..177754a0 100644 --- a/collects/typed-scheme/types/utils.rkt +++ b/collects/typed-scheme/types/utils.rkt @@ -12,7 +12,7 @@ scheme/contract (for-syntax scheme/base syntax/parse)) -(provide fv fv/list +(provide fv fv/list fi substitute substitute-dots substitute-dotted @@ -68,7 +68,7 @@ ;; implements angle bracket substitution from the formalism ;; substitute-dots : Listof[Type] Option[type] Name Type -> Type (d/c (substitute-dots images rimage name target) - ((listof Type/c) (or/c #f (cons/c Type/c symbol?)) symbol? Type? . -> . Type?) + ((listof Type/c) (or/c #f Type/c) symbol? Type? . -> . Type?) (define (sb t) (substitute-dots images rimage name t)) (if (or (hash-ref (free-idxs* target) name #f) (hash-ref (free-vars* target) name #f)) (type-case (#:Type sb #:Filter (sub-f sb)) target @@ -293,6 +293,7 @@ ;; fv : Type -> Listof[Name] (define (fv t) (hash-map (free-vars* t) (lambda (k v) k))) +(define (fi t) (for/list ([(k v) (in-hash (free-idxs* t))]) k)) ;; fv/list : Listof[Type] -> Listof[Name] (define (fv/list ts) (hash-map (combine-frees (map free-vars* ts)) (lambda (k v) k))) From fdfdd6e3b21e17d667dc161088bfb12ebdbbfbd4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 2 Jun 2010 14:21:22 -0400 Subject: [PATCH 087/198] Fix a bunch of uses of `infer' et al. original commit: 18f45c413882b9e145fffa84d41bfb5b378396fc --- collects/typed-scheme/infer/infer-unit.rkt | 9 +++--- collects/typed-scheme/infer/restrict.rkt | 2 +- collects/typed-scheme/typecheck/tc-app.rkt | 37 ++++++++++++++-------- 3 files changed, 30 insertions(+), 18 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index ad372fa7..92054adb 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -510,10 +510,11 @@ ;; just return a boolean result (define (infer X Y S T R must-vars must-idxs [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) - (let ([cs (cgen/list null X Y S T)]) - (if (not expected) - (subst-gen cs R (append must-vars must-idxs)) - (subst-gen (cset-meet cs (cgen null X Y R expected)) R must-vars))))) + (let* ([cs (cgen/list null (append X Y) S T)] + [cs* (if expected + (cset-meet cs (cgen null (append X Y) R expected)) + cs)]) + (subst-gen cs* R (append must-vars must-idxs))))) ;; like infer, but T-var is the vararg type: (define (infer/vararg X Y S T T-var R must-vars must-idxs [expected #f]) diff --git a/collects/typed-scheme/infer/restrict.rkt b/collects/typed-scheme/infer/restrict.rkt index 6e45ac59..9779332f 100644 --- a/collects/typed-scheme/infer/restrict.rkt +++ b/collects/typed-scheme/infer/restrict.rkt @@ -23,7 +23,7 @@ [(subtype t1 t2) t1] ;; already a subtype [(match t2 [(Poly: vars t) - (let ([subst (infer vars (list t1) (list t) t1 vars)]) + (let ([subst (infer vars null (list t1) (list t) t1 (fv t1) (fi t1))]) (and subst (restrict* t1 (subst-all subst t1))))] [_ #f])] [(Union? t1) (union-map (lambda (e) (restrict* e t2)) t1)] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 87fa124a..11cdf7f3 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -319,26 +319,28 @@ (not tail-bound) (<= (length (car doms*)) (length arg-tys)) - (infer/vararg vars + (infer/vararg vars null (cons tail-ty arg-tys) (cons (make-Listof (car rests*)) (car doms*)) (car rests*) (car rngs*) - (fv (car rngs*)))) + (fv (car rngs*)) + (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; actual work, when we have a * function and ... final arg [(and (car rests*) tail-bound (<= (length (car doms*)) (length arg-tys)) - (infer/vararg vars + (infer/vararg vars null (cons (make-Listof tail-ty) arg-tys) (cons (make-Listof (car rests*)) (car doms*)) (car rests*) (car rngs*) - (fv (car rngs*)))) + (fv (car rngs*)) + (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg [(and (car drests*) @@ -346,7 +348,8 @@ (eq? tail-bound (cdr (car drests*))) (= (length (car doms*)) (length arg-tys)) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) + (infer vars null (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) + (car rngs*) (fv (car rngs*)) (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] @@ -373,26 +376,26 @@ (not tail-bound) (<= (length (car doms*)) (length arg-tys)) - (infer/vararg vars + (infer/vararg fixed-vars (list dotted-var) (cons tail-ty arg-tys) (cons (make-Listof (car rests*)) (car doms*)) (car rests*) (car rngs*) - (fv (car rngs*)))) + (fv (car rngs*)) (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; actual work, when we have a * function and ... final arg [(and (car rests*) tail-bound (<= (length (car doms*)) (length arg-tys)) - (infer/vararg vars + (infer/vararg fixed-vars (list dotted-var) (cons (make-Listof tail-ty) arg-tys) (cons (make-Listof (car rests*)) (car doms*)) (car rests*) (car rngs*) - (fv (car rngs*)))) + (fv (car rngs*)) (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg, same bound on ... @@ -401,7 +404,11 @@ (eq? tail-bound (cdr (car drests*))) (= (length (car doms*)) (length arg-tys)) - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))) + (infer fixed-vars (list dotted-var) + (cons tail-ty arg-tys) + (cons (car (car drests*)) (car doms*)) + (car rngs*) + (fv (car rngs*)) (fi (car rngs*)))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg, different bound on ... @@ -413,7 +420,11 @@ (extend-tvars (list tail-bound (cdr (car drests*))) (extend-indexes (cdr (car drests*)) ;; don't need to add tail-bound - it must already be an index - (infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))))) + (infer fixed-vars (list dotted-var) + (cons tail-ty arg-tys) + (cons (car (car drests*)) (car doms*)) + (car rngs*) + (fv (car rngs*)) (fi (car rngs*)))))) => (lambda (substitution) (define drest-bound (cdr (car drests*))) (do-ret (substitute-dotted (cadr (assq drest-bound substitution)) @@ -610,7 +621,7 @@ (fail)) (match (map single-value (syntax->list #'pos-args)) [(list (tc-result1: argtys-t) ...) - (let* ([subst (infer vars argtys-t dom rng (fv rng) (and expected (tc-results->values expected)))]) + (let* ([subst (infer vars null argtys-t dom rng (fv rng) (fi rng) (and expected (tc-results->values expected)))]) (tc-keywords form (list (subst-all subst ar)) (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])] [(tc-result1: (Function: arities)) @@ -843,7 +854,7 @@ (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) ;; note that we have to use argtys-t here, since argtys is a list of tc-results - (lambda (dom rng rest a) (infer/vararg vars argtys-t dom rest rng (fv rng) (and expected (tc-results->values expected)))) + (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (fv rng) (fi rng) (and expected (tc-results->values expected)))) t argtys expected)] ;; procedural structs [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _ _))) _) From c10334cfb0695a9891428463030cfaac67c33bc5 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 2 Jun 2010 19:09:34 -0400 Subject: [PATCH 088/198] More progress on refactoring infer original commit: 82e7d281cb028e9d2e5c57a9a8c01b4d4e18275a --- .../typed-scheme/infer/constraint-structs.rkt | 23 +- collects/typed-scheme/infer/dmap.rkt | 6 +- collects/typed-scheme/infer/infer-unit.rkt | 514 +++++++++--------- collects/typed-scheme/infer/restrict.rkt | 2 +- collects/typed-scheme/infer/signatures.rkt | 12 +- collects/typed-scheme/rep/type-rep.rkt | 2 +- collects/typed-scheme/typecheck/tc-app.rkt | 28 +- 7 files changed, 286 insertions(+), 301 deletions(-) diff --git a/collects/typed-scheme/infer/constraint-structs.rkt b/collects/typed-scheme/infer/constraint-structs.rkt index ea946d98..19cb2591 100644 --- a/collects/typed-scheme/infer/constraint-structs.rkt +++ b/collects/typed-scheme/infer/constraint-structs.rkt @@ -4,22 +4,23 @@ ;; S, T types ;; X a var -(define-struct c (S X T) #:prefab) +;; represents S <: X <: T +(d-s/c c ([S Type/c] [X symbol?] [T Type/c]) #:transparent) ;; fixed : Listof[c] ;; rest : option[c] -(define-struct dcon (fixed rest) #:prefab) +(d-s/c dcon ([fixed (listof c?)] [rest (or/c c? #f)]) #:transparent) ;; fixed : Listof[c] ;; rest : c -(define-struct dcon-exact (fixed rest) #:prefab) +(d-s/c dcon-exact ([fixed (listof c?)] [rest c?]) #:transparent) ;; type : c ;; bound : var -(define-struct dcon-dotted (type bound) #:prefab) +(d-s/c dcon-dotted ([type c?] [bound symbol?]) #:transparent) ;; map : hash mapping variable to dcon or dcon-dotted -(define-struct dmap (map) #:prefab) +(d-s/c dmap ([map (hash/c symbol? (or/c dcon? dcon-exact? dcon-dotted?))]) #:transparent) ;; maps is a list of pairs of ;; - functional maps from vars to c's @@ -27,17 +28,13 @@ ;; we need a bunch of mappings for each cset to handle case-lambda ;; because case-lambda can generate multiple possible solutions, and we ;; don't want to rule them out too early -(define-struct cset (maps) #:prefab) +(d-s/c cset ([maps (listof (cons/c (hash/c symbol? c?) dmap?))]) #:transparent) (define-match-expander c: (lambda (stx) (syntax-parse stx [(_ s x t) - #'(struct c ((app (lambda (v) (if (Type? v) v (Un))) s) x (app (lambda (v) (if (Type? v) v Univ)) t)))]))) + #'(struct c (s x t))]))) -(p/c (struct c ([S (or/c boolean? Type?)] [X symbol?] [T (or/c boolean? Type?)])) - (struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)])) - (struct dcon-exact ([fixed (listof c?)] [rest c?])) - (struct dcon-dotted ([type c?] [bound symbol?])) - (struct dmap ([map (hash/c symbol? (or/c dcon? dcon-exact? dcon-dotted?))])) - (struct cset ([maps (listof (cons/c (hash/c symbol? c?) dmap?))]))) +(provide (struct-out cset) (struct-out dmap) (struct-out dcon) (struct-out dcon-dotted) (struct-out dcon-exact) (struct-out c) + c:) diff --git a/collects/typed-scheme/infer/dmap.rkt b/collects/typed-scheme/infer/dmap.rkt index 7e2e3b39..7f88f291 100644 --- a/collects/typed-scheme/infer/dmap.rkt +++ b/collects/typed-scheme/infer/dmap.rkt @@ -2,14 +2,15 @@ (require "../utils/utils.rkt" "signatures.rkt" "constraint-structs.rkt" - (utils tc-utils) + (utils tc-utils) racket/contract unstable/sequence unstable/hash scheme/match) (import constraints^) (export dmap^) ;; dcon-meet : dcon dcon -> dcon -(define (dcon-meet dc1 dc2) +(d/c (dcon-meet dc1 dc2) + (dcon? dcon? . -> . dcon?) (match* (dc1 dc2) [((struct dcon-exact (fixed1 rest1)) (or (struct dcon (fixed2 rest2)) (struct dcon-exact (fixed2 rest2)))) @@ -20,6 +21,7 @@ [c2 fixed2]) (c-meet c1 c2 (c-X c1))) (c-meet rest1 rest2 (c-X rest1)))] + ;; redo in the other order to call the first case [((struct dcon (fixed1 rest1)) (struct dcon-exact (fixed2 rest2))) (dcon-meet dc2 dc1)] [((struct dcon (fixed1 #f)) (struct dcon (fixed2 #f))) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 92054adb..ae882641 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -7,12 +7,12 @@ "rep/free-variance.rkt" "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/rep-utils.rkt" "types/convenience.rkt" "types/union.rkt" "types/subtype.rkt" "types/remove-intersect.rkt" "types/resolve.rkt" "env/type-name-env.rkt" "env/index-env.rkt" "env/tvar-env.rkt") - make-env) + make-env -> ->* one-of/c) "constraint-structs.rkt" "signatures.rkt" scheme/match mzlib/etc - mzlib/trace + mzlib/trace racket/contract unstable/sequence unstable/list unstable/debug scheme/list) @@ -68,275 +68,253 @@ (define (move-vars-to-dmap cset dbound vars) (mover cset dbound vars - (lambda (cmap) + (λ (cmap) (make-dcon (for/list ([v vars]) (hash-ref cmap v - (lambda () (int-err "No constraint for new var ~a" v)))) + (λ () (int-err "No constraint for new var ~a" v)))) #f)))) (define (move-rest-to-dmap cset dbound #:exact [exact? #f]) (mover cset dbound (list dbound) - (lambda (cmap) + (λ (cmap) ((if exact? make-dcon-exact make-dcon) null (hash-ref cmap dbound - (lambda () (int-err "No constraint for bound ~a" dbound))))))) + (λ () (int-err "No constraint for bound ~a" dbound))))))) (define (move-vars+rest-to-dmap cset dbound vars #:exact [exact? #f]) - (map/cset - (lambda (cmap dmap) - (cons (hash-remove* cmap vars) - (dmap-meet - (singleton-dmap - dbound - ((if exact? make-dcon-exact make-dcon) - (for/list ([v vars]) - (hash-ref cmap v - (lambda () (int-err "No constraint for new var ~a" v)))) - (hash-ref cmap dbound - (lambda () (int-err "No constraint for bound ~a" dbound))))) - dmap))) - cset)) + (mover cset dbound vars + (λ (cmap) + ((if exact? make-dcon-exact make-dcon) + (for/list ([v vars]) + (hash-ref cmap v (λ () (int-err "No constraint for new var ~a" v)))) + (hash-ref cmap dbound + (λ () (int-err "No constraint for bound ~a" dbound))))))) -;; t and s must be *latent* filters -(define (cgen/filter V X t s) - (match* (t s) +;; s and t must be *latent* filters +(define (cgen/filter V X s t) + (match* (s t) [(e e) (empty-cset X)] [(e (Top:)) (empty-cset X)] ;; FIXME - is there something to be said about the logical ones? - [((TypeFilter: t p i) (TypeFilter: s p i)) (cset-meet (cgen V X t s) (cgen V X s t))] - [((NotTypeFilter: t p i) (NotTypeFilter: s p i)) (cset-meet (cgen V X t s) (cgen V X s t))] - [(_ _) (fail! t s)])) + [((TypeFilter: s p i) (TypeFilter: t p i)) (cset-meet (cgen V X s t) (cgen V X t s))] + [((NotTypeFilter: s p i) (NotTypeFilter: t p i)) (cset-meet (cgen V X s t) (cgen V X t s))] + [(_ _) (fail! s t)])) -#; -(define (cgen/filters V X ts ss) - (cond - [(null? ss) (empty-cset X)] - ;; FIXME - this can be less conservative - [(= (length ts) (length ss)) - (cset-meet* (for/list ([t ts] [s ss]) (cgen/filter V X t s)))] - [else (fail! ts ss)])) - - -;; t and s must be *latent* filter sets -(define (cgen/filter-set V X t s) - (match* (t s) +;; s and t must be *latent* filter sets +(define (cgen/filter-set V X s t) + (match* (s t) [(e e) (empty-cset X)] - [((FilterSet: t+ t-) (FilterSet: s+ s-)) - (cset-meet (cgen/filter V X t+ s+) (cgen/filter V X t- s-))] - [(_ _) (fail! t s)])) + [((FilterSet: s+ s-) (FilterSet: t+ t-)) + (cset-meet (cgen/filter V X s+ t+) (cgen/filter V X s- t-))] + [(_ _) (fail! s t)])) -(define (cgen/object V X t s) - (match* (t s) +(define (cgen/object V X s t) + (match* (s t) [(e e) (empty-cset X)] [(e (Empty:)) (empty-cset X)] ;; FIXME - do something here - [(_ _) (fail! t s)])) + [(_ _) (fail! s t)])) -(define (cgen/arr V X t-arr s-arr) +(define (cgen/arr V X s-arr t-arr) (define (cg S T) (cgen V X S T)) - (match* (t-arr s-arr) - [((arr: ts t #f #f '()) - (arr: ss s #f #f '())) - (cset-meet* - (list (cgen/list V X ss ts) - (cg t s)))] - [((arr: ts t t-rest #f '()) - (arr: ss s s-rest #f '())) + (match* (s-arr t-arr) + ;; the simplest case - no rests, drests, keywords + [((arr: ss s #f #f '()) + (arr: ts t #f #f '())) + (cset-meet* (list + ;; contravariant + (cgen/list V X ts ss) + ;; covariant + (cg s t)))] + ;; just a rest arg, no drest, no keywords + [((arr: ss s s-rest #f '()) + (arr: ts t t-rest #f '())) (let ([arg-mapping - (cond [(and t-rest s-rest (<= (length ts) (length ss))) - (cgen/list V X (cons s-rest ss) (cons t-rest (extend ss ts t-rest)))] - [(and t-rest s-rest (>= (length ts) (length ss))) - (cgen/list V X (cons s-rest (extend ts ss s-rest)) (cons t-rest ts))] - [(and t-rest (not s-rest) (<= (length ts) (length ss))) - (cgen/list V X ss (extend ss ts t-rest))] - [(and s-rest (not t-rest) (>= (length ts) (length ss))) - (cgen/list V X (extend ts ss s-rest) ts)] - [else (fail! S T)])] - [ret-mapping (cg t s)]) - (cset-meet* - (list arg-mapping ret-mapping)))] - [((arr: ts t #f (cons dty dbound) '()) - (arr: ss s #f #f '())) - (unless (memq dbound X) - (fail! S T)) - (unless (<= (length ts) (length ss)) - (fail! S T)) - (let* ([num-vars (- (length ss) (length ts))] - [vars (for/list ([n (in-range num-vars)]) - (gensym dbound))] - [new-tys (for/list ([var vars]) - (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null) s-arr)]) - (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f #f '()) - (arr: ss s #f (cons dty dbound) '())) + (cond + ;; both rest args are present, so make them the same length + [(and s-rest t-rest) + (cgen/list V X (cons t-rest (extend ss ts t-rest)) (cons s-rest (extend ts ss s-rest)))] + ;; no rest arg on the right, so just pad the left and forget the rest arg + [(and s-rest (not t-rest) (<= (length ss) (length ts))) + (cgen/list V X ts (extend ts ss s-rest))] + ;; no rest arg on the left, or wrong number = fail + [else (fail! S T)])] + [ret-mapping (cg s t)]) + (cset-meet* (list arg-mapping ret-mapping)))] + ;; dotted on the left, nothing on the right + [((arr: ss s #f (cons dty dbound) '()) + (arr: ts t #f #f '())) (unless (memq dbound X) (fail! S T)) (unless (<= (length ss) (length ts)) (fail! S T)) - (let* ([num-vars (- (length ts) (length ss))] - [vars (for/list ([n (in-range num-vars)]) + (let* ([vars (for/list ([n (in-range (- (length ts) (length ss)))]) + (gensym dbound))] + [new-tys (for/list ([var vars]) + (substitute (make-F var) dbound dty))] + [new-s-arr (make-arr (append ss new-tys) s #f #f null)] + [new-cset (cgen/arr V (append vars X) new-s-arr t-arr)]) + (move-vars-to-dmap new-cset dbound vars))] + ;; dotted on the right, nothing on the left + [((arr: ss s #f #f '()) + (arr: ts t #f (cons dty dbound) '())) + (unless (memq dbound X) + (fail! S T)) + (unless (<= (length ts) (length ss)) + (fail! S T)) + (let* ([vars (for/list ([n (in-range (- (length ss) (length ts)))]) (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null))]) + [new-t-arr (make-arr (append ts new-tys) t #f #f null)] + [new-cset (cgen/arr V (append vars X) s-arr new-t-arr)]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f (cons t-dty dbound) '()) - (arr: ss s #f (cons s-dty dbound) '())) - (unless (= (length ts) (length ss)) + ;; this case is just for constrainting other variables, not dbound + [((arr: ss s #f (cons s-dty dbound) '()) + (arr: ts t #f (cons t-dty dbound) '())) + (unless (= (length ss) (length ts)) (fail! S T)) ;; If we want to infer the dotted bound, then why is it in both types? (when (memq dbound X) (fail! S T)) - (let* ([arg-mapping (cgen/list V X ss ts)] - [darg-mapping (cgen V X s-dty t-dty)] - [ret-mapping (cg t s)]) + (let* ([arg-mapping (cgen/list V X ts ss)] + [darg-mapping (cgen V X t-dty s-dty)] + [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))] - [((arr: ts t #f (cons t-dty dbound) '()) - (arr: ss s #f (cons s-dty dbound*) '())) - (unless (= (length ts) (length ss)) + ;; bounds are different + [((arr: ss s #f (cons s-dty dbound) '()) + (arr: ts t #f (cons t-dty dbound*) '())) + (unless (= (length ss) (length ts)) (fail! S T)) - (let* ([arg-mapping (cgen/list V X ss ts)] - [darg-mapping (cgen V (cons dbound* X) s-dty t-dty)] - [ret-mapping (cg t s)]) + (let* ([arg-mapping (cgen/list V X ts ss)] + ;; just add dbound as something that can be constrained + [darg-mapping (cgen V (cons dbound X) t-dty s-dty)] + [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))] - [((arr: ts t t-rest #f '()) - (arr: ss s #f (cons s-dty dbound) '())) + [((arr: ss s s-rest #f '()) + (arr: ts t #f (cons t-dty dbound) '())) (unless (memq dbound X) (fail! S T)) - (if (<= (length ts) (length ss)) + (if (<= (length ss) (length ts)) ;; the simple case - (let* ([arg-mapping (cgen/list V X ss (extend ss ts t-rest))] - [darg-mapping (move-rest-to-dmap (cgen V X s-dty t-rest) dbound)] - [ret-mapping (cg t s)]) + (let* ([arg-mapping (cgen/list V X ts (extend ts ss s-rest))] + [darg-mapping (move-rest-to-dmap (cgen V X t-dty s-rest) dbound)] + [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping))) ;; the hard case - (let* ([num-vars (- (length ts) (length ss))] - [vars (for/list ([n (in-range num-vars)]) + (let* ([vars (for/list ([n (in-range (- (length ss) (length ts)))]) (gensym dbound))] [new-tys (for/list ([var vars]) - (substitute (make-F var) dbound s-dty))] - [new-cset (cgen/arr V (append vars X) t-arr - (make-arr (append ss new-tys) s #f (cons s-dty dbound) null))]) + (substitute (make-F var) dbound t-dty))] + [new-t-arr (make-arr (append ts new-tys) t #f (cons t-dty dbound) null)] + [new-cset (cgen/arr V (append vars X) s-arr new-t-arr)]) (move-vars+rest-to-dmap new-cset dbound vars)))] ;; If dotted <: starred is correct, add it below. Not sure it is. - [((arr: ts t #f (cons t-dty dbound) '()) - (arr: ss s s-rest #f '())) + [((arr: ss s #f (cons s-dty dbound) '()) + (arr: ts t t-rest #f '())) (unless (memq dbound X) (fail! S T)) - (cond [(< (length ts) (length ss)) + (cond [(< (length ss) (length ts)) ;; the hard case - (let* ([num-vars (- (length ss) (length ts))] - [vars (for/list ([n (in-range num-vars)]) + (let* ([vars (for/list ([n (in-range (- (length ts) (length ss)))]) (gensym dbound))] [new-tys (for/list ([var vars]) - (substitute (make-F var) dbound t-dty))] - [arg-mapping (cgen/list V (append vars X) ss (append ts new-tys))] - [darg-mapping (cgen V X s-rest t-dty)] - [ret-mapping (cg t s)] - [new-cset - (cset-meet* (list arg-mapping darg-mapping ret-mapping))]) + (substitute (make-F var) dbound s-dty))] + [new-s-arr (make-arr (append ss new-tys) s #f (cons s-dty dbound) null)] + [new-cset (cgen/arr V (append vars X) new-s-arr t-arr)]) (move-vars+rest-to-dmap new-cset dbound vars #:exact #t))] [else ;; the simple case - (let* ([arg-mapping (cgen/list V X (extend ts ss s-rest) ts)] - [darg-mapping (move-rest-to-dmap (cgen V X s-rest t-dty) dbound #:exact #t)] - [ret-mapping (cg t s)]) + (let* ([arg-mapping (cgen/list V X (extend ss ts t-rest) ss)] + [darg-mapping (move-rest-to-dmap (cgen V X t-rest s-dty) dbound #:exact #t)] + [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))])] [(_ _) (fail! S T)])) -;; determine constraints on the variables in X that would make S a subtype of T -;; the resulting constraints will not mention V -(define (cgen V X S T) +;; V : a set of variables not to mention in the constraints +;; X : the set of variables to be constrained +;; S : a type to be the subtype of T +;; T : a type +;; produces a cset which determines a substitution that makes S a subtype of T +;; implements the V |-_X S <: T => C judgment from Pierce+Turner +(d/c (cgen V X S T) + ((listof symbol?) (listof symbol?) Type? Type? . -> . cset?) + ;; useful quick loop (define (cg S T) (cgen V X S T)) + ;; this places no constraints on any variables in X (define empty (empty-cset X)) - (define (singleton S X T) - (insert empty X S T)) + ;; this constrains just x (which is a single var) + (define (singleton S x T) + (insert empty x S T)) + ;; if we've been around this loop before, we're done (for rec types) (if (seen? S T) empty (parameterize ([match-equality-test (lambda (a b) (if (and (Rep? a) (Rep? b)) (type-equal? a b) (equal? a b)))] + ;; remember S and T, and obtain everything we've seen from the context + ;; we can't make this an argument since we may call back and forth with subtyping, for example [current-seen (remember S T (current-seen))]) - (match* - (S T) + (match* (S T) + ;; if they're equal, no constraints are necessary (CG-Refl) [(a a) empty] + ;; CG-Top [(_ (Univ:)) empty] + ;; refinements are erased to their bound [((Refinement: S _ _) T) (cg S T)] - [((F: (? (lambda (e) (memq e X)) v)) S) - (when (match S - [(F: v*) - (and (bound-index? v*) (not (bound-tvar? v*)))] - [_ #f]) - (fail! S T)) - (singleton (Un) v (var-demote S V))] + ;; variables that are in X and should be constrained + ;; all other variables are compatible only with themselves + [((F: (? (λ (e) (memq e X)) v)) T) + (match T + ;; only possible when v* is an index + [(F: v*) (when (and (bound-index? v*) (not (bound-tvar? v*))) + (fail! S T))] + [_ (void)]) + ;; constrain v to be below T (but don't mention V) + (singleton (Un) v (var-demote T V))] [(S (F: (? (lambda (e) (memq e X)) v))) - (when (match S - [(F: v*) - (and (bound-index? v*) (not (bound-tvar? v*)))] - [_ #f]) - (fail! S T)) + (match S + [(F: v*) (when (and (bound-index? v*) (not (bound-tvar? v*))) + (fail! S T))] + [_ (void)]) + ;; constrain v to be above S (but don't mention V) (singleton (var-promote S V) v Univ)] - - ;; two unions with the same number of elements, so we just try to unify them pairwise - #;[((Union: l1) (Union: l2)) - (=> unmatch) - (unless (= (length l1) (length l2)) - (unmatch)) - (cgen-union V X l1 l2)] - #;[((Poly: v1 b1) (Poly: v2 b2)) - (unless (= (length v1) (length v2)) - (fail! S T)) - (let ([b2* (subst-all (map list v2 v1) b2)]) - (cg b1 b2*))] + ;; constrain b1 to be below T, but don't mention the new vars + [((Poly: v1 b1) T) (cgen (append v1 V) X b1 T)] - #;[((PolyDots: (list v1 ... r1) b1) (PolyDots: (list v2 ... r2) b2)) - (unless (= (length v1) (length v2)) - (fail! S T)) - (let ([b2* (substitute-dotted v1 v1 v2 (subst-all (map list v2 v1) b2))]) - (cg b1 b2*))] + ;; constrain *each* element of es to be below T, and then combine the constraints + [((Union: es) T) (cset-meet* (cons empty (for/list ([e es]) (cg e T))))] - [((Poly: v1 b1) T) - (cgen (append v1 V) X b1 T)] - - #;[((PolyDots: (list v1 ... r1) b1) T) - (let ([b1* (var-demote b1 (cons r1 v1))]) - (cg b1* T))] - - #; - [((Poly-unsafe: n b) (Poly-unsafe: n* b*)) - (unless (= n n*) - (fail! S T)) - (cg b b*)] - - - [((Union: es) S) (cset-meet* (cons empty (for/list ([e es]) (cg e S))))] - ;; we might want to use multiple csets here, but I don't think it makes a difference - [(S (Union: es)) (or - (for/or - ([e es]) - (with-handlers - ([exn:infer? (lambda _ #f)]) - (cg S e))) - (fail! S T))] + ;; find *an* element of es which can be made to be a supertype of S + ;; FIXME: we're using multiple csets here, but I don't think it makes a difference + ;; not using multiple csets will break for: ??? + [(S (Union: es)) + (cset-combine + (filter values + (for/list ([e es]) + (with-handlers ([exn:infer? (λ _ #f)]) (cg S e)))))] + ;; two structs with the same name and parent + ;; just check pairwise on the fields + ;; FIXME - wrong for mutable structs! [((Struct: nm p flds proc _ _ _ _ _) (Struct: nm p flds* proc* _ _ _ _ _)) (let-values ([(flds flds*) (cond [(and proc proc*) (values (cons proc flds) (cons proc* flds*))] - [(or proc proc*) - (fail! S T)] [else (values flds flds*)])]) (cgen/list V X flds flds*))] + + ;; two struct names, need to resolve b/c one could be a parent [((Name: n) (Name: n*)) (if (free-identifier=? n n*) null - (fail! S T))] + (cg (resolve-once S) (resolve-once T)))] + ;; pairs are pointwise [((Pair: a b) (Pair: a* b*)) (cset-meet (cg a a*) (cg b b*))] ;; sequences are covariant @@ -362,108 +340,126 @@ (cg t t*)] [((Hashtable: k v) (Sequence: (list k* v*))) (cgen/list V X (list k v) (list k* v*))] + ;; ListDots can be below a Listof ;; must be above mu unfolding [((ListDots: s-dty dbound) (Listof: t-elem)) (when (memq dbound X) (fail! S T)) (cgen V X (substitute Univ dbound s-dty) t-elem)] + ;; two ListDots with the same bound, just check the element type [((ListDots: s-dty dbound) (ListDots: t-dty dbound)) (when (memq dbound X) (fail! S T)) - (cgen V X s-dty t-dty)] + (cgen V X s-dty t-dty)] + + ;; this constrains `dbound' to be |ts| - |ss| + [((ListDots: s-dty dbound) (List: ts)) + (unless (memq dbound X) (fail! S T)) + + (let* ([vars (for/list ([n (in-range (length ts))]) + (gensym dbound))] + ;; new-tys are dummy plain type variables, standing in for the elements of dbound that need to be generated + [new-tys (for/list ([var vars]) + (substitute (make-F var) dbound s-dty))] + ;; generate constraints on the prefixes, and on the dummy types + [new-cset (cgen/list V (append vars X) new-tys ts)]) + ;; now take all the dummy types, and use them to constrain dbound appropriately + (move-vars-to-dmap new-cset dbound vars))] + ;; if we have two mu's, we rename them to have the same variable ;; and then compare the bodies + ;; This relies on (B 0) only unifying with itself, and thus only hitting the first case of this `match' [((Mu-unsafe: s) (Mu-unsafe: t)) (cg s t)] + ;; other mu's just get unfolded [(s (? Mu? t)) (cg s (unfold t))] [((? Mu? s) t) (cg (unfold s) t)] - ;; type application - [((App: (Name: n) args _) - (App: (Name: n*) args* _)) - (unless (free-identifier=? n n*) - (fail! S T)) - (cg (resolve-once S) (resolve-once T))] + + ;; resolve applications [((App: _ _ _) _) (cg (resolve-once S) T)] [(_ (App: _ _ _)) (cg S (resolve-once T))] + + ;; values are covariant [((Values: ss) (Values: ts)) (unless (= (length ss) (length ts)) (fail! ss ts)) (cgen/list V X ss ts)] - [((Values: ss) (ValuesDots: ts t-dty dbound)) - (unless (>= (length ss) (length ts)) - (fail! ss ts)) - (unless (memq dbound X) - (fail! S T)) - (let* ([num-vars (- (length ss) (length ts))] - [vars (for/list ([n (in-range num-vars)]) - (gensym dbound))] - [new-tys (for/list ([var vars]) - (substitute (make-F var) dbound t-dty))] - [new-cset (cgen/list V (append vars X) ss (append ts new-tys))]) - (move-vars-to-dmap new-cset dbound vars))] + + ;; this constrains `dbound' to be |ts| - |ss| [((ValuesDots: ss s-dty dbound) (Values: ts)) - (unless (>= (length ts) (length ss)) - (fail! ss ts)) - (unless (memq dbound X) - (fail! S T)) - (let* ([num-vars (- (length ts) (length ss))] - [vars (for/list ([n (in-range num-vars)]) + (unless (>= (length ts) (length ss)) (fail! ss ts)) + (unless (memq dbound X) (fail! S T)) + + (let* ([vars (for/list ([n (in-range (- (length ts) (length ss)))]) (gensym dbound))] + ;; new-tys are dummy plain type variables, standing in for the elements of dbound that need to be generated [new-tys (for/list ([var vars]) (substitute (make-F var) dbound s-dty))] + ;; generate constraints on the prefixes, and on the dummy types [new-cset (cgen/list V (append vars X) (append ss new-tys) ts)]) + ;; now take all the dummy types, and use them to constrain dbound appropriately (move-vars-to-dmap new-cset dbound vars))] + + ;; identical bounds - just unify pairwise [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound)) (when (memq dbound X) (fail! ss ts)) (cgen/list V X (cons s-dty ss) (cons t-dty ts))] + ;; vectors are invariant - generate constraints *both* ways [((Vector: e) (Vector: e*)) (cset-meet (cg e e*) (cg e* e))] + ;; boxes are invariant - generate constraints *both* ways [((Box: e) (Box: e*)) (cset-meet (cg e e*) (cg e* e))] [((MPair: s t) (MPair: s* t*)) (cset-meet* (list (cg s s*) (cg s* s) (cg t t*) (cg t* t)))] [((Channel: e) (Channel: e*)) (cset-meet (cg e e*) (cg e* e))] + ;; we assume all HTs are mutable at the moment [((Hashtable: s1 s2) (Hashtable: t1 t2)) ;; for mutable hash tables, both are invariant (cset-meet* (list (cg t1 s1) (cg s1 t1) (cg t2 s2) (cg s2 t2)))] + ;; syntax is covariant [((Syntax: s1) (Syntax: 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))] + ;; every function is trivially below top-arr [((Function: _) (Function: (list (top-arr:)))) empty] - [((Function: (list t-arr ...)) - (Function: (list s-arr ...))) - (=> unmatch) - (cset-combine - (filter - values ;; only generate the successful csets - (for*/list - ([t-arr t-arr] [s-arr s-arr]) - (with-handlers ([exn:infer? (lambda (_) #f)]) - (cgen/arr V X t-arr s-arr)))))] - ;; this is overly conservative + [((Function: (list s-arr ...)) + (Function: (list t-arr ...))) + (cset-meet* + (for/list ([t-arr t-arr]) + ;; for each element of t-arr, we need to get at least one element of s-arr that works + (let ([results (filter values + (for/list ([s-arr s-arr]) + (with-handlers ([exn:infer? (lambda (_) #f)]) + (cgen/arr V X s-arr t-arr))))]) + ;; ensure that something produces a constraint set + (when (null? results) (fail! S T)) + (cset-combine results))))] + ;; check each element [((Result: s f-s o-s) (Result: t f-t o-t)) (cset-meet* (list (cg s t) (cgen/filter-set V X f-s f-t) (cgen/object V X o-s o-t)))] [(_ _) - (cond [(subtype S T) empty] - ;; or, nothing worked, and we fail - [else (fail! S T)])])))) + (cond + ;; subtypes are easy - should this go earlier? + [(subtype S T) empty] + ;; or, nothing worked, and we fail + [else (fail! S T)])])))) -(define (check-vars must-vars subst) - (and (for/and ([v must-vars]) - (assq v subst)) - subst)) - -(define (subst-gen C R must-vars) +(d/c (subst-gen C R) + (cset? Type? . -> . (or/c #f list?)) + ;; fixme - should handle these separately + (define must-vars (append (fv R) (fi R))) (define (constraint->type v #:variable [variable #f]) (match v [(struct c (S X T)) + ;; fixme - handle free indexes, remove Dotted (let ([var (hash-ref (free-vars* R) (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) (evcase var @@ -471,28 +467,36 @@ [Covariant S] [Contravariant T] [Invariant S] - [Dotted T]))])) + [Dotted T]))])) (match (car (cset-maps C)) - [(cons cmap (struct dmap (dm))) - (check-vars - must-vars - (append - (for/list ([(k dc) (in-hash dm)]) - (match dc - [(struct dcon (fixed rest)) - (list k - (for/list ([f fixed]) - (constraint->type f #:variable k)) - (and rest (constraint->type rest)))] - [(struct dcon-exact (fixed rest)) - (list k - (for/list ([f fixed]) - (constraint->type f #:variable k)) - (constraint->type rest))])) - (for/list ([(k v) (in-hash cmap)]) - (list k (constraint->type v)))))])) + [(cons cmap (dmap dm)) + (let ([subst (append + (for/list ([(k dc) (in-hash dm)]) + (match dc + [(dcon fixed rest) + (list k + (for/list ([f fixed]) + (constraint->type f #:variable k)) + (and rest (constraint->type rest)))] + [(dcon-exact fixed rest) + (list k + (for/list ([f fixed]) + (constraint->type f #:variable k)) + (constraint->type rest))])) + (for/list ([(k v) (in-hash cmap)]) + (list k (constraint->type v))))]) + ;; verify that we got all the important variables + (and (for/and ([v must-vars]) + (assq v subst)) + subst))])) -(define (cgen/list V X S T) +;; V : a set of variables not to mention in the constraints +;; X : the set of variables to be constrained +;; S : a list of types to be the subtypes of T +;; T : a list of types +;; produces a cset which determines a substitution that makes the Ss subtypes of the Ts +(d/c (cgen/list V X S T) + ((listof symbol?) (listof symbol?) (listof Type?) (listof Type?) . -> . cset?) (unless (= (length S) (length T)) (fail! S T)) (cset-meet* (for/list ([s S] [t T]) (cgen V X s t)))) @@ -502,25 +506,23 @@ ;; S : actual argument types ;; T : formal argument types ;; R : result type -;; must-vars : variables that must be in the substitution -;; must-idxs : index variables that must be in the substitution ;; expected : boolean ;; returns a substitution ;; if R is #f, we don't care about the substituion ;; just return a boolean result -(define (infer X Y S T R must-vars must-idxs [expected #f]) +(define (infer X Y S T R [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) (let* ([cs (cgen/list null (append X Y) S T)] [cs* (if expected (cset-meet cs (cgen null (append X Y) R expected)) cs)]) - (subst-gen cs* R (append must-vars must-idxs))))) + (if R (subst-gen cs* R) #t)))) ;; like infer, but T-var is the vararg type: -(define (infer/vararg X Y S T T-var R must-vars must-idxs [expected #f]) +(define (infer/vararg X Y S T T-var R [expected #f]) (define new-T (if T-var (extend S T T-var) T)) (and ((length S) . >= . (length T)) - (infer X Y S new-T R must-vars must-idxs expected))) + (infer X Y S new-T R expected))) ;; like infer, but dotted-var is the bound on the ... ;; and T-dotted is the repeated type @@ -537,7 +539,7 @@ [cs-dotted* (move-vars-to-dmap cs-dotted dotted-var new-vars)] [cs (cset-meet cs-short cs-dotted*)]) (if (not expected) - (subst-gen cs R must-vars) - (subst-gen (cset-meet cs (cgen null X R expected)) R must-vars))))) + (subst-gen cs R) + (subst-gen (cset-meet cs (cgen null X R expected)) R))))) ;(trace cgen) diff --git a/collects/typed-scheme/infer/restrict.rkt b/collects/typed-scheme/infer/restrict.rkt index 9779332f..b0825050 100644 --- a/collects/typed-scheme/infer/restrict.rkt +++ b/collects/typed-scheme/infer/restrict.rkt @@ -23,7 +23,7 @@ [(subtype t1 t2) t1] ;; already a subtype [(match t2 [(Poly: vars t) - (let ([subst (infer vars null (list t1) (list t) t1 (fv t1) (fi t1))]) + (let ([subst (infer vars null (list t1) (list t) t1)]) (and subst (restrict* t1 (subst-all subst t1))))] [_ #f])] [(Union? t1) (union-map (lambda (e) (restrict* e t2)) t1)] diff --git a/collects/typed-scheme/infer/signatures.rkt b/collects/typed-scheme/infer/signatures.rkt index f9b80aa5..fb545701 100644 --- a/collects/typed-scheme/infer/signatures.rkt +++ b/collects/typed-scheme/infer/signatures.rkt @@ -39,11 +39,7 @@ ;; domain (listof Type?) ;; range - Type? - ;; free variables - (listof symbol?) - ;; free indexes - (listof symbol?)) + (or/c #f Type?)) ;; optional expected type ((or/c #f Type?)) . ->* . any)] @@ -58,11 +54,7 @@ ;; rest (or/c #f Type?) ;; range - Type? - ;; free variables - (listof symbol?) - ;; free indexes - (listof symbol?)) + (or/c #f Type?)) ;; [optional] expected type ((or/c #f Type?)) . ->* . any)] [cnt infer/dots (((listof symbol?) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 4e9b861a..bc3ff7ec 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -227,7 +227,7 @@ ;; name : symbol ;; parent : Struct -;; flds : Listof[Cons[Type,Bool]] type and mutability +;; flds : Listof[Type] ;; proc : Function Type ;; poly? : is this a polymorphic type? ;; pred-id : identifier for the predicate of the struct diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 11cdf7f3..b8887930 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -324,9 +324,7 @@ (cons (make-Listof (car rests*)) (car doms*)) (car rests*) - (car rngs*) - (fv (car rngs*)) - (fi (car rngs*)))) + (car rngs*))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; actual work, when we have a * function and ... final arg [(and (car rests*) @@ -338,9 +336,7 @@ (cons (make-Listof (car rests*)) (car doms*)) (car rests*) - (car rngs*) - (fv (car rngs*)) - (fi (car rngs*)))) + (car rngs*))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg [(and (car drests*) @@ -349,7 +345,7 @@ (= (length (car doms*)) (length arg-tys)) (infer vars null (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) - (car rngs*) (fv (car rngs*)) (fi (car rngs*)))) + (car rngs*))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] @@ -381,8 +377,7 @@ (cons (make-Listof (car rests*)) (car doms*)) (car rests*) - (car rngs*) - (fv (car rngs*)) (fi (car rngs*)))) + (car rngs*))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; actual work, when we have a * function and ... final arg [(and (car rests*) @@ -394,8 +389,7 @@ (cons (make-Listof (car rests*)) (car doms*)) (car rests*) - (car rngs*) - (fv (car rngs*)) (fi (car rngs*)))) + (car rngs*))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg, same bound on ... @@ -407,8 +401,7 @@ (infer fixed-vars (list dotted-var) (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) - (car rngs*) - (fv (car rngs*)) (fi (car rngs*)))) + (car rngs*))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, ... arg, different bound on ... @@ -423,8 +416,7 @@ (infer fixed-vars (list dotted-var) (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) - (car rngs*) - (fv (car rngs*)) (fi (car rngs*)))))) + (car rngs*))))) => (lambda (substitution) (define drest-bound (cdr (car drests*))) (do-ret (substitute-dotted (cadr (assq drest-bound substitution)) @@ -621,7 +613,7 @@ (fail)) (match (map single-value (syntax->list #'pos-args)) [(list (tc-result1: argtys-t) ...) - (let* ([subst (infer vars null argtys-t dom rng (fv rng) (fi rng) (and expected (tc-results->values expected)))]) + (let* ([subst (infer vars null argtys-t dom rng (and expected (tc-results->values expected)))]) (tc-keywords form (list (subst-all subst ar)) (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected))])] [(tc-result1: (Function: arities)) @@ -839,7 +831,7 @@ (if drest (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) #:expected (and expected (tc-results->values expected))) - (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng (fv rng) (fi rng) + (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng (and expected (tc-results->values expected))))) t argtys expected)] ;; regular polymorphic functions without dotted rest, and without mandatory keyword args @@ -854,7 +846,7 @@ (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) ;; note that we have to use argtys-t here, since argtys is a list of tc-results - (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (fv rng) (fi rng) (and expected (tc-results->values expected)))) + (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) t argtys expected)] ;; procedural structs [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _ _))) _) From c2b7caa66d7e31c4ee2b7a2dba45983cb9617ec6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 3 Jun 2010 17:30:23 -0400 Subject: [PATCH 089/198] The inference engine doesn't need this annotation anymore. original commit: e235c837b0d20538ca4c0fc024c18ddb30ac2ae4 --- collects/tests/typed-scheme/succeed/priority-queue.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/succeed/priority-queue.scm b/collects/tests/typed-scheme/succeed/priority-queue.scm index e2d7e57c..091a284d 100644 --- a/collects/tests/typed-scheme/succeed/priority-queue.scm +++ b/collects/tests/typed-scheme/succeed/priority-queue.scm @@ -76,7 +76,7 @@ (error "priority queue empty")))) (pdefine: (a) (insert [x : a] [p : number] [pq : (priority-queue a)]) : (priority-queue a) - (make (heap:insert (#{cons :: (case-lambda (a (list-of a) -> (list-of a)) (number a -> (cons number a)))} p x) (heap pq)))) + (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) From 7e4ee76e4e7b8db3a30bfe6f3b19893ae83b1728 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 3 Jun 2010 17:31:09 -0400 Subject: [PATCH 090/198] Various small assorted fixes. original commit: d886331807f55e5a2a4ebb464b50d50835e20393 --- .../typed-scheme/infer/constraint-structs.rkt | 13 ++++++++---- collects/typed-scheme/infer/dmap.rkt | 2 +- collects/typed-scheme/infer/infer-unit.rkt | 21 ++++++++++++++----- collects/typed-scheme/typecheck/tc-app.rkt | 17 +++++++++------ 4 files changed, 37 insertions(+), 16 deletions(-) diff --git a/collects/typed-scheme/infer/constraint-structs.rkt b/collects/typed-scheme/infer/constraint-structs.rkt index 19cb2591..4ad2c0c2 100644 --- a/collects/typed-scheme/infer/constraint-structs.rkt +++ b/collects/typed-scheme/infer/constraint-structs.rkt @@ -9,6 +9,9 @@ ;; fixed : Listof[c] ;; rest : option[c] +;; a constraint on an index variable +;; the index variable must be instantiated with |fixed| arguments, each meeting the appropriate constraint +;; and further instantions of the index variable must respect the rest constraint, if it exists (d-s/c dcon ([fixed (listof c?)] [rest (or/c c? #f)]) #:transparent) ;; fixed : Listof[c] @@ -19,8 +22,10 @@ ;; bound : var (d-s/c dcon-dotted ([type c?] [bound symbol?]) #:transparent) -;; map : hash mapping variable to dcon or dcon-dotted -(d-s/c dmap ([map (hash/c symbol? (or/c dcon? dcon-exact? dcon-dotted?))]) #:transparent) +(define dcon/c (or/c dcon? dcon-exact? dcon-dotted?)) + +;; map : hash mapping index variables to dcons +(d-s/c dmap ([map (hash/c symbol? dcon/c)]) #:transparent) ;; maps is a list of pairs of ;; - functional maps from vars to c's @@ -28,7 +33,7 @@ ;; we need a bunch of mappings for each cset to handle case-lambda ;; because case-lambda can generate multiple possible solutions, and we ;; don't want to rule them out too early -(d-s/c cset ([maps (listof (cons/c (hash/c symbol? c?) dmap?))]) #:transparent) +(d-s/c cset ([maps (listof (cons/c (hash/c symbol? c? #:immutable #t) dmap?))]) #:transparent) (define-match-expander c: (lambda (stx) @@ -37,4 +42,4 @@ #'(struct c (s x t))]))) (provide (struct-out cset) (struct-out dmap) (struct-out dcon) (struct-out dcon-dotted) (struct-out dcon-exact) (struct-out c) - c:) + c: dcon/c) diff --git a/collects/typed-scheme/infer/dmap.rkt b/collects/typed-scheme/infer/dmap.rkt index 7f88f291..6f613748 100644 --- a/collects/typed-scheme/infer/dmap.rkt +++ b/collects/typed-scheme/infer/dmap.rkt @@ -10,7 +10,7 @@ ;; dcon-meet : dcon dcon -> dcon (d/c (dcon-meet dc1 dc2) - (dcon? dcon? . -> . dcon?) + (dcon/c dcon/c . -> . dcon/c) (match* (dc1 dc2) [((struct dcon-exact (fixed1 rest1)) (or (struct dcon (fixed2 rest2)) (struct dcon-exact (fixed2 rest2)))) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index ae882641..f60a2806 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -66,7 +66,13 @@ dmap))) cset)) -(define (move-vars-to-dmap cset dbound vars) +;; dbound : index variable +;; vars : listof[type variable] - temporary variables +;; cset : the constraints being manipulated +;; takes the constraints on vars and creates a dmap entry contstraining dbound to be |vars| +;; with the constraints that cset places on vars +(d/c (move-vars-to-dmap cset dbound vars) + (cset? symbol? (listof symbol?) . -> . cset?) (mover cset dbound vars (λ (cmap) (make-dcon (for/list ([v vars]) @@ -74,7 +80,11 @@ (λ () (int-err "No constraint for new var ~a" v)))) #f)))) -(define (move-rest-to-dmap cset dbound #:exact [exact? #f]) +;; dbound : index variable +;; cset : the constraints being manipulated +;; +(d/c (move-rest-to-dmap cset dbound #:exact [exact? #f]) + ((cset? symbol?) (#:exact boolean?) . ->* . cset?) (mover cset dbound (list dbound) (λ (cmap) ((if exact? make-dcon-exact make-dcon) @@ -82,7 +92,8 @@ (hash-ref cmap dbound (λ () (int-err "No constraint for bound ~a" dbound))))))) -(define (move-vars+rest-to-dmap cset dbound vars #:exact [exact? #f]) +(d/c (move-vars+rest-to-dmap cset dbound vars #:exact [exact? #f]) + ((cset? symbol? (listof symbol?)) (#:exact boolean?) . ->* . cset?) (mover cset dbound vars (λ (cmap) ((if exact? make-dcon-exact make-dcon) @@ -91,7 +102,6 @@ (hash-ref cmap dbound (λ () (int-err "No constraint for bound ~a" dbound))))))) -;; s and t must be *latent* filters (define (cgen/filter V X s t) (match* (s t) [(e e) (empty-cset X)] @@ -194,6 +204,7 @@ [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))] + ;; * <: ... [((arr: ss s s-rest #f '()) (arr: ts t #f (cons t-dty dbound) '())) (unless (memq dbound X) @@ -460,7 +471,7 @@ (match v [(struct c (S X T)) ;; fixme - handle free indexes, remove Dotted - (let ([var (hash-ref (free-vars* R) (or variable X) Constant)]) + (let ([var (hash-ref (free-vars* R) (or variable X) (λ () (hash-ref (free-idxs* R) (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) (evcase var [Constant S] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index b8887930..151e7d46 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -813,7 +813,7 @@ #: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))))] - ;; any kind of polymorphic function + ;; any kind of dotted polymorphic function without mandatory keyword args [((tc-result1: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var)) (Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...))))) @@ -828,11 +828,16 @@ ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) ;; note that we have to use argtys-t here, since argtys is a list of tc-results (lambda (dom rng rest drest a) - (if drest - (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) - #:expected (and expected (tc-results->values expected))) - (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng - (and expected (tc-results->values expected))))) + (cond + [drest + (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) + #:expected (and expected (tc-results->values expected)))] + [rest + (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng + (and expected (tc-results->values expected)))] + ;; no rest or drest + [else (infer fixed-vars (list dotted-var) argtys-t dom rng + (and expected (tc-results->values expected)))])) t argtys expected)] ;; regular polymorphic functions without dotted rest, and without mandatory keyword args [((tc-result1: From 5a4d6ed4a021b3b2aef0a8c52696460d7d64a805 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 4 Jun 2010 14:13:03 -0400 Subject: [PATCH 091/198] Fix up subst-gen to treat vars and idxs separately. original commit: ec09139e0a22007fd3f6bd7ac69336053d65bb48 --- collects/typed-scheme/infer/infer-unit.rkt | 38 ++++++++++++++-------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index f60a2806..a62b7e57 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -465,20 +465,21 @@ (d/c (subst-gen C R) (cset? Type? . -> . (or/c #f list?)) - ;; fixme - should handle these separately - (define must-vars (append (fv R) (fi R))) - (define (constraint->type v #:variable [variable #f]) + (define var-hash (free-vars* R)) + (define idx-hash (free-idxs* R)) + ;; v : Symbol - variable for which to check variance + ;; h : (Hash Symbol Variance) - hash to check variance in (either var or idx hash) + ;; variable: Symbol - variable to use instead, if v was a temp var for idx extension + (define (constraint->type v h #:variable [variable #f]) (match v [(struct c (S X T)) - ;; fixme - handle free indexes, remove Dotted - (let ([var (hash-ref (free-vars* R) (or variable X) (λ () (hash-ref (free-idxs* R) (or variable X) Constant)))]) + (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) (evcase var [Constant S] [Covariant S] [Contravariant T] - [Invariant S] - [Dotted T]))])) + [Invariant S]))])) (match (car (cset-maps C)) [(cons cmap (dmap dm)) (let ([subst (append @@ -487,18 +488,27 @@ [(dcon fixed rest) (list k (for/list ([f fixed]) - (constraint->type f #:variable k)) - (and rest (constraint->type rest)))] + (constraint->type f idx-hash #:variable k)) + (and rest (constraint->type rest idx-hash)))] [(dcon-exact fixed rest) (list k (for/list ([f fixed]) - (constraint->type f #:variable k)) - (constraint->type rest))])) + (constraint->type f idx-hash #:variable k)) + (constraint->type rest idx-hash))])) (for/list ([(k v) (in-hash cmap)]) - (list k (constraint->type v))))]) + (list k (constraint->type v var-hash))))]) ;; verify that we got all the important variables - (and (for/and ([v must-vars]) - (assq v subst)) + (and (for/and ([v (fv R)]) + (let ([entry (assq v subst)]) + ;; Make sure we got a subst entry for a type var + ;; (i.e. just a type to substitute) + (and entry (= (length entry) 2)))) + (for/and ([v (fi R)]) + (let ([entry (assq v subst)]) + ;; Make sure we got a subst entry for an index var + ;; (i.e. a list of types for the fixed portion + ;; and a type for the starred portion) + (and entry (= (length entry) 3)))) subst))])) ;; V : a set of variables not to mention in the constraints From b956e47ed289e2424f21871916cdcd3b670494b5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 11 Jun 2010 14:31:34 -0400 Subject: [PATCH 092/198] Export the types provide macro. original commit: 078b57c77da5051470cf88e932c69f9f95ed60b6 --- collects/typed-scheme/utils/utils.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index 493ab95a..bf109ba9 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -23,7 +23,7 @@ at least theoretically. ;; struct printing custom-printer define-struct/printer ;; provide macros - rep utils typecheck infer env private) + rep utils typecheck infer env private types) (define optimize? (make-parameter #f)) From f1ef77e550535f0c4e5e8c9ed2a6bcd6e3cafb16 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 11 Jun 2010 14:55:08 -0400 Subject: [PATCH 093/198] The initial shot at extending cgen and friends to take both X and Y. This doesn't fully work, in that more test cases are broken. However, this is mostly due to questionable inference rules in the past, and so fixing these errors should lead to a more correct inference algorithm. (i.e. we need to handle things like (List X ... a) (List Y .. b), where a and b are not the same bound. We'd started this work before, but never actually gone through with it, since smashing regular and dotted type variables into the same environment meant some things magically worked when they possibly shouldn't have.) original commit: b5d4d54d450b7c2e87ab1d80db66e84cbd1bd2e5 --- collects/typed-scheme/infer/constraints.rkt | 5 +- collects/typed-scheme/infer/infer-unit.rkt | 214 ++++++++++++-------- collects/typed-scheme/infer/signatures.rkt | 2 +- collects/typed-scheme/typecheck/tc-app.rkt | 21 +- 4 files changed, 142 insertions(+), 100 deletions(-) diff --git a/collects/typed-scheme/infer/constraints.rkt b/collects/typed-scheme/infer/constraints.rkt index 2626eb2f..037fa4cd 100644 --- a/collects/typed-scheme/infer/constraints.rkt +++ b/collects/typed-scheme/infer/constraints.rkt @@ -26,7 +26,10 @@ (define (no-constraint v) (make-c (Un) v Univ)) -(define (empty-cset X) +;; Create an empty constraint map from a set of type variables X and +;; index variables Y. For now, we add the widest constraints for +;; variables in X to the cmap and create an empty dmap. +(define (empty-cset X Y) (make-cset (list (cons (for/hash ([x X]) (values x (no-constraint x))) (make-dmap (make-immutable-hash null)))))) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index a62b7e57..9d85d689 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -1,12 +1,12 @@ #lang scheme/unit -(require scheme/require +(require scheme/require (path-up "utils/utils.rkt") (except-in - (path-up - "utils/utils.rkt" "utils/tc-utils.rkt" "types/utils.rkt" - "rep/free-variance.rkt" "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/rep-utils.rkt" - "types/convenience.rkt" "types/union.rkt" "types/subtype.rkt" "types/remove-intersect.rkt" "types/resolve.rkt" - "env/type-name-env.rkt" "env/index-env.rkt" "env/tvar-env.rkt") + (combine-in + (utils tc-utils) + (rep free-variance type-rep filter-rep rep-utils) + (types utils convenience union subtype remove-intersect resolve) + (env type-name-env index-env tvar-env)) make-env -> ->* one-of/c) "constraint-structs.rkt" "signatures.rkt" @@ -62,7 +62,7 @@ (dmap-meet (singleton-dmap dbound - (f cmap)) + (f cmap dmap)) dmap))) cset)) @@ -74,7 +74,7 @@ (d/c (move-vars-to-dmap cset dbound vars) (cset? symbol? (listof symbol?) . -> . cset?) (mover cset dbound vars - (λ (cmap) + (λ (cmap dmap) (make-dcon (for/list ([v vars]) (hash-ref cmap v (λ () (int-err "No constraint for new var ~a" v)))) @@ -86,55 +86,63 @@ (d/c (move-rest-to-dmap cset dbound #:exact [exact? #f]) ((cset? symbol?) (#:exact boolean?) . ->* . cset?) (mover cset dbound (list dbound) - (λ (cmap) + (λ (cmap dmap) ((if exact? make-dcon-exact make-dcon) null (hash-ref cmap dbound (λ () (int-err "No constraint for bound ~a" dbound))))))) +;; This one's weird, because the way we set it up, the rest is already in the dmap. +;; This is because we create all the vars, then recall cgen/arr with the new vars +;; in place, and the "simple" case will then call move-rest-to-dmap. This means +;; we need to extract that result from the dmap and merge it with the fixed vars +;; we now handled. So I've extended the mover to give access to the dmap, which we use here. (d/c (move-vars+rest-to-dmap cset dbound vars #:exact [exact? #f]) ((cset? symbol? (listof symbol?)) (#:exact boolean?) . ->* . cset?) (mover cset dbound vars - (λ (cmap) + (λ (cmap dmap) ((if exact? make-dcon-exact make-dcon) (for/list ([v vars]) (hash-ref cmap v (λ () (int-err "No constraint for new var ~a" v)))) - (hash-ref cmap dbound - (λ () (int-err "No constraint for bound ~a" dbound))))))) + (match (hash-ref (dmap-map dmap) dbound + (λ () (int-err "No constraint for bound ~a" dbound))) + [(dcon null rest) rest] + [(dcon-exact null rest) rest] + [_ (int-err "did not get a rest-only dcon when moving to the dmap")]))))) -(define (cgen/filter V X s t) +(define (cgen/filter V X Y s t) (match* (s t) - [(e e) (empty-cset X)] - [(e (Top:)) (empty-cset X)] + [(e e) (empty-cset X Y)] + [(e (Top:)) (empty-cset X Y)] ;; FIXME - is there something to be said about the logical ones? - [((TypeFilter: s p i) (TypeFilter: t p i)) (cset-meet (cgen V X s t) (cgen V X t s))] - [((NotTypeFilter: s p i) (NotTypeFilter: t p i)) (cset-meet (cgen V X s t) (cgen V X t s))] + [((TypeFilter: s p i) (TypeFilter: t p i)) (cset-meet (cgen V X Y s t) (cgen V X Y t s))] + [((NotTypeFilter: s p i) (NotTypeFilter: t p i)) (cset-meet (cgen V X Y s t) (cgen V X Y t s))] [(_ _) (fail! s t)])) ;; s and t must be *latent* filter sets -(define (cgen/filter-set V X s t) +(define (cgen/filter-set V X Y s t) (match* (s t) - [(e e) (empty-cset X)] + [(e e) (empty-cset X Y)] [((FilterSet: s+ s-) (FilterSet: t+ t-)) - (cset-meet (cgen/filter V X s+ t+) (cgen/filter V X s- t-))] + (cset-meet (cgen/filter V X Y s+ t+) (cgen/filter V X Y s- t-))] [(_ _) (fail! s t)])) -(define (cgen/object V X s t) +(define (cgen/object V X Y s t) (match* (s t) - [(e e) (empty-cset X)] - [(e (Empty:)) (empty-cset X)] + [(e e) (empty-cset X Y)] + [(e (Empty:)) (empty-cset X Y)] ;; FIXME - do something here [(_ _) (fail! s t)])) -(define (cgen/arr V X s-arr t-arr) - (define (cg S T) (cgen V X S T)) +(define (cgen/arr V X Y s-arr t-arr) + (define (cg S T) (cgen V X Y S T)) (match* (s-arr t-arr) ;; the simplest case - no rests, drests, keywords [((arr: ss s #f #f '()) (arr: ts t #f #f '())) (cset-meet* (list ;; contravariant - (cgen/list V X ts ss) + (cgen/list V X Y ts ss) ;; covariant (cg s t)))] ;; just a rest arg, no drest, no keywords @@ -144,10 +152,10 @@ (cond ;; both rest args are present, so make them the same length [(and s-rest t-rest) - (cgen/list V X (cons t-rest (extend ss ts t-rest)) (cons s-rest (extend ts ss s-rest)))] + (cgen/list V X Y (cons t-rest (extend ss ts t-rest)) (cons s-rest (extend ts ss s-rest)))] ;; no rest arg on the right, so just pad the left and forget the rest arg [(and s-rest (not t-rest) (<= (length ss) (length ts))) - (cgen/list V X ts (extend ts ss s-rest))] + (cgen/list V X Y ts (extend ts ss s-rest))] ;; no rest arg on the left, or wrong number = fail [else (fail! S T)])] [ret-mapping (cg s t)]) @@ -155,7 +163,7 @@ ;; dotted on the left, nothing on the right [((arr: ss s #f (cons dty dbound) '()) (arr: ts t #f #f '())) - (unless (memq dbound X) + (unless (memq dbound Y) (fail! S T)) (unless (<= (length ss) (length ts)) (fail! S T)) @@ -164,12 +172,12 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] [new-s-arr (make-arr (append ss new-tys) s #f #f null)] - [new-cset (cgen/arr V (append vars X) new-s-arr t-arr)]) + [new-cset (cgen/arr V (append vars X) Y new-s-arr t-arr)]) (move-vars-to-dmap new-cset dbound vars))] ;; dotted on the right, nothing on the left [((arr: ss s #f #f '()) (arr: ts t #f (cons dty dbound) '())) - (unless (memq dbound X) + (unless (memq dbound Y) (fail! S T)) (unless (<= (length ts) (length ss)) (fail! S T)) @@ -178,7 +186,7 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] [new-t-arr (make-arr (append ts new-tys) t #f #f null)] - [new-cset (cgen/arr V (append vars X) s-arr new-t-arr)]) + [new-cset (cgen/arr V (append vars X) Y s-arr new-t-arr)]) (move-vars-to-dmap new-cset dbound vars))] ;; this case is just for constrainting other variables, not dbound [((arr: ss s #f (cons s-dty dbound) '()) @@ -186,10 +194,10 @@ (unless (= (length ss) (length ts)) (fail! S T)) ;; If we want to infer the dotted bound, then why is it in both types? - (when (memq dbound X) + (when (memq dbound Y) (fail! S T)) - (let* ([arg-mapping (cgen/list V X ts ss)] - [darg-mapping (cgen V X t-dty s-dty)] + (let* ([arg-mapping (cgen/list V X Y ts ss)] + [darg-mapping (cgen V X Y t-dty s-dty)] [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))] @@ -198,21 +206,21 @@ (arr: ts t #f (cons t-dty dbound*) '())) (unless (= (length ss) (length ts)) (fail! S T)) - (let* ([arg-mapping (cgen/list V X ts ss)] + (let* ([arg-mapping (cgen/list V X Y ts ss)] ;; just add dbound as something that can be constrained - [darg-mapping (cgen V (cons dbound X) t-dty s-dty)] + [darg-mapping (cgen V (cons dbound X) Y t-dty s-dty)] [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))] ;; * <: ... [((arr: ss s s-rest #f '()) (arr: ts t #f (cons t-dty dbound) '())) - (unless (memq dbound X) + (unless (memq dbound Y) (fail! S T)) (if (<= (length ss) (length ts)) ;; the simple case - (let* ([arg-mapping (cgen/list V X ts (extend ts ss s-rest))] - [darg-mapping (move-rest-to-dmap (cgen V X t-dty s-rest) dbound)] + (let* ([arg-mapping (cgen/list V X Y ts (extend ts ss s-rest))] + [darg-mapping (move-rest-to-dmap (cgen V (cons dbound X) Y t-dty s-rest) dbound)] [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping))) ;; the hard case @@ -221,12 +229,12 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound t-dty))] [new-t-arr (make-arr (append ts new-tys) t #f (cons t-dty dbound) null)] - [new-cset (cgen/arr V (append vars X) s-arr new-t-arr)]) + [new-cset (cgen/arr V (append vars X) Y s-arr new-t-arr)]) (move-vars+rest-to-dmap new-cset dbound vars)))] ;; If dotted <: starred is correct, add it below. Not sure it is. [((arr: ss s #f (cons s-dty dbound) '()) (arr: ts t t-rest #f '())) - (unless (memq dbound X) + (unless (memq dbound Y) (fail! S T)) (cond [(< (length ss) (length ts)) ;; the hard case @@ -235,28 +243,30 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound s-dty))] [new-s-arr (make-arr (append ss new-tys) s #f (cons s-dty dbound) null)] - [new-cset (cgen/arr V (append vars X) new-s-arr t-arr)]) + [new-cset (cgen/arr V (append vars X) Y new-s-arr t-arr)]) (move-vars+rest-to-dmap new-cset dbound vars #:exact #t))] [else ;; the simple case - (let* ([arg-mapping (cgen/list V X (extend ss ts t-rest) ss)] - [darg-mapping (move-rest-to-dmap (cgen V X t-rest s-dty) dbound #:exact #t)] + (let* ([arg-mapping (cgen/list V X Y (extend ss ts t-rest) ss)] + [darg-mapping (move-rest-to-dmap (cgen V (cons dbound X) Y t-rest s-dty) dbound #:exact #t)] [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))])] [(_ _) (fail! S T)])) ;; V : a set of variables not to mention in the constraints -;; X : the set of variables to be constrained +;; X : the set of type variables to be constrained +;; Y : the set of index variables to be constrained ;; S : a type to be the subtype of T ;; T : a type ;; produces a cset which determines a substitution that makes S a subtype of T -;; implements the V |-_X S <: T => C judgment from Pierce+Turner -(d/c (cgen V X S T) - ((listof symbol?) (listof symbol?) Type? Type? . -> . cset?) +;; implements the V |-_X S <: T => C judgment from Pierce+Turner, extended with +;; the index variables from the TOPLAS paper +(d/c (cgen V X Y S T) + ((listof symbol?) (listof symbol?) (listof symbol?) Type? Type? . -> . cset?) ;; useful quick loop - (define (cg S T) (cgen V X S T)) + (define (cg S T) (cgen V X Y S T)) ;; this places no constraints on any variables in X - (define empty (empty-cset X)) + (define empty (empty-cset X Y)) ;; this constrains just x (which is a single var) (define (singleton S x T) (insert empty x S T)) @@ -296,7 +306,7 @@ (singleton (var-promote S V) v Univ)] ;; constrain b1 to be below T, but don't mention the new vars - [((Poly: v1 b1) T) (cgen (append v1 V) X b1 T)] + [((Poly: v1 b1) T) (cgen (append v1 V) X Y b1 T)] ;; constrain *each* element of es to be below T, and then combine the constraints [((Union: es) T) (cset-meet* (cons empty (for/list ([e es]) (cg e T))))] @@ -318,7 +328,7 @@ (cond [(and proc proc*) (values (cons proc flds) (cons proc* flds*))] [else (values flds flds*)])]) - (cgen/list V X flds flds*))] + (cgen/list V X Y flds flds*))] ;; two struct names, need to resolve b/c one could be a parent [((Name: n) (Name: n*)) @@ -330,7 +340,7 @@ (cset-meet (cg a a*) (cg b b*))] ;; sequences are covariant [((Sequence: ts) (Sequence: ts*)) - (cgen/list V X ts ts*)] + (cgen/list V X Y ts ts*)] [((Listof: t) (Sequence: (list t*))) (cg t t*)] [((List: ts) (Sequence: (list t*))) @@ -350,20 +360,20 @@ [((Vector: t) (Sequence: (list t*))) (cg t t*)] [((Hashtable: k v) (Sequence: (list k* v*))) - (cgen/list V X (list k v) (list k* v*))] + (cgen/list V X Y (list k v) (list k* v*))] ;; ListDots can be below a Listof ;; must be above mu unfolding [((ListDots: s-dty dbound) (Listof: t-elem)) - (when (memq dbound X) (fail! S T)) - (cgen V X (substitute Univ dbound s-dty) t-elem)] + (when (memq dbound Y) (fail! S T)) + (cgen V X Y (substitute Univ dbound s-dty) t-elem)] ;; two ListDots with the same bound, just check the element type [((ListDots: s-dty dbound) (ListDots: t-dty dbound)) - (when (memq dbound X) (fail! S T)) - (cgen V X s-dty t-dty)] + (when (memq dbound Y) (fail! S T)) + (cgen V X Y s-dty t-dty)] ;; this constrains `dbound' to be |ts| - |ss| [((ListDots: s-dty dbound) (List: ts)) - (unless (memq dbound X) (fail! S T)) + (unless (memq dbound Y) (fail! S T)) (let* ([vars (for/list ([n (in-range (length ts))]) (gensym dbound))] @@ -371,7 +381,7 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound s-dty))] ;; generate constraints on the prefixes, and on the dummy types - [new-cset (cgen/list V (append vars X) new-tys ts)]) + [new-cset (cgen/list V (append vars X) Y new-tys ts)]) ;; now take all the dummy types, and use them to constrain dbound appropriately (move-vars-to-dmap new-cset dbound vars))] @@ -393,12 +403,12 @@ [((Values: ss) (Values: ts)) (unless (= (length ss) (length ts)) (fail! ss ts)) - (cgen/list V X ss ts)] + (cgen/list V X Y ss ts)] ;; this constrains `dbound' to be |ts| - |ss| [((ValuesDots: ss s-dty dbound) (Values: ts)) (unless (>= (length ts) (length ss)) (fail! ss ts)) - (unless (memq dbound X) (fail! S T)) + (unless (memq dbound Y) (fail! S T)) (let* ([vars (for/list ([n (in-range (- (length ts) (length ss)))]) (gensym dbound))] @@ -406,14 +416,14 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound s-dty))] ;; generate constraints on the prefixes, and on the dummy types - [new-cset (cgen/list V (append vars X) (append ss new-tys) ts)]) + [new-cset (cgen/list V (append vars X) Y (append ss new-tys) ts)]) ;; now take all the dummy types, and use them to constrain dbound appropriately (move-vars-to-dmap new-cset dbound vars))] ;; identical bounds - just unify pairwise [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound)) - (when (memq dbound X) (fail! ss ts)) - (cgen/list V X (cons s-dty ss) (cons t-dty ts))] + (when (memq dbound Y) (fail! ss ts)) + (cgen/list V X Y (cons s-dty ss) (cons t-dty ts))] ;; vectors are invariant - generate constraints *both* ways [((Vector: e) (Vector: e*)) (cset-meet (cg e e*) (cg e* e))] @@ -446,7 +456,7 @@ (let ([results (filter values (for/list ([s-arr s-arr]) (with-handlers ([exn:infer? (lambda (_) #f)]) - (cgen/arr V X s-arr t-arr))))]) + (cgen/arr V X Y s-arr t-arr))))]) ;; ensure that something produces a constraint set (when (null? results) (fail! S T)) (cset-combine results))))] @@ -454,8 +464,8 @@ [((Result: s f-s o-s) (Result: t f-t o-t)) (cset-meet* (list (cg s t) - (cgen/filter-set V X f-s f-t) - (cgen/object V X o-s o-t)))] + (cgen/filter-set V X Y f-s f-t) + (cgen/object V X Y o-s o-t)))] [(_ _) (cond ;; subtypes are easy - should this go earlier? @@ -463,8 +473,11 @@ ;; or, nothing worked, and we fail [else (fail! S T)])])))) -(d/c (subst-gen C R) - (cset? Type? . -> . (or/c #f list?)) +;; C : cset? - set of constraints found by the inference engine +;; Y : (listof symbol?) - index variables that must have entries +;; R : Type? - result type into which we will be substituting +(d/c (subst-gen C Y R) + (cset? (listof symbol?) Type? . -> . (or/c #f list?)) (define var-hash (free-vars* R)) (define idx-hash (free-idxs* R)) ;; v : Symbol - variable for which to check variance @@ -480,6 +493,34 @@ [Covariant S] [Contravariant T] [Invariant S]))])) + ;; Since we don't add entries to the empty cset for index variables (since there is no + ;; widest constraint, due to dcon-exacts), we must add substitutions here if no constraint + ;; was found. If we're at this point and had no other constraints, then adding the + ;; equivalent of the constraint (dcon null (c Bot X Top)) is okay. + (define (extend-idxs S) + ;; absent-entries is #f if there's an error in the substitution, otherwise + ;; it's a list of variables that don't appear in the substitution + (define absent-entries + (for/fold ([no-entry null]) ([v (in-list Y)]) + (let ([entry (assq v S)]) + ;; Make sure we got a subst entry for an index var + ;; (i.e. a list of types for the fixed portion + ;; and a type for the starred portion) + (cond + [(not no-entry) no-entry] + [(not entry) (cons v no-entry)] + [(= (length entry) 3) no-entry] + [else #f])))) + (and absent-entries + (append + (for/list ([missing (in-list absent-entries)]) + (let ([var (hash-ref idx-hash missing Constant)]) + (evcase var + [Constant (int-err "attempted to demote dotted variable")] + [Covariant (int-err "attempted to demote dotted variable")] + [Contravariant (list missing null Univ)] + [Invariant (int-err "attempted to demote dotted variable")]))) + S))) (match (car (cset-maps C)) [(cons cmap (dmap dm)) (let ([subst (append @@ -503,24 +544,19 @@ ;; Make sure we got a subst entry for a type var ;; (i.e. just a type to substitute) (and entry (= (length entry) 2)))) - (for/and ([v (fi R)]) - (let ([entry (assq v subst)]) - ;; Make sure we got a subst entry for an index var - ;; (i.e. a list of types for the fixed portion - ;; and a type for the starred portion) - (and entry (= (length entry) 3)))) - subst))])) + (extend-idxs subst)))])) ;; V : a set of variables not to mention in the constraints -;; X : the set of variables to be constrained +;; X : the set of type variables to be constrained +;; Y : the set of index variables to be constrained ;; S : a list of types to be the subtypes of T ;; T : a list of types ;; produces a cset which determines a substitution that makes the Ss subtypes of the Ts -(d/c (cgen/list V X S T) - ((listof symbol?) (listof symbol?) (listof Type?) (listof Type?) . -> . cset?) +(d/c (cgen/list V X Y S T) + ((listof symbol?) (listof symbol?) (listof symbol?) (listof Type?) (listof Type?) . -> . cset?) (unless (= (length S) (length T)) (fail! S T)) - (cset-meet* (for/list ([s S] [t T]) (cgen V X s t)))) + (cset-meet* (for/list ([s S] [t T]) (cgen V X Y s t)))) ;; X : variables to infer ;; Y : indices to infer @@ -533,11 +569,11 @@ ;; just return a boolean result (define (infer X Y S T R [expected #f]) (with-handlers ([exn:infer? (lambda _ #f)]) - (let* ([cs (cgen/list null (append X Y) S T)] + (let* ([cs (cgen/list null X Y S T)] [cs* (if expected - (cset-meet cs (cgen null (append X Y) R expected)) + (cset-meet cs (cgen null X Y R expected)) cs)]) - (if R (subst-gen cs* R) #t)))) + (if R (subst-gen cs* Y R) #t)))) ;; like infer, but T-var is the vararg type: (define (infer/vararg X Y S T T-var R [expected #f]) @@ -551,16 +587,16 @@ (with-handlers ([exn:infer? (lambda _ #f)]) (let* ([short-S (take S (length T))] [rest-S (drop S (length T))] - [cs-short (cgen/list null (cons dotted-var X) short-S T)] + [cs-short (cgen/list null X (list dotted-var) short-S T)] [new-vars (for/list ([i (in-range (length rest-S))]) (gensym dotted-var))] [new-Ts (for/list ([v new-vars]) (substitute (make-F v) dotted-var (substitute-dots (map make-F new-vars) #f dotted-var T-dotted)))] - [cs-dotted (cgen/list null (append new-vars X) rest-S new-Ts)] + [cs-dotted (cgen/list null (append new-vars X) (list dotted-var) rest-S new-Ts)] [cs-dotted* (move-vars-to-dmap cs-dotted dotted-var new-vars)] [cs (cset-meet cs-short cs-dotted*)]) (if (not expected) - (subst-gen cs R) - (subst-gen (cset-meet cs (cgen null X R expected)) R))))) + (subst-gen cs (list dotted-var) R) + (subst-gen (cset-meet cs (cgen null X (list dotted-var) R expected)) (list dotted-var) R))))) ;(trace cgen) diff --git a/collects/typed-scheme/infer/signatures.rkt b/collects/typed-scheme/infer/signatures.rkt index fb545701..5286215d 100644 --- a/collects/typed-scheme/infer/signatures.rkt +++ b/collects/typed-scheme/infer/signatures.rkt @@ -21,7 +21,7 @@ [cnt cset-meet (cset? cset? . -> . cset?)] [cnt cset-meet* ((listof cset?) . -> . cset?)] no-constraint - [cnt empty-cset ((listof symbol?) . -> . cset?)] + [cnt empty-cset ((listof symbol?) (listof symbol?) . -> . cset?)] [cnt insert (cset? symbol? Type? Type? . -> . cset?)] [cnt cset-combine ((listof cset?) . -> . cset?)] [cnt c-meet ((c? c?) (symbol?) . ->* . c?)])) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 151e7d46..180fa36c 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -399,8 +399,8 @@ (= (length (car doms*)) (length arg-tys)) (infer fixed-vars (list dotted-var) - (cons tail-ty arg-tys) - (cons (car (car drests*)) (car doms*)) + (cons (make-ListDots tail-ty tail-bound) arg-tys) + (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*)) (car rngs*))) => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] @@ -414,16 +414,19 @@ (extend-indexes (cdr (car drests*)) ;; don't need to add tail-bound - it must already be an index (infer fixed-vars (list dotted-var) - (cons tail-ty arg-tys) - (cons (car (car drests*)) (car doms*)) + (cons (make-ListDots tail-ty tail-bound) arg-tys) + (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*)) (car rngs*))))) => (lambda (substitution) (define drest-bound (cdr (car drests*))) - (do-ret (substitute-dotted (cadr (assq drest-bound substitution)) - tail-bound - drest-bound - (subst-all (alist-delete drest-bound substitution eq?) - (car rngs*)))))] + (let ([dots-subst (assq drest-bound substitution)]) + (unless dots-subst + (int-err "expected dotted substitution for ~a" drest-bound)) + (do-ret (substitute-dotted (cadr dots-subst) + tail-bound + drest-bound + (subst-all (alist-delete drest-bound substitution eq?) + (car rngs*))))))] ;; ... function, (List A B C etc) arg [(and (car drests*) (not tail-bound) From 16617152c556c3b4497becffba00582e8f1ac3f7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 14:59:37 -0400 Subject: [PATCH 094/198] Fix move-to-dmap functions original commit: 9f99c914f3ce2c00119b64caa0be1a286df398c1 --- collects/typed-scheme/infer/infer-unit.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 9d85d689..75328d60 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -58,12 +58,12 @@ (define (mover cset dbound vars f) (map/cset (lambda (cmap dmap) - (cons (hash-remove* cmap vars) + (cons (hash-remove* cmap (cons dbound vars)) (dmap-meet (singleton-dmap dbound (f cmap dmap)) - dmap))) + (make-dmap (hash-remove (dmap-map dmap) dbound))))) cset)) ;; dbound : index variable @@ -85,7 +85,7 @@ ;; (d/c (move-rest-to-dmap cset dbound #:exact [exact? #f]) ((cset? symbol?) (#:exact boolean?) . ->* . cset?) - (mover cset dbound (list dbound) + (mover cset dbound null (λ (cmap dmap) ((if exact? make-dcon-exact make-dcon) null From 9f8b2e4e2bf21b7d681e12cf1f26624c6fd3fb84 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 15:01:09 -0400 Subject: [PATCH 095/198] fix fail! to use the correct arguments original commit: 692dc025c0db0aa64ee358ae5a36cbd6165455a3 --- collects/typed-scheme/infer/infer-unit.rkt | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 75328d60..434a53ca 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -157,16 +157,16 @@ [(and s-rest (not t-rest) (<= (length ss) (length ts))) (cgen/list V X Y ts (extend ts ss s-rest))] ;; no rest arg on the left, or wrong number = fail - [else (fail! S T)])] + [else (fail! s-arr t-arr)])] [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping ret-mapping)))] ;; dotted on the left, nothing on the right [((arr: ss s #f (cons dty dbound) '()) (arr: ts t #f #f '())) (unless (memq dbound Y) - (fail! S T)) + (fail! s-arr t-arr)) (unless (<= (length ss) (length ts)) - (fail! S T)) + (fail! ss ts)) (let* ([vars (for/list ([n (in-range (- (length ts) (length ss)))]) (gensym dbound))] [new-tys (for/list ([var vars]) @@ -178,9 +178,9 @@ [((arr: ss s #f #f '()) (arr: ts t #f (cons dty dbound) '())) (unless (memq dbound Y) - (fail! S T)) + (fail! s-arr t-arr)) (unless (<= (length ts) (length ss)) - (fail! S T)) + (fail! ss ts)) (let* ([vars (for/list ([n (in-range (- (length ss) (length ts)))]) (gensym dbound))] [new-tys (for/list ([var vars]) @@ -192,10 +192,10 @@ [((arr: ss s #f (cons s-dty dbound) '()) (arr: ts t #f (cons t-dty dbound) '())) (unless (= (length ss) (length ts)) - (fail! S T)) + (fail! ss ts)) ;; If we want to infer the dotted bound, then why is it in both types? (when (memq dbound Y) - (fail! S T)) + (fail! s-arr t-arr)) (let* ([arg-mapping (cgen/list V X Y ts ss)] [darg-mapping (cgen V X Y t-dty s-dty)] [ret-mapping (cg s t)]) @@ -205,7 +205,7 @@ [((arr: ss s #f (cons s-dty dbound) '()) (arr: ts t #f (cons t-dty dbound*) '())) (unless (= (length ss) (length ts)) - (fail! S T)) + (fail! ss ts)) (let* ([arg-mapping (cgen/list V X Y ts ss)] ;; just add dbound as something that can be constrained [darg-mapping (cgen V (cons dbound X) Y t-dty s-dty)] @@ -216,7 +216,7 @@ [((arr: ss s s-rest #f '()) (arr: ts t #f (cons t-dty dbound) '())) (unless (memq dbound Y) - (fail! S T)) + (fail! s-arr t-arr)) (if (<= (length ss) (length ts)) ;; the simple case (let* ([arg-mapping (cgen/list V X Y ts (extend ts ss s-rest))] @@ -235,7 +235,7 @@ [((arr: ss s #f (cons s-dty dbound) '()) (arr: ts t t-rest #f '())) (unless (memq dbound Y) - (fail! S T)) + (fail! s-arr t-arr)) (cond [(< (length ss) (length ts)) ;; the hard case (let* ([vars (for/list ([n (in-range (- (length ts) (length ss)))]) @@ -251,7 +251,7 @@ [darg-mapping (move-rest-to-dmap (cgen V (cons dbound X) Y t-rest s-dty) dbound #:exact #t)] [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))])] - [(_ _) (fail! S T)])) + [(_ _) (fail! s-arr t-arr)])) ;; V : a set of variables not to mention in the constraints ;; X : the set of type variables to be constrained From 5618abb4f4e3fb061ab5ebd7225a97943623af7b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 15:02:24 -0400 Subject: [PATCH 096/198] provide more information in inference failures original commit: 8990459be69c3e720871bff23827826709990c49 --- collects/typed-scheme/infer/constraints.rkt | 4 ++-- collects/typed-scheme/infer/signatures.rkt | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/infer/constraints.rkt b/collects/typed-scheme/infer/constraints.rkt index 037fa4cd..fb504a5c 100644 --- a/collects/typed-scheme/infer/constraints.rkt +++ b/collects/typed-scheme/infer/constraints.rkt @@ -14,13 +14,13 @@ (define-values (fail-sym exn:infer?) (let ([sym (gensym 'infer-fail)]) - (values sym (lambda (s) (eq? s sym))))) + (values sym (λ (s) (and (pair? s) (eq? (car s) sym)))))) ;; why does this have to be duplicated? ;; inference failure - masked before it gets to the user program (define-syntaxes (fail!) (syntax-rules () - [(_ s t) (raise fail-sym)])) + [(_ s t) (raise (list fail-sym s t))])) ;; Widest constraint possible (define (no-constraint v) diff --git a/collects/typed-scheme/infer/signatures.rkt b/collects/typed-scheme/infer/signatures.rkt index 5286215d..962bea83 100644 --- a/collects/typed-scheme/infer/signatures.rkt +++ b/collects/typed-scheme/infer/signatures.rkt @@ -17,7 +17,7 @@ ;; inference failure - masked before it gets to the user program (define-syntaxes (fail!) (syntax-rules () - [(_ s t) (raise fail-sym)])) + [(_ s t) (raise (list fail-sym s t))])) [cnt cset-meet (cset? cset? . -> . cset?)] [cnt cset-meet* ((listof cset?) . -> . cset?)] no-constraint From da323feea336a08567a37e00c89a4874f7d56c11 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 15:59:04 -0400 Subject: [PATCH 097/198] This test case now passes. original commit: dcc8beb5cd00f6fc12c450be56b4ba83823e3898 --- .../{fail/dotted-identity.rkt => succeed/dotted-identity2.rkt} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename collects/tests/typed-scheme/{fail/dotted-identity.rkt => succeed/dotted-identity2.rkt} (100%) diff --git a/collects/tests/typed-scheme/fail/dotted-identity.rkt b/collects/tests/typed-scheme/succeed/dotted-identity2.rkt similarity index 100% rename from collects/tests/typed-scheme/fail/dotted-identity.rkt rename to collects/tests/typed-scheme/succeed/dotted-identity2.rkt From 6514ee71e1d07c97d5beaf0f9665c98ad15ba951 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 17 Jun 2010 17:20:48 -0400 Subject: [PATCH 098/198] Refactor substitution. - new file types/substitute - use structs for substitutions original commit: 44d46e4cd7ecc06a264282b31dd7ba47dee421f1 --- .../typed-scheme/unit-tests/subst-tests.rkt | 2 +- collects/typed-scheme/infer/constraints.rkt | 7 - collects/typed-scheme/infer/infer-unit.rkt | 32 ++-- collects/typed-scheme/infer/restrict.rkt | 2 +- collects/typed-scheme/typecheck/tc-app.rkt | 16 +- .../typed-scheme/typecheck/tc-structs.rkt | 4 +- collects/typed-scheme/types/substitute.rkt | 145 ++++++++++++++++++ collects/typed-scheme/types/subtype.rkt | 5 +- collects/typed-scheme/types/utils.rkt | 134 +--------------- 9 files changed, 177 insertions(+), 170 deletions(-) create mode 100644 collects/typed-scheme/types/substitute.rkt diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.rkt b/collects/tests/typed-scheme/unit-tests/subst-tests.rkt index 6bb8593c..42332056 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.rkt @@ -2,7 +2,7 @@ (require "test-utils.ss" (for-syntax scheme/base) (rep type-rep) - (types utils abbrev) + (types utils abbrev substitute) rackunit) (define-syntax-rule (s img var tgt result) diff --git a/collects/typed-scheme/infer/constraints.rkt b/collects/typed-scheme/infer/constraints.rkt index fb504a5c..444ddca9 100644 --- a/collects/typed-scheme/infer/constraints.rkt +++ b/collects/typed-scheme/infer/constraints.rkt @@ -62,13 +62,6 @@ (fail! S T)) (make-c S (or var X) T))])) -(define (subst-all/c sub -c) - (match -c - [(struct c (S X T)) - (make-c (subst-all sub S) - (F-n (subst-all sub (make-F X))) - (subst-all sub T))])) - (define (cset-meet x y) (match* (x y) [((struct cset (maps1)) (struct cset (maps2))) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 434a53ca..9b1e2108 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -5,7 +5,8 @@ (combine-in (utils tc-utils) (rep free-variance type-rep filter-rep rep-utils) - (types utils convenience union subtype remove-intersect resolve) + (types utils convenience union subtype remove-intersect resolve + substitute) (env type-name-env index-env tvar-env)) make-env -> ->* one-of/c) "constraint-structs.rkt" @@ -509,7 +510,7 @@ (cond [(not no-entry) no-entry] [(not entry) (cons v no-entry)] - [(= (length entry) 3) no-entry] + [(or (i-subst? entry) (i-subst/starred? entry) (i-subst/dotted? entry)) no-entry] [else #f])))) (and absent-entries (append @@ -518,7 +519,7 @@ (evcase var [Constant (int-err "attempted to demote dotted variable")] [Covariant (int-err "attempted to demote dotted variable")] - [Contravariant (list missing null Univ)] + [Contravariant (i-subst/starred missing null Univ)] [Invariant (int-err "attempted to demote dotted variable")]))) S))) (match (car (cset-maps C)) @@ -526,24 +527,29 @@ (let ([subst (append (for/list ([(k dc) (in-hash dm)]) (match dc + [(dcon fixed #f) + (i-subst k + (for/list ([f fixed]) + (constraint->type f idx-hash #:variable k)))] [(dcon fixed rest) - (list k - (for/list ([f fixed]) - (constraint->type f idx-hash #:variable k)) - (and rest (constraint->type rest idx-hash)))] + (i-subst/starred k + (for/list ([f fixed]) + (constraint->type f idx-hash #:variable k)) + (constraint->type rest idx-hash))] [(dcon-exact fixed rest) - (list k - (for/list ([f fixed]) - (constraint->type f idx-hash #:variable k)) - (constraint->type rest idx-hash))])) + (i-subst/starred + k + (for/list ([f fixed]) + (constraint->type f idx-hash #:variable k)) + (constraint->type rest idx-hash))])) (for/list ([(k v) (in-hash cmap)]) - (list k (constraint->type v var-hash))))]) + (t-subst k (constraint->type v var-hash))))]) ;; verify that we got all the important variables (and (for/and ([v (fv R)]) (let ([entry (assq v subst)]) ;; Make sure we got a subst entry for a type var ;; (i.e. just a type to substitute) - (and entry (= (length entry) 2)))) + (and entry (t-subst? entry)))) (extend-idxs subst)))])) ;; V : a set of variables not to mention in the constraints diff --git a/collects/typed-scheme/infer/restrict.rkt b/collects/typed-scheme/infer/restrict.rkt index b0825050..9664ee4b 100644 --- a/collects/typed-scheme/infer/restrict.rkt +++ b/collects/typed-scheme/infer/restrict.rkt @@ -2,7 +2,7 @@ (require "../utils/utils.rkt") (require (rep type-rep) - (types utils union subtype remove-intersect resolve) + (types utils union subtype remove-intersect resolve substitute) "signatures.rkt" scheme/match mzlib/trace) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 180fa36c..8b5e91c7 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -13,7 +13,7 @@ ;; end fixme (for-syntax syntax/parse scheme/base (utils tc-utils)) (private type-annotation) - (types utils abbrev union subtype resolve convenience type-table) + (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) @@ -417,16 +417,7 @@ (cons (make-ListDots tail-ty tail-bound) arg-tys) (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*)) (car rngs*))))) - => (lambda (substitution) - (define drest-bound (cdr (car drests*))) - (let ([dots-subst (assq drest-bound substitution)]) - (unless dots-subst - (int-err "expected dotted substitution for ~a" drest-bound)) - (do-ret (substitute-dotted (cadr dots-subst) - tail-bound - drest-bound - (subst-all (alist-delete drest-bound substitution eq?) - (car rngs*))))))] + => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; ... function, (List A B C etc) arg [(and (car drests*) (not tail-bound) @@ -436,8 +427,7 @@ (untuple tail-ty) (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) (car (car drests*)) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) - (define drest-bound (cdr (car drests*))) + => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index 828f36ff..5ffb450b 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" (except-in (rep type-rep free-variance) Dotted) (private parse-type) - (types convenience utils union resolve abbrev) + (types convenience utils union resolve abbrev substitute) (env global-env type-env-structs type-name-env tvar-env) (utils tc-utils) "def-binding.rkt" @@ -199,7 +199,7 @@ ;; wrap everything in the approriate forall #:wrapper (lambda (t) (make-Poly tvars t)) #:type-wrapper (lambda (t) (make-App t new-tvars #f)) - #:pred-wrapper (lambda (t) (subst-all (for/list ([t tvars]) (list t Univ)) t)) + #:pred-wrapper (lambda (t) (subst-all (for/list ([t tvars]) (t-subst t Univ)) t)) #:poly? tvars)) diff --git a/collects/typed-scheme/types/substitute.rkt b/collects/typed-scheme/types/substitute.rkt new file mode 100644 index 00000000..191833ae --- /dev/null +++ b/collects/typed-scheme/types/substitute.rkt @@ -0,0 +1,145 @@ +#lang racket/base + +(require "../utils/utils.rkt" + (rep type-rep filter-rep object-rep rep-utils) + (utils tc-utils) + (only-in (rep free-variance) combine-frees) + (env index-env tvar-env) + scheme/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)) + +(define (subst v t e) (substitute t v e)) + +(d-s/c substitution ([name symbol?])) +(d-s/c (t-subst substitution) ([type Type/c])) +(d-s/c (i-subst substitution) ([types (listof Type/c)])) +(d-s/c (i-subst/starred substitution) ([types (listof Type/c)] [starred Type/c])) +(d-s/c (i-subst/dotted substitution) ([types (listof Type/c)] [dty Type/c] [dbound symbol?])) + +;; substitute : Type Name Type -> Type +(d/c (substitute image name target #:Un [Un (get-union-maker)]) + ((Type/c symbol? Type?) (#:Un procedure?) . ->* . Type?) + (define (sb t) (substitute image name t)) + (if (hash-ref (free-vars* target) name #f) + (type-case (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb)) + target + [#:Union tys (Un (map sb tys))] + [#:F name* (if (eq? name* name) image target)] + [#:arr dom rng rest drest kws + (begin + (when (and (pair? drest) + (eq? name (cdr drest)) + (not (bound-tvar? name))) + (int-err "substitute used on ... variable ~a in type ~a" name target)) + (make-arr (map sb dom) + (sb rng) + (and rest (sb rest)) + (and drest (cons (sb (car drest)) (cdr drest))) + (map sb kws)))] + [#:ValuesDots types dty dbound + (begin + (when (and (eq? name dbound) (not (bound-tvar? name))) + (int-err "substitute used on ... variable ~a in type ~a" name target)) + (make-ValuesDots (map sb types) (sb dty) dbound))] + [#:ListDots dty dbound + (begin + (when (and (eq? name dbound) (not (bound-tvar? name))) + (int-err "substitute used on ... variable ~a in type ~a" name target)) + (make-ListDots (sb dty) dbound))]) + target)) + +;; implements angle bracket substitution from the formalism +;; substitute-dots : Listof[Type] Option[type] Name Type -> Type +(d/c (substitute-dots images rimage name target) + ((listof Type/c) (or/c #f Type/c) symbol? Type? . -> . Type?) + (define (sb t) (substitute-dots images rimage name t)) + (if (or (hash-ref (free-idxs* target) name #f) (hash-ref (free-vars* target) name #f)) + (type-case (#:Type sb #:Filter (sub-f sb)) target + [#:ListDots dty dbound + (if (eq? name dbound) + ;; 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]) + (make-Pair (substitute img name expanded) t))) + (make-ListDots (sb dty) dbound))] + [#:ValuesDots types dty dbound + (if (eq? name dbound) + (make-Values + (append + (map sb types) + ;; We need to recur first, just to expand out any dotted usages of this. + (let ([expanded (sb dty)]) + (for/list ([img images]) + (make-Result + (substitute img name expanded) + (make-FilterSet (make-Top) (make-Top)) + (make-Empty)))))) + (make-ValuesDots (map sb types) (sb dty) dbound))] + [#:arr dom rng rest drest kws + (if (and (pair? drest) + (eq? name (cdr drest))) + (make-arr (append + (map sb dom) + ;; We need to recur first, just to expand out any dotted usages of this. + (let ([expanded (sb (car drest))]) + (map (lambda (img) (substitute img name expanded)) images))) + (sb rng) + rimage + #f + (map sb kws)) + (make-arr (map sb dom) + (sb rng) + (and rest (sb rest)) + (and drest (cons (sb (car drest)) (cdr drest))) + (map sb kws)))]) + target)) + +;; implements curly brace substitution from the formalism +;; substitute-dotted : Type Name Name Type -> Type +(define (substitute-dotted image image-bound name target) + (define (sb t) (substitute-dotted image image-bound name t)) + (if (hash-ref (free-idxs* target) name #f) + (type-case (#:Type sb #:Filter (sub-f sb)) + target + [#:ValuesDots types dty dbound + (make-ValuesDots (map sb types) + (sb dty) + (if (eq? name dbound) image-bound dbound))] + [#:ListDots dty dbound + (make-ListDots (sb dty) + (if (eq? name dbound) image-bound dbound))] + [#:F name* + (if (eq? name* name) + image + target)] + [#:arr dom rng rest drest kws + (make-arr (map sb dom) + (sb rng) + (and rest (sb rest)) + (and drest + (cons (substitute image (cdr drest) (sb (car drest))) + (if (eq? name (cdr drest)) image-bound (cdr drest)))) + (map sb kws))]) + target)) + +;; substitute many variables +;; substitution = Listof[U List[Name,Type] List[Name,Listof[Type]]] +;; subst-all : substitution Type -> Type +(d/c (subst-all s t) + ((listof substitution?) Type/c . -> . Type/c) + (for/fold ([t t]) ([e s]) + (match e + [(t-subst v img) + (substitute img v t)] + [(i-subst v imgs) + (substitute-dots imgs #f v t)] + [(i-subst/starred v imgs rest) + (substitute-dots imgs rest v t)] + [(i-subst/dotted v imgs dty dbound) + (int-err "i-subst/dotted nyi") + #; + (substitute-dotted imgs rest v t)]))) \ No newline at end of file diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index 7b5d91de..86c1a983 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -2,7 +2,7 @@ (require "../utils/utils.rkt" (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) - (types utils comparison resolve abbrev) + (types utils comparison resolve abbrev substitute) (env type-name-env) (only-in (infer infer-dummy) unify) scheme/match unstable/match @@ -305,8 +305,7 @@ (=> unmatch) (unless (= (length ns) (length ms)) (unmatch)) - ;(printf "Poly: ~n~a ~n~a~n" b1 (subst-all (map list ms (map make-F ns)) b2)) - (subtype* A0 b1 (subst-all (map list ms (map make-F ns)) b2))] + (subtype* A0 b1 (subst-all (map t-subst ms (map make-F ns)) b2))] [((Refinement: par _ _) t) (subtype* A0 par t)] ;; use unification to see if we can use the polytype here diff --git a/collects/typed-scheme/types/utils.rkt b/collects/typed-scheme/types/utils.rkt index 177754a0..8e4df07c 100644 --- a/collects/typed-scheme/types/utils.rkt +++ b/collects/typed-scheme/types/utils.rkt @@ -4,6 +4,7 @@ (require (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 @@ -13,12 +14,6 @@ (for-syntax scheme/base syntax/parse)) (provide fv fv/list fi - substitute - substitute-dots - substitute-dotted - subst-all - subst - ;ret instantiate-poly instantiate-poly-dotted tc-result? @@ -33,125 +28,6 @@ current-poly-struct) -;; substitute : Type Name Type -> Type -(d/c (substitute image name target #:Un [Un (get-union-maker)]) - ((Type/c symbol? Type?) (#:Un procedure?) . ->* . Type?) - (define (sb t) (substitute image name t)) - (if (hash-ref (free-vars* target) name #f) - (type-case (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb)) - target - [#:Union tys (Un (map sb tys))] - [#:F name* (if (eq? name* name) image target)] - [#:arr dom rng rest drest kws - (begin - (when (and (pair? drest) - (eq? name (cdr drest)) - (not (bound-tvar? name))) - (int-err "substitute used on ... variable ~a in type ~a" name target)) - (make-arr (map sb dom) - (sb rng) - (and rest (sb rest)) - (and drest (cons (sb (car drest)) (cdr drest))) - (map sb kws)))] - [#:ValuesDots types dty dbound - (begin - (when (and (eq? name dbound) (not (bound-tvar? name))) - (int-err "substitute used on ... variable ~a in type ~a" name target)) - (make-ValuesDots (map sb types) (sb dty) dbound))] - [#:ListDots dty dbound - (begin - (when (and (eq? name dbound) (not (bound-tvar? name))) - (int-err "substitute used on ... variable ~a in type ~a" name target)) - (make-ListDots (sb dty) dbound))]) - target)) - -;; implements angle bracket substitution from the formalism -;; substitute-dots : Listof[Type] Option[type] Name Type -> Type -(d/c (substitute-dots images rimage name target) - ((listof Type/c) (or/c #f Type/c) symbol? Type? . -> . Type?) - (define (sb t) (substitute-dots images rimage name t)) - (if (or (hash-ref (free-idxs* target) name #f) (hash-ref (free-vars* target) name #f)) - (type-case (#:Type sb #:Filter (sub-f sb)) target - [#:ListDots dty dbound - (if (eq? name dbound) - ;; 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]) - (make-Pair (substitute img name expanded) t))) - (make-ListDots (sb dty) dbound))] - [#:ValuesDots types dty dbound - (if (eq? name dbound) - (make-Values - (append - (map sb types) - ;; We need to recur first, just to expand out any dotted usages of this. - (let ([expanded (sb dty)]) - (for/list ([img images]) - (make-Result - (substitute img name expanded) - (make-FilterSet (make-Top) (make-Top)) - (make-Empty)))))) - (make-ValuesDots (map sb types) (sb dty) dbound))] - [#:arr dom rng rest drest kws - (if (and (pair? drest) - (eq? name (cdr drest))) - (make-arr (append - (map sb dom) - ;; We need to recur first, just to expand out any dotted usages of this. - (let ([expanded (sb (car drest))]) - (map (lambda (img) (substitute img name expanded)) images))) - (sb rng) - rimage - #f - (map sb kws)) - (make-arr (map sb dom) - (sb rng) - (and rest (sb rest)) - (and drest (cons (sb (car drest)) (cdr drest))) - (map sb kws)))]) - target)) - -;; implements curly brace substitution from the formalism -;; substitute-dotted : Type Name Name Type -> Type -(define (substitute-dotted image image-bound name target) - (define (sb t) (substitute-dotted image image-bound name t)) - (if (hash-ref (free-idxs* target) name #f) - (type-case (#:Type sb #:Filter (sub-f sb)) - target - [#:ValuesDots types dty dbound - (make-ValuesDots (map sb types) - (sb dty) - (if (eq? name dbound) image-bound dbound))] - [#:ListDots dty dbound - (make-ListDots (sb dty) - (if (eq? name dbound) image-bound dbound))] - [#:F name* - (if (eq? name* name) - image - target)] - [#:arr dom rng rest drest kws - (make-arr (map sb dom) - (sb rng) - (and rest (sb rest)) - (and drest - (cons (substitute image (cdr drest) (sb (car drest))) - (if (eq? name (cdr drest)) image-bound (cdr drest)))) - (map sb kws))]) - target)) - -;; substitute many variables -;; substitution = Listof[U List[Name,Type] List[Name,Listof[Type]]] -;; subst-all : substitution Type -> Type -(define (subst-all s t) - (for/fold ([t t]) ([e s]) - (match e - [(list v (list imgs ...) starred) - (substitute-dots imgs starred v t)] - [(list v img) - (substitute img v t)]))) - - ;; unfold : Type -> Type ;; must be applied to a Mu (define (unfold t) @@ -164,13 +40,13 @@ [(Poly: ns body) (unless (= (length types) (length ns)) (int-err "instantiate-poly: wrong number of types: expected ~a, got ~a" (length ns) (length types))) - (subst-all (map list ns types) body)] + (subst-all (map t-subst ns types) body)] [(PolyDots: (list fixed ... dotted) body) (unless (>= (length types) (length fixed)) (int-err "instantiate-poly: wrong number of types: expected at least ~a, got ~a" (length fixed) (length types))) (let* ([fixed-tys (take types (length fixed))] [rest-tys (drop types (length fixed))] - [body* (subst-all (map list fixed fixed-tys) body)]) + [body* (subst-all (map t-subst fixed fixed-tys) body)]) (substitute-dots rest-tys #f dotted body*))] [_ (int-err "instantiate-poly: requires Poly type, got ~a" t)])) @@ -180,7 +56,7 @@ (unless (= (length fixed) (length types)) (int-err "instantiate-poly-dotted: wrong number of types: expected ~a, got ~a, types were ~a" (length fixed) (length types) types)) - (let ([body* (subst-all (map list fixed types) body)]) + (let ([body* (subst-all (map t-subst fixed types) body)]) (substitute-dotted image var dotted body*))] [_ (int-err "instantiate-poly-dotted: requires PolyDots type, got ~a" t)])) @@ -277,8 +153,6 @@ [(list (tc-result1: t f o) ...) (ret t f o)])) -(define (subst v t e) (substitute t v e)) - ;; type comparison From 380885f97824fc8d64cab9e427d1734204680a03 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 18 Jun 2010 15:14:42 -0400 Subject: [PATCH 099/198] Implement substitutions as hash tables from vars to subst-rhs. - add convenience function for generating substitutions - give trivial substitution for unreferenced index variables original commit: 339add9f78723fecb3e7332a8a173f615c37bc2c --- collects/typed-scheme/infer/infer-unit.rkt | 63 +++++++++++-------- collects/typed-scheme/typecheck/tc-app.rkt | 14 ++--- .../typed-scheme/typecheck/tc-structs.rkt | 7 ++- collects/typed-scheme/types/substitute.rkt | 34 ++++++---- collects/typed-scheme/types/subtype.rkt | 2 +- collects/typed-scheme/types/utils.rkt | 6 +- 6 files changed, 72 insertions(+), 54 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 9b1e2108..fe0d22f2 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -14,7 +14,7 @@ scheme/match mzlib/etc mzlib/trace racket/contract - unstable/sequence unstable/list unstable/debug + unstable/sequence unstable/list unstable/debug unstable/hash scheme/list) (import dmap^ constraints^ promote-demote^) @@ -478,7 +478,7 @@ ;; Y : (listof symbol?) - index variables that must have entries ;; R : Type? - result type into which we will be substituting (d/c (subst-gen C Y R) - (cset? (listof symbol?) Type? . -> . (or/c #f list?)) + (cset? (listof symbol?) Type? . -> . (or/c #f substitution/c)) (define var-hash (free-vars* R)) (define idx-hash (free-idxs* R)) ;; v : Symbol - variable for which to check variance @@ -499,11 +499,20 @@ ;; was found. If we're at this point and had no other constraints, then adding the ;; equivalent of the constraint (dcon null (c Bot X Top)) is okay. (define (extend-idxs S) + (define fi-R (fi R)) + ;; If the index variable v is not used in the type, then + ;; we allow it to be replaced with the empty list of types; + ;; otherwise we error, as we do not yet know what an appropriate + ;; lower bound is. + (define (demote/check-free v) + (if (memq v fi-R) + (int-err "attempted to demote dotted variable") + (i-subst null))) ;; absent-entries is #f if there's an error in the substitution, otherwise ;; it's a list of variables that don't appear in the substitution (define absent-entries (for/fold ([no-entry null]) ([v (in-list Y)]) - (let ([entry (assq v S)]) + (let ([entry (hash-ref S v #f)]) ;; Make sure we got a subst entry for an index var ;; (i.e. a list of types for the fixed portion ;; and a type for the starred portion) @@ -513,40 +522,42 @@ [(or (i-subst? entry) (i-subst/starred? entry) (i-subst/dotted? entry)) no-entry] [else #f])))) (and absent-entries - (append - (for/list ([missing (in-list absent-entries)]) + (hash-union + (for/hash ([missing (in-list absent-entries)]) (let ([var (hash-ref idx-hash missing Constant)]) - (evcase var - [Constant (int-err "attempted to demote dotted variable")] - [Covariant (int-err "attempted to demote dotted variable")] - [Contravariant (i-subst/starred missing null Univ)] - [Invariant (int-err "attempted to demote dotted variable")]))) + (values missing + (evcase var + [Constant (demote/check-free missing)] + [Covariant (demote/check-free missing)] + [Contravariant (i-subst/starred null Univ)] + [Invariant (demote/check-free missing)])))) S))) (match (car (cset-maps C)) [(cons cmap (dmap dm)) - (let ([subst (append - (for/list ([(k dc) (in-hash dm)]) + (let ([subst (hash-union + (for/hash ([(k dc) (in-hash dm)]) (match dc [(dcon fixed #f) - (i-subst k + (values k + (i-subst (for/list ([f fixed]) - (constraint->type f idx-hash #:variable k)))] + (constraint->type f idx-hash #:variable k))))] [(dcon fixed rest) - (i-subst/starred k - (for/list ([f fixed]) - (constraint->type f idx-hash #:variable k)) - (constraint->type rest idx-hash))] + (values k + (i-subst/starred (for/list ([f fixed]) + (constraint->type f idx-hash #:variable k)) + (constraint->type rest idx-hash)))] [(dcon-exact fixed rest) - (i-subst/starred - k - (for/list ([f fixed]) - (constraint->type f idx-hash #:variable k)) - (constraint->type rest idx-hash))])) - (for/list ([(k v) (in-hash cmap)]) - (t-subst k (constraint->type v var-hash))))]) + (values k + (i-subst/starred + (for/list ([f fixed]) + (constraint->type f idx-hash #:variable k)) + (constraint->type rest idx-hash)))])) + (for/hash ([(k v) (in-hash cmap)]) + (values k (t-subst (constraint->type v var-hash)))))]) ;; verify that we got all the important variables (and (for/and ([v (fv R)]) - (let ([entry (assq v subst)]) + (let ([entry (hash-ref subst v #f)]) ;; Make sure we got a subst entry for a type var ;; (i.e. just a type to substitute) (and entry (t-subst? entry)))) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 8b5e91c7..e4bc51ec 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -360,6 +360,7 @@ (values tail-ty tail-bound)] [t (values t #f)])]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) + (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)))) @@ -378,7 +379,7 @@ (car doms*)) (car rests*) (car rngs*))) - => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] + => finish] ;; actual work, when we have a * function and ... final arg [(and (car rests*) tail-bound @@ -390,8 +391,7 @@ (car doms*)) (car rests*) (car rngs*))) - => (lambda (substitution) - (do-ret (subst-all substitution (car rngs*))))] + => finish] ;; ... function, ... arg, same bound on ... [(and (car drests*) tail-bound @@ -402,8 +402,7 @@ (cons (make-ListDots tail-ty tail-bound) arg-tys) (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*)) (car rngs*))) - => (lambda (substitution) - (do-ret (subst-all substitution (car rngs*))))] + => finish] ;; ... function, ... arg, different bound on ... [(and (car drests*) tail-bound @@ -417,7 +416,7 @@ (cons (make-ListDots tail-ty tail-bound) arg-tys) (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*)) (car rngs*))))) - => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] + => finish] ;; ... function, (List A B C etc) arg [(and (car drests*) (not tail-bound) @@ -427,8 +426,7 @@ (untuple tail-ty) (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) (car (car drests*)) (car rngs*) (fv (car rngs*)))) - => (lambda (substitution) - (do-ret (subst-all substitution (car rngs*))))] + => finish] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [(tc-result1: (PolyDots: vars (Function: '()))) diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index 5ffb450b..45c3a446 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -11,6 +11,7 @@ syntax/struct mzlib/trace unstable/debug + racket/function scheme/match (for-syntax scheme/base)) @@ -197,9 +198,9 @@ ;; then register them (mk/register-sty nm flds parent-name parent-field-types types ;; wrap everything in the approriate forall - #:wrapper (lambda (t) (make-Poly tvars t)) - #:type-wrapper (lambda (t) (make-App t new-tvars #f)) - #:pred-wrapper (lambda (t) (subst-all (for/list ([t tvars]) (t-subst t Univ)) t)) + #:wrapper (λ (t) (make-Poly tvars t)) + #:type-wrapper (λ (t) (make-App t new-tvars #f)) + #:pred-wrapper (λ (t) (subst-all (make-simple-substitution tvars (map (const Univ) tvars)) t)) #:poly? tvars)) diff --git a/collects/typed-scheme/types/substitute.rkt b/collects/typed-scheme/types/substitute.rkt index 191833ae..873b9236 100644 --- a/collects/typed-scheme/types/substitute.rkt +++ b/collects/typed-scheme/types/substitute.rkt @@ -9,15 +9,23 @@ 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)) + (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-s/c substitution ([name symbol?])) -(d-s/c (t-subst substitution) ([type Type/c])) -(d-s/c (i-subst substitution) ([types (listof Type/c)])) -(d-s/c (i-subst/starred substitution) ([types (listof Type/c)] [starred Type/c])) -(d-s/c (i-subst/dotted substitution) ([types (listof Type/c)] [dty Type/c] [dbound symbol?])) +(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 ()) +(d-s/c (t-subst subst-rhs) ([type Type/c])) +(d-s/c (i-subst subst-rhs) ([types (listof Type/c)])) +(d-s/c (i-subst/starred subst-rhs) ([types (listof Type/c)] [starred Type/c])) +(d-s/c (i-subst/dotted subst-rhs) ([types (listof Type/c)] [dty Type/c] [dbound symbol?])) + +(define substitution/c (hash/c symbol? subst-rhs? #:immutable #t)) ;; substitute : Type Name Type -> Type (d/c (substitute image name target #:Un [Un (get-union-maker)]) @@ -130,16 +138,16 @@ ;; substitution = Listof[U List[Name,Type] List[Name,Listof[Type]]] ;; subst-all : substitution Type -> Type (d/c (subst-all s t) - ((listof substitution?) Type/c . -> . Type/c) - (for/fold ([t t]) ([e s]) - (match e - [(t-subst v img) + (substitution/c Type? . -> . Type?) + (for/fold ([t t]) ([(v r) s]) + (match r + [(t-subst img) (substitute img v t)] - [(i-subst v imgs) + [(i-subst imgs) (substitute-dots imgs #f v t)] - [(i-subst/starred v imgs rest) + [(i-subst/starred imgs rest) (substitute-dots imgs rest v t)] - [(i-subst/dotted v imgs dty dbound) + [(i-subst/dotted imgs dty dbound) (int-err "i-subst/dotted nyi") #; (substitute-dotted imgs rest v t)]))) \ No newline at end of file diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index 86c1a983..fde4c808 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -305,7 +305,7 @@ (=> unmatch) (unless (= (length ns) (length ms)) (unmatch)) - (subtype* A0 b1 (subst-all (map t-subst ms (map make-F ns)) b2))] + (subtype* A0 b1 (subst-all (make-simple-substitution ms (map make-F ns)) b2))] [((Refinement: par _ _) t) (subtype* A0 par t)] ;; use unification to see if we can use the polytype here diff --git a/collects/typed-scheme/types/utils.rkt b/collects/typed-scheme/types/utils.rkt index 8e4df07c..af9780bf 100644 --- a/collects/typed-scheme/types/utils.rkt +++ b/collects/typed-scheme/types/utils.rkt @@ -40,13 +40,13 @@ [(Poly: ns body) (unless (= (length types) (length ns)) (int-err "instantiate-poly: wrong number of types: expected ~a, got ~a" (length ns) (length types))) - (subst-all (map t-subst ns types) body)] + (subst-all (make-simple-substitution ns types) body)] [(PolyDots: (list fixed ... dotted) body) (unless (>= (length types) (length fixed)) (int-err "instantiate-poly: wrong number of types: expected at least ~a, got ~a" (length fixed) (length types))) (let* ([fixed-tys (take types (length fixed))] [rest-tys (drop types (length fixed))] - [body* (subst-all (map t-subst fixed fixed-tys) body)]) + [body* (subst-all (make-simple-substitution fixed fixed-tys) body)]) (substitute-dots rest-tys #f dotted body*))] [_ (int-err "instantiate-poly: requires Poly type, got ~a" t)])) @@ -56,7 +56,7 @@ (unless (= (length fixed) (length types)) (int-err "instantiate-poly-dotted: wrong number of types: expected ~a, got ~a, types were ~a" (length fixed) (length types) types)) - (let ([body* (subst-all (map t-subst fixed types) body)]) + (let ([body* (subst-all (make-simple-substitution fixed types) body)]) (substitute-dotted image var dotted body*))] [_ (int-err "instantiate-poly-dotted: requires PolyDots type, got ~a" t)])) From c925e90dc609918be9bd7feb4fc84636791bed30 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 18 Jun 2010 15:22:59 -0400 Subject: [PATCH 100/198] Add fixed part to dcon-dotted. original commit: 3f7ca52e370dfa0b81b5c9955c785bd429cda3d8 --- .../typed-scheme/infer/constraint-structs.rkt | 3 ++- collects/typed-scheme/infer/dmap.rkt | 9 ++++++--- collects/typed-scheme/infer/infer-unit.rkt | 17 ----------------- 3 files changed, 8 insertions(+), 21 deletions(-) diff --git a/collects/typed-scheme/infer/constraint-structs.rkt b/collects/typed-scheme/infer/constraint-structs.rkt index 4ad2c0c2..82e65033 100644 --- a/collects/typed-scheme/infer/constraint-structs.rkt +++ b/collects/typed-scheme/infer/constraint-structs.rkt @@ -18,9 +18,10 @@ ;; rest : c (d-s/c dcon-exact ([fixed (listof c?)] [rest c?]) #:transparent) +;; fixed : Listof[c] ;; type : c ;; bound : var -(d-s/c dcon-dotted ([type c?] [bound symbol?]) #:transparent) +(d-s/c dcon-dotted ([fixed (listof c?)] [type c?] [bound symbol?]) #:transparent) (define dcon/c (or/c dcon? dcon-exact? dcon-dotted?)) diff --git a/collects/typed-scheme/infer/dmap.rkt b/collects/typed-scheme/infer/dmap.rkt index 6f613748..c76702bf 100644 --- a/collects/typed-scheme/infer/dmap.rkt +++ b/collects/typed-scheme/infer/dmap.rkt @@ -52,10 +52,13 @@ [c2 (in-sequence-forever shorter srest)]) (c-meet c1 c2 (c-X c1))) (c-meet lrest srest (c-X lrest))))] - [((struct dcon-dotted (c1 bound1)) (struct dcon-dotted (c2 bound2))) - (unless (eq? bound1 bound2) + [((struct dcon-dotted (fixed1 c1 bound1)) (struct dcon-dotted (fixed2 c2 bound2))) + (unless (and (= (length fixed1) (length fixed2)) + (eq? bound1 bound2)) (fail! bound1 bound2)) - (make-dcon-dotted (c-meet c1 c2 bound1) bound1)] + (make-dcon-dotted (for/list ([c1 fixed1] [c2 fixed2]) + (c-meet c1 c2 (c-X c1))) + (c-meet c1 c2 bound1) bound1)] [((struct dcon _) (struct dcon-dotted _)) (fail! dc1 dc2)] [((struct dcon-dotted _) (struct dcon _)) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index fe0d22f2..fbb408e6 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -29,23 +29,6 @@ (define (seen? s t) (member (seen-before s t) (current-seen))) -(define (dmap-constraint dmap dbound v) - (let ([dc (hash-ref dmap dbound #f)]) - (match dc - [(struct dcon (fixed #f)) - (if (eq? dbound v) - (no-constraint v) - (hash-ref fixed v (no-constraint v)))] - [(struct dcon (fixed rest)) - (if (eq? dbound v) - rest - (hash-ref fixed v (no-constraint v)))] - [(struct dcon-dotted (type bound)) - (if (eq? bound v) - type - (no-constraint v))] - [_ (no-constraint v)]))) - (define (map/cset f cset) (make-cset (for/list ([(cmap dmap) (in-pairs (cset-maps cset))]) (f cmap dmap)))) From a49d4de0ba797b9c1048afb9648846d5eecd80b7 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 18 Jun 2010 15:26:24 -0400 Subject: [PATCH 101/198] Take dcon-dotteds and create an appropriate i-subst/dotted entry. original commit: 9c22701bd3a0178470e736b51c1c6c863ebd08d6 --- collects/typed-scheme/infer/infer-unit.rkt | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index fbb408e6..a07f1ec4 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -535,7 +535,14 @@ (i-subst/starred (for/list ([f fixed]) (constraint->type f idx-hash #:variable k)) - (constraint->type rest idx-hash)))])) + (constraint->type rest idx-hash)))] + [(dcon-dotted fixed dc dbound) + (values k + (i-subst/dotted + (for/list ([f fixed]) + (constraint->type f idx-hash #:variable k)) + (constraint->type dc idx-hash #:variable k) + dbound))])) (for/hash ([(k v) (in-hash cmap)]) (values k (t-subst (constraint->type v var-hash)))))]) ;; verify that we got all the important variables From e73d9f5ee8ef2879fc7c48e22c1d74935df7f573 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 18 Jun 2010 16:02:49 -0400 Subject: [PATCH 102/198] Generate dcon-dotted, and substitute for them. - generated only in the case where we have two ListDots or two ValuesDots - or when -> with the same bound, and fixed argument lengts are identical - currently errors if there are any 'fixed' portions original commit: 034b22d01401bba31f700dd5cb38fcf731ed64be --- collects/typed-scheme/infer/infer-unit.rkt | 48 ++++++++++++++++++++-- collects/typed-scheme/types/substitute.rkt | 2 + 2 files changed, 46 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index a07f1ec4..2ae4d286 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -76,6 +76,19 @@ (hash-ref cmap dbound (λ () (int-err "No constraint for bound ~a" dbound))))))) +;; dbound : index variable +;; cset : the constraints being manipulated +;; +(d/c (move-dotted-rest-to-dmap cset dbound) + (cset? symbol? . -> . cset?) + (mover cset dbound null + (λ (cmap dmap) + (make-dcon-dotted + null + (hash-ref cmap dbound + (λ () (int-err "No constraint for bound ~a" dbound))) + dbound)))) + ;; This one's weird, because the way we set it up, the rest is already in the dmap. ;; This is because we create all the vars, then recall cgen/arr with the new vars ;; in place, and the "simple" case will then call move-rest-to-dmap. This means @@ -186,13 +199,22 @@ (cset-meet* (list arg-mapping darg-mapping ret-mapping)))] ;; bounds are different - [((arr: ss s #f (cons s-dty dbound) '()) + [((arr: ss s #f (cons s-dty (? (λ (db) (memq db Y)) dbound)) '()) (arr: ts t #f (cons t-dty dbound*) '())) - (unless (= (length ss) (length ts)) - (fail! ss ts)) + (unless (= (length ss) (length ts)) (fail! ss ts)) + (when (memq dbound* Y) (fail! s-arr t-arr)) (let* ([arg-mapping (cgen/list V X Y ts ss)] ;; just add dbound as something that can be constrained - [darg-mapping (cgen V (cons dbound X) Y t-dty s-dty)] + [darg-mapping (move-dotted-rest-to-dmap (cgen V (cons dbound X) Y t-dty s-dty) dbound)] + [ret-mapping (cg s t)]) + (cset-meet* + (list arg-mapping darg-mapping ret-mapping)))] + [((arr: ss s #f (cons s-dty dbound) '()) + (arr: ts t #f (cons t-dty (? (λ (db) (memq db Y)) dbound*)) '())) + (unless (= (length ss) (length ts)) (fail! ss ts)) + (let* ([arg-mapping (cgen/list V X Y ts ss)] + ;; just add dbound as something that can be constrained + [darg-mapping (move-dotted-rest-to-dmap (cgen V (cons dbound* X) Y t-dty s-dty) dbound*)] [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))] @@ -354,6 +376,13 @@ [((ListDots: s-dty dbound) (ListDots: t-dty dbound)) (when (memq dbound Y) (fail! S T)) (cgen V X Y s-dty t-dty)] + [((ListDots: s-dty (? (λ (db) (memq db Y)) s-dbound)) (ListDots: t-dty t-dbound)) + ;; What should we do if both are in Y? + (when (memq t-dbound Y) (fail! S T)) + (move-dotted-rest-to-dmap (cgen V (cons s-dbound X) Y s-dty t-dty) s-dbound)] + [((ListDots: s-dty s-dbound) (ListDots: t-dty (? (λ (db) (memq db Y)) t-dbound))) + ;; s-dbound can't be in Y, due to previous rule + (move-dotted-rest-to-dmap (cgen V (cons t-dbound X) Y s-dty t-dty) t-dbound)] ;; this constrains `dbound' to be |ts| - |ss| [((ListDots: s-dty dbound) (List: ts)) @@ -408,6 +437,17 @@ [((ValuesDots: ss s-dty dbound) (ValuesDots: ts t-dty dbound)) (when (memq dbound Y) (fail! ss ts)) (cgen/list V X Y (cons s-dty ss) (cons t-dty ts))] + [((ValuesDots: ss s-dty (? (λ (db) (memq db Y)) s-dbound)) (ValuesDots: ts t-dty t-dbound)) + ;; What should we do if both are in Y? + (when (memq t-dbound Y) (fail! S T)) + (cset-meet + (cgen/list V X Y ss ts) + (move-dotted-rest-to-dmap (cgen V (cons s-dbound X) Y s-dty t-dty) s-dbound))] + [((ValuesDots: ss s-dty s-dbound) (ValuesDots: ts t-dty (? (λ (db) (memq db Y)) t-dbound))) + ;; s-dbound can't be in Y, due to previous rule + (cset-meet + (cgen/list V X Y ss ts) + (move-dotted-rest-to-dmap (cgen V (cons t-dbound X) Y s-dty t-dty) t-dbound))] ;; vectors are invariant - generate constraints *both* ways [((Vector: e) (Vector: e*)) (cset-meet (cg e e*) (cg e* e))] diff --git a/collects/typed-scheme/types/substitute.rkt b/collects/typed-scheme/types/substitute.rkt index 873b9236..20d5659b 100644 --- a/collects/typed-scheme/types/substitute.rkt +++ b/collects/typed-scheme/types/substitute.rkt @@ -147,6 +147,8 @@ (substitute-dots imgs #f v t)] [(i-subst/starred imgs rest) (substitute-dots imgs rest v t)] + [(i-subst/dotted null dty dbound) + (substitute-dotted dty dbound v t)] [(i-subst/dotted imgs dty dbound) (int-err "i-subst/dotted nyi") #; From 84247a1882862df39f66c4eb944e994839d3f15b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 21 Jun 2010 17:37:47 -0400 Subject: [PATCH 103/198] allow optional specifcation of var pattern original commit: b8777d20b26837d8ecfa78eeeda25fdccdb4a783 --- collects/typed-scheme/types/abbrev.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index c2608c17..0ab61f3d 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -58,8 +58,8 @@ (define-match-expander Listof: (lambda (stx) (syntax-parse stx - [(_ elem-pat) - #'(Mu: var (Union: (list (Value: '()) (Pair: elem-pat (F: var)))))]))) + [(_ elem-pat (~optional var-pat #:defaults ([var-pat #'var]))) + (syntax/loc stx (Mu: var-pat (Union: (list (Value: '()) (Pair: elem-pat (F: var-pat))))))]))) (define-match-expander List: (lambda (stx) From f50aa4917a38783e502ce405a96b5aeea575bec6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 21 Jun 2010 17:38:05 -0400 Subject: [PATCH 104/198] support `map' over multiple ListDots with the same bound - also support ListDots + Listof (map errors when not same length) original commit: 0c7c722e16cd9f6e3e88deaa45cb681337021078 --- .../tests/typed-scheme/succeed/list-dots.rkt | 14 +++++++++++ collects/typed-scheme/typecheck/tc-app.rkt | 25 ++++++++++++------- 2 files changed, 30 insertions(+), 9 deletions(-) diff --git a/collects/tests/typed-scheme/succeed/list-dots.rkt b/collects/tests/typed-scheme/succeed/list-dots.rkt index 83ed511b..1c19fff0 100644 --- a/collects/tests/typed-scheme/succeed/list-dots.rkt +++ b/collects/tests/typed-scheme/succeed/list-dots.rkt @@ -1,5 +1,7 @@ #lang typed/racket +;; tests for the new iteration of ... + (: f (All (a ...) ((List a ...) -> (List a ... a)))) (define (f x) x) @@ -19,3 +21,15 @@ (: h4 (All (a ...) (a ... -> Number))) (define (h4 . x) (length x)) + +(: i (All (a ...) (List a ...) (a ... -> Number) -> Number)) +(define (i xs f) (apply f xs)) + +(: i2 (All (a ...) (List a ...) (Any * -> Number) -> Number)) +(define (i2 xs f) (apply f xs)) + +(: i3 (All (a ...) (List a ...) (List a ...) ((Pairof a a) ... -> Number) -> Number)) +(define (i3 xs ys f) (apply f (map cons xs ys))) + +(: i4 (All (a ...) (List a ...) (Listof Number) ((Pairof a Number) ... -> Number) -> Number)) +(define (i4 xs ys f) (apply f (map cons xs ys))) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index e4bc51ec..07a57c68 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -625,21 +625,28 @@ (check-do-make-object #'cl #'args #'() #'())] [(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...)) (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))] - [(#%plain-app (~literal map) f arg) - (match (single-value #'arg) + [(#%plain-app (~literal map) f arg0 arg ...) + (match* ((single-value #'arg0) (map single-value (syntax->list #'(arg ...)))) ;; if the argument is a ListDots - [(tc-result1: (ListDots: t bound)) - - (match (extend-tvars (list bound) + [((tc-result1: (ListDots: t0 bound0)) + (list (tc-result1: (or (and (ListDots: t bound) (app (λ _ #f) var)) + ;; a devious hack - just generate #f so the test below succeeds + ;; have to explicitly bind `var' since otherwise `var' appears on only one side of the or + ;; NOTE: safe to include these, `map' will error if any list is not the same length as all the others + (and (Listof: t var) (app (λ _ #f) bound)))) + ...)) + (=> fail) + (unless (for/and ([b bound]) (or (not b) (eq? bound0 b))) (fail)) + (match (extend-tvars (list bound0) ;; just check that the function applies successfully to the element type - (tc/funapp #'f #'(arg) (tc-expr #'f) (list (ret t)) expected)) - [(tc-result1: t) (ret (make-ListDots t bound))] + (tc/funapp #'f #'(arg0 arg ...) (tc-expr #'f) (cons (ret t0) (map ret t)) expected)) + [(tc-result1: t) (ret (make-ListDots t bound0))] [(tc-results: ts) (tc-error/expr #:return (ret (Un)) "Expected one value, but got ~a" (-values ts))])] ;; otherwise, if it's not a ListDots, defer to the regular function typechecking - [res - (tc/funapp #'map #'(f arg) (single-value #'map) (list (tc-expr #'f) res) expected)])] + [(res0 res) + (tc/funapp #'map #'(f arg0 arg ...) (single-value #'map) (list* (tc-expr #'f) res0 res) expected)])] ;; ormap/andmap of ... argument [(#%plain-app (~and fun (~or (~literal andmap) (~literal ormap))) f arg) ;; check the arguments From eb621217bcb0e0ff3311c772cb3bb19d7536c890 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 21 Jun 2010 17:55:35 -0400 Subject: [PATCH 105/198] Docs for List x ... original commit: 4df7d09ef1933fc128737ad3d29b61428d80b70b --- collects/typed-scheme/scribblings/ts-reference.scrbl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index f7cc38cd..43b7cb40 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -123,6 +123,10 @@ The following base types are parameteric in their type arguments. @defform[(Listof t)]{Homogenous @rtech{lists} of @racket[t]} @defform[(List t ...)]{is the type of the list with one element, in order, for each type provided to the @racket[List] type constructor.} +@defform/none[(#,(racket List) t ... trest #,(racket ...) bound)]{is the type of a list with +one element for each of the @racket[t]s, plus a sequence of elements +corresponding to @racket[trest], where @racket[bound] + must be an identifier denoting a type variable bound with @racket[...].} @ex[ (list 'a 'b 'c) @@ -179,7 +183,7 @@ The following base types are parameteric in their type arguments. @defform*[#:id -> #:literals (* ...) [(dom ... -> rng) (dom ... rest * -> rng) - (dom ... rest ... bound -> rng) + (dom ... rest #,(racket ...) bound -> rng) (dom -> rng : pred)]]{is the type of functions from the (possibly-empty) sequence @racket[dom ...] to the @racket[rng] type. The second form specifies a uniform rest argument of type @racket[rest], and the From 0bf7faa4fa5e8abb707072914eadbd127113d2ba Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 22 Jun 2010 10:11:14 -0400 Subject: [PATCH 106/198] Initialize `infer' for tests original commit: 95c5f942e6854e1d066b7627b2f65097e14e24b9 --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 25a881d3..a9014746 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -15,7 +15,8 @@ [true-lfilter -true-lfilter] [true-filter -true-filter] [-> t:->]) - (utils tc-utils utils) + (except-in (utils tc-utils utils) infer) + typed-scheme/infer/infer-dummy typed-scheme/infer/infer unstable/mutated-vars (env type-name-env type-env-structs init-envs) rackunit rackunit/text-ui @@ -63,6 +64,7 @@ #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] [custom-printer #t] + [infer-param infer] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) (parameterize ([mutated-vars (find-mutated-vars ex)]) @@ -74,6 +76,7 @@ #`(parameterize ([delay-errors? #f] [current-namespace (namespace-anchor->namespace anch)] [custom-printer #t] + [infer-param infer] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) (parameterize ([mutated-vars (find-mutated-vars ex)]) From b718e6046981395af3b3a40d9a9272591f0b81a7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 22 Jun 2010 10:12:54 -0400 Subject: [PATCH 107/198] Typecheck `map' expression, not just #'map. original commit: bce2cedf3864166c137ef91ca3f79f45fb6745da --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 2 ++ collects/typed-scheme/typecheck/tc-app.rkt | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index a9014746..34776dee 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -824,6 +824,8 @@ x (lambda (z) (eq? x z)))) (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)] ) (test-suite "check-type tests" diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 07a57c68..af8a9053 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -625,7 +625,7 @@ (check-do-make-object #'cl #'args #'() #'())] [(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...)) (check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))] - [(#%plain-app (~literal map) f arg0 arg ...) + [(#%plain-app (~and map-expr (~literal map)) f arg0 arg ...) (match* ((single-value #'arg0) (map single-value (syntax->list #'(arg ...)))) ;; if the argument is a ListDots [((tc-result1: (ListDots: t0 bound0)) @@ -646,7 +646,7 @@ "Expected one value, but got ~a" (-values ts))])] ;; otherwise, if it's not a ListDots, defer to the regular function typechecking [(res0 res) - (tc/funapp #'map #'(f arg0 arg ...) (single-value #'map) (list* (tc-expr #'f) res0 res) expected)])] + (tc/funapp #'map-expr #'(f arg0 arg ...) (single-value #'map-expr) (list* (tc-expr #'f) res0 res) expected)])] ;; ormap/andmap of ... argument [(#%plain-app (~and fun (~or (~literal andmap) (~literal ormap))) f arg) ;; check the arguments From 8869cd4d22f10114faf5ee249943728d9d2e8037 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 22 Jun 2010 13:42:10 -0400 Subject: [PATCH 108/198] Add `struct:' original commit: 6e1954d79b520fefd21abe81d06fe615e056ac93 --- .../typed-scheme/succeed/racket-struct.rkt | 7 ++ collects/typed-scheme/private/prims.rkt | 87 +++++++++++++------ .../scribblings/ts-reference.scrbl | 20 ++++- .../typed-scheme/typecheck/tc-structs.rkt | 3 +- .../typed-scheme/typecheck/tc-toplevel.rkt | 10 +++ 5 files changed, 95 insertions(+), 32 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/racket-struct.rkt diff --git a/collects/tests/typed-scheme/succeed/racket-struct.rkt b/collects/tests/typed-scheme/succeed/racket-struct.rkt new file mode 100644 index 00000000..354a6698 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/racket-struct.rkt @@ -0,0 +1,7 @@ +#lang typed/racket + +(struct: x ([y : Number])) + +(x 1) +(x-y (x 7)) +(ann x? (Any -> Boolean : x)) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index 4905f204..a1ae9550 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -26,6 +26,7 @@ This file defines two sorts of primitives. All of them are provided into any mod [define-typed-struct/exec define-struct/exec:])) (require "../utils/utils.rkt" + racket/base (for-syntax syntax/parse syntax/private/util @@ -296,31 +297,64 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-typed-struct-internal (vars ...) #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))])) -(define-syntax (define-typed-struct stx) - (define-syntax-class fld-spec - #:literals (:) - #:description "[field-name : type]" - (pattern [fld:id : ty])) - (define-syntax-class struct-name - #:description "struct name (with optional super-struct name)" - #:attributes (name super) - (pattern (name:id super:id)) - (pattern name:id - #:with super #f)) - (syntax-parse stx - [(_ nm:struct-name (fs:fld-spec ...) . opts) - (let ([mutable (if (memq '#:mutable (syntax->datum #'opts)) - '(#:mutable) - '())]) - (with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts)) - 'typechecker:ignore #t)] - [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))])) +(define-syntaxes (define-typed-struct struct:) + (let () + (define-syntax-class fld-spec + #:literals (:) + #:description "[field-name : type]" + (pattern [fld:id : ty])) + (define-syntax-class struct-name + #:description "struct name (with optional super-struct name)" + #:attributes (name super) + (pattern (name:id super:id)) + (pattern name:id + #:with super #f)) + (define-splicing-syntax-class struct-name/new + #:description "struct name (with optional super-struct name)" + (pattern (~seq name:id super:id) + #:attr old-spec #'(name super) + #:with new-spec #'(name super)) + (pattern name:id + #:with super #f + #:attr old-spec #'name + #:with new-spec #'(name))) + (define (mutable? opts) + (if (memq '#:mutable (syntax->datum opts)) '(#:mutable) '())) + (values + (lambda (stx) + (syntax-parse stx + [(_ nm:struct-name (fs:fld-spec ...) . opts) + (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* () 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))])) + (lambda (stx) + (syntax-parse stx + [(_ nm:struct-name/new (fs:fld-spec ...) . opts) + (let ([mutable (mutable? #'opts)] + [cname (datum->syntax #f (syntax-e #'nm.name))]) + (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* () 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))]) + (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))]) + #'(begin d-s dtsi)))]))))) (define-syntax (require-typed-struct stx) (syntax-parse stx #:literals (:) @@ -347,8 +381,7 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ (nm parent) ([fld : ty] ...) lib) (and (identifier? #'nm) (identifier? #'parent)) (with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)] - [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))] - #;[(parent-tys ...) (Struct-flds (parse-type #'parent))]) + [(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]) #`(begin (require (only-in lib struct-info)) (define-syntax nm (make-struct-info diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 43b7cb40..8d8ae382 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -367,14 +367,26 @@ types. In most cases, use of @racket[:] is preferred to use of @racket[define:] @subsection{Structure Definitions} @defform/subs[ -(define-struct: maybe-type-vars name-spec ([f : t] ...)) +(struct: maybe-type-vars name-spec ([f : t] ...) options ...) ([maybe-type-vars code:blank (v ...)] - [name-spec name (name parent)])]{ + [name-spec name (code:line name parent)] + [options #:transparent #:mutable])]{ Defines a @rtech{structure} with the name @racket[name], where the - fields @racket[f] have types @racket[t]. When @racket[parent], the + fields @racket[f] have types @racket[t], similar to the behavior of @racket[struct]. + When @racket[parent] is present, the structure is a substructure of @racket[parent]. When @racket[maybe-type-vars] is present, the structure is polymorphic in the type - variables @racket[v].} + variables @racket[v]. + +Options provided have the same meaning as for the @racket[struct] form.} + + +@defform/subs[ +(define-struct: maybe-type-vars name-spec ([f : t] ...) options ...) +([maybe-type-vars code:blank (v ...)] + [name-spec name (name parent)] + [options #:transparent #:mutable])]{Legacy version of @racket[struct:], +corresponding to @racket[define-struct].} @defform/subs[ (define-struct/exec: name-spec ([f : t] ...) [e : proc-t]) diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index 45c3a446..66ddbb10 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -173,7 +173,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) +(define (tc/poly-struct vars nm/par flds tys #:maker [maker #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 @@ -197,6 +197,7 @@ ;; that the outside world will see ;; then register them (mk/register-sty nm flds parent-name parent-field-types types + #:maker maker ;; 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-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index 03569cac..e970654b 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -94,6 +94,16 @@ (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)] + [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) + #:maker m)) + (#%plain-app values))) + (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) + #:maker #'m)] + [(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 nm ([fld : ty] ...) #:type-only)) (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)] From 0f27106fdd245d8ba666f126b3b94940c5e0c876 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 21 Jun 2010 12:24:03 -0400 Subject: [PATCH 109/198] Made make-vector's type more convenient. original commit: 61545c4e75795adbdd951ed94fb6274a1a7b9709 --- collects/typed-scheme/private/base-env-indexing-abs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index e2e73e9b..75616876 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -135,7 +135,7 @@ [build-vector (-poly (a) (index-type (index-type . -> . a) . -> . (-vec a)))] [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 -Nat)] + [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Nat a))] [(index-type a) (-vec a)]))] [peek-char From 1cf790fc868e463f121d134ebeeda5538627a1d9 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 21 Jun 2010 16:01:40 -0400 Subject: [PATCH 110/198] Fixed the types of flvector operations. original commit: 192c1fa995f44163d42e46f2466bdd05e74a98a8 --- collects/typed-scheme/private/base-env-numeric.rkt | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 7d6aa00a..dd708b0b 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -318,13 +318,14 @@ [flvector? (make-pred-ty -FlVector)] [flvector (->* (list) -Flonum -FlVector)] -[make-flvector (-> -Nat -Flonum -FlVector)] +[make-flvector (cl->* (-> -Integer -FlVector) + (-> -Integer -Flonum -FlVector))] [flvector-length (-> -FlVector -Nat)] -[flvector-ref (-> -FlVector -Nat -Flonum)] -[flvector-set! (-> -FlVector -Nat -Flonum -Void)] +[flvector-ref (-> -FlVector -Integer -Flonum)] +[flvector-set! (-> -FlVector -Integer -Flonum -Void)] ;; unsafe flvector ops [unsafe-flvector-length (-> -FlVector -Nat)] -[unsafe-flvector-ref (-> -FlVector -Nat -Flonum)] -[unsafe-flvector-set! (-> -FlVector -Nat -Flonum -Void)] +[unsafe-flvector-ref (-> -FlVector -Integer -Flonum)] +[unsafe-flvector-set! (-> -FlVector -Integer -Flonum -Void)] From 8dc90d067baa74e3b298bb67053fe825445e0b31 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 21 Jun 2010 17:49:16 -0400 Subject: [PATCH 111/198] Moved the types for some byte string operations to base-env-indexing-abs.rkt. original commit: eea31102b015d77ee989dfb0951729b3f1bfa313 --- .../private/base-env-indexing-abs.rkt | 19 +++++++++++++++++++ collects/typed-scheme/private/base-env.rkt | 16 +--------------- 2 files changed, 20 insertions(+), 15 deletions(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index 75616876..5e451994 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -137,6 +137,25 @@ [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))] [(index-type a) (-vec a)]))] + + [bytes-ref (-> -Bytes index-type -Nat)] + [unsafe-bytes-ref (-> -Bytes index-type -Nat)] + [bytes-set! (-> -Bytes index-type index-type -Void)] + [unsafe-bytes-set! (-> -Bytes index-type index-type -Void)] + [subbytes (cl-> [(-Bytes index-type) -Bytes] [(-Bytes index-type index-type) -Bytes])] + [bytes-copy! (-Bytes index-type -Bytes [index-type index-type] . ->opt . -Void)] + [bytes-fill! (-> -Bytes index-type -Void)] + [bytes->string/utf-8 (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -String)] + [bytes->string/locale (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -String)] + [bytes->string/latin-1 (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -String)] + [string->bytes/utf-8 (-String [(Un (-val #f) index-type) index-type index-type] . ->opt . -Bytes)] + [string->bytes/locale (-String [(Un (-val #f) index-type) index-type index-type] . ->opt . -Bytes)] + [string->bytes/latin-1 (-String [(Un (-val #f) index-type) index-type index-type] . ->opt . -Bytes)] + [string-utf-8-length (-String [index-type index-type] . ->opt . -Nat)] + [bytes-utf-8-length (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -Nat)] + [bytes-utf-8-ref (-Bytes [index-type (Un (-val #f) -Char) index-type index-type] . ->opt . -Char)] + [bytes-utf-8-index (-Bytes [index-type (Un (-val #f) -Char) index-type index-type] . ->opt . -Nat)] + [peek-char (cl->* [->opt [-Input-Port index-type] (Un -Char (-val eof))])] diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 140ec67a..27a7bdc9 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -564,30 +564,16 @@ [(-Integer) -Bytes])] [bytes->immutable-bytes (-> -Bytes -Bytes)] [byte? (make-pred-ty -Nat)] -[bytes-ref (-> -Bytes -Integer -Nat)] -[bytes-set! (-> -Bytes -Integer -Integer -Void)] [bytes-append (->* (list) -Bytes -Bytes)] -[subbytes (cl-> [(-Bytes -Integer) -Bytes] [(-Bytes -Integer -Integer) -Bytes])] [bytes-length (-> -Bytes -Nat)] +[unsafe-bytes-length (-> -Bytes -Nat)] [bytes-copy (-> -Bytes -Bytes)] -[bytes-copy! (-Bytes -Integer -Bytes [-Integer -Integer] . ->opt . -Void)] -[bytes-fill! (-> -Bytes -Integer -Void)] [unsafe-bytes-length (-> -Bytes -Nat)] [bytes->list (-> -Bytes (-lst -Nat))] [list->bytes (-> (-lst -Integer) -Bytes)] [bytes* (list -Bytes) -Bytes B)] [bytes>? (->* (list -Bytes) -Bytes B)] [bytes=? (->* (list -Bytes) -Bytes B)] -[bytes->string/utf-8 (-Bytes [(Un (-val #f) -Char) -Integer -Integer] . ->opt . -String)] -[bytes->string/locale (-Bytes [(Un (-val #f) -Char) -Integer -Integer] . ->opt . -String)] -[bytes->string/latin-1 (-Bytes [(Un (-val #f) -Char) -Integer -Integer] . ->opt . -String)] -[string->bytes/utf-8 (-String [(Un (-val #f) -Integer) -Integer -Integer] . ->opt . -Bytes)] -[string->bytes/locale (-String [(Un (-val #f) -Integer) -Integer -Integer] . ->opt . -Bytes)] -[string->bytes/latin-1 (-String [(Un (-val #f) -Integer) -Integer -Integer] . ->opt . -Bytes)] -[string-utf-8-length (-String [-Integer -Integer] . ->opt . -Nat)] -[bytes-utf-8-length (-Bytes [(Un (-val #f) -Char) -Integer -Integer] . ->opt . -Nat)] -[bytes-utf-8-ref (-Bytes [-Integer (Un (-val #f) -Char) -Integer -Integer] . ->opt . -Char)] -[bytes-utf-8-index (-Bytes [-Integer (Un (-val #f) -Char) -Integer -Integer] . ->opt . -Nat)] [read-bytes-line (->opt [-Input-Port Sym] (Un -Bytes (-val eof)))] [open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)] From 9cbdbd8ed76941f1cb0be49932bca4e068d77ef5 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 21 Jun 2010 17:50:35 -0400 Subject: [PATCH 112/198] Added support for unsafe operations on heterogenous vectors. original commit: 379d9a21251696293a997aa1c58611b85b41b6ce --- .../typed-scheme/private/base-env-indexing-abs.rkt | 2 ++ collects/typed-scheme/typecheck/tc-app.rkt | 12 ++++++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index 5e451994..8e9b7250 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -134,6 +134,8 @@ [unsafe-vector*-ref (-poly (a) ((-vec a) index-type . -> . a))] [build-vector (-poly (a) (index-type (index-type . -> . a) . -> . (-vec a)))] [vector-set! (-poly (a) (-> (-vec a) index-type a -Void))] + [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))] [(index-type a) (-vec a)]))] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index af8a9053..cfa4fb9c 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -8,6 +8,7 @@ unstable/sequence unstable/debug ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy scheme/bool + racket/unsafe/ops (only-in racket/private/class-internal make-object do-make-object) (only-in '#%kernel [apply k:apply]) ;; end fixme @@ -20,7 +21,8 @@ (rep type-rep filter-rep object-rep) (r:infer infer) '#%paramz - (for-template + (for-template + racket/unsafe/ops (only-in '#%kernel [apply k:apply]) "internal-forms.rkt" scheme/base scheme/bool '#%paramz (only-in racket/private/class-internal make-object do-make-object))) @@ -441,7 +443,9 @@ (syntax-parse form #:literals (#%plain-app #%plain-lambda letrec-values quote values apply k:apply not list list* call-with-values do-make-object make-object cons - map andmap ormap reverse extend-parameterization vector-ref) + map andmap ormap reverse extend-parameterization + vector-ref unsafe-vector-ref unsafe-vector*-ref + vector-set! unsafe-vector-set! unsafe-vector*-set!) [(#%plain-app extend-parameterization pmz args ...) (let loop ([args (syntax->list #'(args ...))]) (if (null? args) (ret Univ) @@ -457,7 +461,7 @@ (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t) (loop (cddr args))]))))] ;; vector-ref on het vectors - [(#%plain-app (~and op (~literal vector-ref)) v e:expr) + [(#%plain-app (~and op (~or (~literal vector-ref) (~literal unsafe-vector-ref) (~literal unsafe-vector*-ref))) v e:expr) (let ([e-t (single-value #'e)]) (match (single-value #'v) [(tc-result1: (and t (HeterogenousVector: es))) @@ -483,7 +487,7 @@ [v-ty (let ([arg-tys (list v-ty e-t)]) (tc/funapp #'op #'(v e) (single-value #'op) arg-tys expected))]))] - [(#%plain-app (~and op (~literal vector-set!)) v e:expr val:expr) + [(#%plain-app (~and op (~or (~literal vector-set!) (~literal unsafe-vector-set!) (~literal unsafe-vector*-set!))) v e:expr val:expr) (let ([e-t (single-value #'e)]) (match (single-value #'v) [(tc-result1: (and t (HeterogenousVector: es))) From 1d48090ecb15b059e58f9d179c493b72b6c449eb Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 22 Jun 2010 13:22:39 -0400 Subject: [PATCH 113/198] Added support for unsafe struct operations to Typed Scheme. original commit: 7d1040283ed325c93fb5499649a0aba5cfadfab7 --- .../fail/unsafe-struct-parent.rkt | 19 ++++++ .../tests/typed-scheme/fail/unsafe-struct.rkt | 13 ++++ .../succeed/unsafe-struct-parent.rkt | 26 ++++++++ .../typed-scheme/succeed/unsafe-struct.rkt | 14 +++++ collects/typed-scheme/private/base-env.rkt | 5 ++ collects/typed-scheme/typecheck/tc-app.rkt | 61 ++++++++++++++++++- 6 files changed, 137 insertions(+), 1 deletion(-) create mode 100644 collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt create mode 100644 collects/tests/typed-scheme/fail/unsafe-struct.rkt create mode 100644 collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt create mode 100644 collects/tests/typed-scheme/succeed/unsafe-struct.rkt diff --git a/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt b/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt new file mode 100644 index 00000000..e4734368 --- /dev/null +++ b/collects/tests/typed-scheme/fail/unsafe-struct-parent.rkt @@ -0,0 +1,19 @@ +#; +(exn-pred 7) +#lang typed/scheme +(require racket/unsafe/ops) + +(define-struct: foo ((x : Integer) (y : String))) +(define-struct: (bar foo) ((z : Float))) + +(define a (make-foo 1 "1")) +(define b (make-bar 2 "2" 2.0)) + +(+ (unsafe-struct-ref a 1) 2) +(+ (unsafe-struct-ref b 1) 2) + +(unsafe-struct-set! a 0 "2") +(unsafe-struct-set! a 1 2) +(unsafe-struct-set! b 0 3.0) +(unsafe-struct-set! b 1 3) +(unsafe-struct-set! b 2 "3") diff --git a/collects/tests/typed-scheme/fail/unsafe-struct.rkt b/collects/tests/typed-scheme/fail/unsafe-struct.rkt new file mode 100644 index 00000000..a185937b --- /dev/null +++ b/collects/tests/typed-scheme/fail/unsafe-struct.rkt @@ -0,0 +1,13 @@ +#; +(exn-pred 3) +#lang typed/scheme +(require racket/unsafe/ops) + +(define-struct: x ((a : Integer) (b : String)) #:mutable) + +(define x1 (make-x 1 "1")) + +(+ (unsafe-struct-ref x1 1) 1) + +(unsafe-struct-set! x1 0 "2") +(unsafe-struct-set! x1 1 1) diff --git a/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt b/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt new file mode 100644 index 00000000..82ecf767 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/unsafe-struct-parent.rkt @@ -0,0 +1,26 @@ +#lang typed/scheme +(require racket/unsafe/ops) + +(define-struct: foo ((x : Integer) (y : String))) +(define-struct: (bar foo) ((z : Float))) + +(define a (make-foo 1 "1")) +(define b (make-bar 2 "2" 2.0)) + +(= (+ (unsafe-struct-ref a 0) 2) 3) +(string=? (string-append (unsafe-struct-ref a 1) "\n") "1\n") +(= (+ (unsafe-struct-ref b 0) 2) 4) +(string=? (string-append (unsafe-struct-ref b 1) "\n") "2\n") +(= (+ (unsafe-struct-ref b 2) 2.0) 4.0) + +(unsafe-struct-set! a 0 2) +(unsafe-struct-set! a 1 "2") +(unsafe-struct-set! b 0 3) +(unsafe-struct-set! b 1 "3") +(unsafe-struct-set! b 2 3.0) + +(= (+ (unsafe-struct-ref a 0) 2) 4) +(string=? (string-append (unsafe-struct-ref a 1) "\n") "2\n") +(= (+ (unsafe-struct-ref b 0) 2) 5) +(string=? (string-append (unsafe-struct-ref b 1) "\n") "3\n") +(= (+ (unsafe-struct-ref b 2) 2.0) 5.0) diff --git a/collects/tests/typed-scheme/succeed/unsafe-struct.rkt b/collects/tests/typed-scheme/succeed/unsafe-struct.rkt new file mode 100644 index 00000000..df6bff14 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/unsafe-struct.rkt @@ -0,0 +1,14 @@ +#lang typed/scheme +(require racket/unsafe/ops) + +(define-struct: x ((a : Integer) (b : String)) #:mutable) + +(define x1 (make-x 1 "1")) + +(= (+ (unsafe-struct-ref x1 0) 2) 3) +(string=? (string-append (unsafe-struct-ref x1 1) "\n") "1\n") + +(unsafe-struct-set! x1 0 2) +(unsafe-struct-set! x1 1 "2") +(= (+ (unsafe-struct-ref x1 0) 2) 4) +(string=? (string-append (unsafe-struct-ref x1 1) "\n") "2\n") diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 27a7bdc9..aca51a68 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -411,6 +411,11 @@ [call-with-escape-continuation (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))] [struct->vector (Univ . -> . (-vec Univ))] +[unsafe-struct-ref top-func] +[unsafe-struct*-ref top-func] +[unsafe-struct-set! top-func] +[unsafe-struct*-set! top-func] + ;; parameter stuff [parameterization-key Sym] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index cfa4fb9c..109cb371 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -445,7 +445,8 @@ values apply k:apply not list list* call-with-values do-make-object make-object cons map andmap ormap reverse extend-parameterization vector-ref unsafe-vector-ref unsafe-vector*-ref - vector-set! unsafe-vector-set! unsafe-vector*-set!) + vector-set! unsafe-vector-set! unsafe-vector*-set! + unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set!) [(#%plain-app extend-parameterization pmz args ...) (let loop ([args (syntax->list #'(args ...))]) (if (null? args) (ret Univ) @@ -460,6 +461,64 @@ [(tc-result1: t) (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t) (loop (cddr args))]))))] + ;; unsafe struct operations + [(#%plain-app (~and op (~or (~literal unsafe-struct-ref) (~literal unsafe-struct*-ref))) s e:expr) + (let ([e-t (single-value #'e)]) + (match (single-value #'s) + [(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _) + (? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _)))))) + (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) + (match e-t + [(tc-result1: (Value: (? number? i))) i] + [_ #f]))]) + (cond [(not ival) + (check-below e-t -Nat) + (if expected + (check-below (ret (apply Un flds)) expected) + (ret (apply Un flds)))] + [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds)))) + (if expected + (check-below (ret (list-ref flds ival)) expected) + (ret (list-ref flds ival)))] + [(not (and (integer? ival) (exact? ival))) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for struct index, but got ~a" ival)] + [(< ival 0) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)] + [(not (<= ival (sub1 (length flds)))) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))] + [s-ty + (let ([arg-tys (list s-ty e-t)]) + (tc/funapp #'op #'(s e) (single-value #'op) arg-tys expected))]))] + [(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr) + (let ([e-t (single-value #'e)]) + (match (single-value #'s) + [(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _) + (? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _)))))) + (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) + (match e-t + [(tc-result1: (Value: (? number? i))) i] + [_ #f]))]) + (cond [(not ival) + (tc-error/expr #:stx #'e + #:return (or expected (ret -Void)) + "expected statically known index for unsafe struct mutation, but got ~a" (match e-t [(tc-result1: t) t]))] + [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds)))) + (tc-expr/check #'val (ret (list-ref flds ival))) + (if expected + (check-below (ret -Void) expected) + (ret -Void))] + [(not (and (integer? ival) (exact? ival))) + (single-value #'val) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for unsafe struct mutation, but got ~a" ival)] + [(< ival 0) + (single-value #'val) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for struct ~a" ival t)] + [(not (<= ival (sub1 (length flds)))) + (single-value #'val) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for struct ~a" ival t)]))] + [s-ty + (let ([arg-tys (list s-ty e-t (single-value #'val))]) + (tc/funapp #'op #'(s e val) (single-value #'op) arg-tys expected))]))] ;; vector-ref on het vectors [(#%plain-app (~and op (~or (~literal vector-ref) (~literal unsafe-vector-ref) (~literal unsafe-vector*-ref))) v e:expr) (let ([e-t (single-value #'e)]) From 93728d1ebdd7c6876c5d00a97ba7e1330822dc71 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 22 Jun 2010 13:23:44 -0400 Subject: [PATCH 114/198] Switched indexing to integers in the typechecker's special cases for heterogenous vectors and unsafe struct operations. original commit: 3c9e7e34db69a6112f8aa87c4e5c3edcd550b4ab --- collects/typed-scheme/typecheck/tc-app.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 109cb371..a03531ff 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -472,7 +472,7 @@ [(tc-result1: (Value: (? number? i))) i] [_ #f]))]) (cond [(not ival) - (check-below e-t -Nat) + (check-below e-t -Integer) (if expected (check-below (ret (apply Un flds)) expected) (ret (apply Un flds)))] @@ -529,7 +529,7 @@ [(tc-result1: (Value: (? number? i))) i] [_ #f]))]) (cond [(not ival) - (check-below e-t -Nat) + (check-below e-t -Integer) (if expected (check-below (ret (apply Un es)) expected) (ret (apply Un es)))] From 68ba63ce4de115bdea7136ef60d9b47852813a91 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 24 Jun 2010 11:01:29 -0400 Subject: [PATCH 115/198] Better handling of unsafe identifier generation. original commit: 3078807757448b9223bcd58cfa10d7b30db4ddee --- collects/typed-scheme/private/optimize.rkt | 40 +++++++++++----------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index e34c5b65..5d466deb 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -2,7 +2,7 @@ (require syntax/parse (for-template scheme/base scheme/flonum scheme/unsafe/ops) "../utils/utils.rkt" unstable/match scheme/match unstable/syntax - (rep type-rep) + (rep type-rep) syntax/id-table racket/dict (types abbrev type-table utils subtype)) (provide optimize) @@ -26,21 +26,22 @@ [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) #:with opt #'e.opt)) -(define-syntax-class float-binary-op - #:literals (+ - * / = <= < > >= min max - fl+ fl- fl* fl/ fl= fl<= fl< fl> fl>= flmin flmax) - (pattern (~and i:id (~or + - * / = <= < > >= min max)) - #:with unsafe (format-id #'here "unsafe-fl~a" #'i)) - (pattern (~and i:id (~or fl+ fl- fl* fl/ fl= fl<= fl< fl> fl>= flmin flmax)) - #:with unsafe (format-id #'here "unsafe-~a" #'i))) +(define (mk-float-tbl generic) + (for/fold ([h (make-immutable-free-id-table)]) ([g generic]) + (let ([f (format-id g "fl~a" g)] [u (format-id g "unsafe-fl~a" g)]) + (dict-set (dict-set h g u) f u)))) -(define-syntax-class float-unary-op - #:literals (abs sin cos tan asin acos atan log exp sqrt round floor ceiling truncate - flabs flsin flcos fltan flasin flacos flatan fllog flexp flsqrt flround flfloor flceiling fltruncate) - (pattern (~and i:id (~or abs sin cos tan asin acos atan log exp sqrt round floor ceiling truncate)) - #:with unsafe (format-id #'here "unsafe-fl~a" #'i)) - (pattern (~and i:id (~or flabs flsin flcos fltan flasin flacos flatan fllog flexp flsqrt flround flfloor flceiling fltruncate)) - #:with unsafe (format-id #'here "unsafe-~a" #'i))) +(define binary-float-ops + (mk-float-tbl (list #'+ #'- #'* #'/ #'= #'<= #'< #'> #'>= #'min #'max))) + +(define unary-float-ops + (mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp + #'sqrt #'round #'floor #'ceiling #'truncate))) + +(define-syntax-class (float-op tbl) + (pattern i:id + #:when (dict-ref tbl #'i #f) + #:with unsafe (dict-ref tbl #'i))) (define-syntax-class pair-opt-expr (pattern e:opt-expr @@ -50,9 +51,8 @@ #:with opt #'e.opt)) (define-syntax-class pair-unary-op - #:literals (car cdr) - (pattern (~and i:id (~or car cdr)) - #:with unsafe (format-id #'here "unsafe-~a" #'i))) + (pattern (~literal car) #:with unsafe #'unsafe-car) + (pattern (~literal cdr) #:with unsafe #'unsafe-cdr)) (define-syntax-class opt-expr (pattern e:opt-expr* @@ -72,12 +72,12 @@ #:literal-sets (kernel-literals) ;; interesting cases, where something is optimized - (pattern (#%plain-app op:float-unary-op f:float-opt-expr) + (pattern (#%plain-app (~var op (float-op unary-float-ops)) f:float-opt-expr) #:with opt (begin (log-optimization "unary float" #'op) #'(op.unsafe f.opt))) ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments - (pattern (~and res (#%plain-app op:float-binary-op f1:float-arg-expr f2:float-arg-expr fs:float-arg-expr ...)) + (pattern (~and res (#%plain-app (~var op (float-op binary-float-ops)) f1:float-arg-expr f2:float-arg-expr fs:float-arg-expr ...)) #:when (match (type-of #'res) [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) #:with opt From 7f6da53efa781a0e507eeef196dffa92daf0ad6f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 24 Jun 2010 13:39:31 -0400 Subject: [PATCH 116/198] Use the correct field numbers in substructs. Maintain table of struct accessors/mutators. original commit: 3c8952d63d2cd28a3b5a588c0367b53dc963308b --- .../typed-scheme/succeed/test-child-field.rkt | 10 +++++ collects/typed-scheme/rep/type-rep.rkt | 3 +- .../typed-scheme/typecheck/tc-structs.rkt | 43 +++++++++++-------- collects/typed-scheme/types/type-table.rkt | 20 ++++++++- 4 files changed, 53 insertions(+), 23 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/test-child-field.rkt diff --git a/collects/tests/typed-scheme/succeed/test-child-field.rkt b/collects/tests/typed-scheme/succeed/test-child-field.rkt new file mode 100644 index 00000000..40f36fe6 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/test-child-field.rkt @@ -0,0 +1,10 @@ +#lang typed/racket + +(define-struct: x ([a : Any])) +(define-struct: (A) (y x) ([b : A])) + +(: f : (y Any) -> String) +(define (f v) + (if (string? (y-b v)) + (y-b v) + "foo")) \ No newline at end of file diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index bc3ff7ec..d0c122f1 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -18,8 +18,7 @@ (not (ValuesDots? e)) (not (Result? e))))) -(define Type/c - (flat-named-contract 'Type Type/c?)) +(define Type/c (flat-named-contract 'Type Type/c?)) ;; Name = Symbol diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index 66ddbb10..1942898d 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" (except-in (rep type-rep free-variance) Dotted) (private parse-type) - (types convenience utils union resolve abbrev substitute) + (types convenience utils union resolve abbrev substitute type-table) (env global-env type-env-structs type-name-env tvar-env) (utils tc-utils) "def-binding.rkt" @@ -142,26 +142,31 @@ (or (eq? variance Constant) (eq? variance Covariant)))) #t))) + (define parent-count (- (length external-fld-types) (length external-fld-types/no-parent))) ;; the list of names w/ types (define bindings - (append - (list - (cons struct-type-id - (make-StructType sty)) - (cons (or maker* maker) - (wrapper (->* external-fld-types (if cret cret name)))) - (cons (or pred* pred) - (make-pred-ty (if (not covariant?) - (make-StructTop sty) - (pred-wrapper name))))) - (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) - (let ([func (if setters? - (->* (list name) t) - (->acc (list name) t (list (make-StructPE name i))))]) - (cons g (wrapper func)))) - (if setters? - (map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent) - null))) + (list* + (cons struct-type-id + (make-StructType sty)) + (cons (or maker* maker) + (wrapper (->* external-fld-types (if cret cret name)))) + (cons (or pred* pred) + (make-pred-ty (if (not covariant?) + (make-StructTop sty) + (pred-wrapper name)))) + (append + (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals parent-count)]) + (let* ([path (make-StructPE name i)] + [func (if setters? + (->* (list name) t) + (->acc (list name) t (list path)))]) + (add-struct-fn! g path #f) + (cons g (wrapper func)))) + (if setters? + (for/list ([g (in-list setters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals parent-count)]) + (add-struct-fn! g (make-StructPE name i) #t) + (cons g (wrapper (->* (list name t) -Void)))) + null)))) (register-type-name nm (wrapper sty)) (cons (make-def-struct-stx-binding nm si) diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt index 498768da..78cc289c 100644 --- a/collects/typed-scheme/types/type-table.rkt +++ b/collects/typed-scheme/types/type-table.rkt @@ -1,6 +1,7 @@ #lang scheme/base -(require unstable/debug "../utils/utils.rkt" (rep type-rep) (only-in (types abbrev utils) tc-results?) (utils tc-utils) scheme/contract) +(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)) (define table (make-hasheq)) @@ -12,6 +13,21 @@ (define (type-of e) (hash-ref table e (lambda () (int-err (format "no type for ~a" (syntax->datum e)))))) +(define struct-fn-table (make-free-id-table)) + +(define (add-struct-fn! id pe mut?) (dict-set! struct-fn-table id (list pe mut?))) + +(define-values (struct-accessor? struct-mutator?) + (let () + (define ((mk mut?) id) + (cond [(dict-ref struct-fn-table id #f) + => (match-lambda [(list pe #f) pe] [_ #f])] + [else #f])) + (values (mk #f) (mk #t)))) + (p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)] [type-of (syntax? . -> . tc-results?)] - [reset-type-table (-> any/c)]) \ No newline at end of file + [reset-type-table (-> any/c)] + [add-struct-fn! (identifier? StructPE? boolean? . -> . any/c)] + [struct-accessor? (identifier? . -> . (or/c #f StructPE?))] + [struct-mutator? (identifier? . -> . (or/c #f StructPE?))]) \ No newline at end of file From 8e76e3436805b4574b939959446c718464651189 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 24 Jun 2010 16:46:31 -0400 Subject: [PATCH 117/198] More options for test runner. original commit: 5b1118d514ca8cc7f0071bfa531f8268401fc531 --- collects/tests/typed-scheme/main.rkt | 10 ++++++++-- collects/tests/typed-scheme/run.rkt | 20 +++++++++++++++----- 2 files changed, 23 insertions(+), 7 deletions(-) diff --git a/collects/tests/typed-scheme/main.rkt b/collects/tests/typed-scheme/main.rkt index 96fb394b..ac68c30a 100644 --- a/collects/tests/typed-scheme/main.rkt +++ b/collects/tests/typed-scheme/main.rkt @@ -86,8 +86,14 @@ (test-suite "Typed Scheme Tests" unit-tests int-tests)) -(define (go [unit? #f]) (test/gui (if unit? unit-tests tests))) -(define (go/text [unit? #f]) (run-tests (if unit? unit-tests tests) 'verbose)) +(define (go [unit? #f] [int? #f]) (test/gui (cond [unit? unit-tests] + [int? int-tests] + [else tests]))) +(define (go/text [unit? #f] [int? #f]) (run-tests + (cond [unit? unit-tests] + [int? int-tests] + [else tests]) + 'verbose)) (provide go go/text) diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-scheme/run.rkt index c462e3d9..efde19fe 100644 --- a/collects/tests/typed-scheme/run.rkt +++ b/collects/tests/typed-scheme/run.rkt @@ -2,14 +2,24 @@ (require racket/vector racket/gui/dynamic) (require "main.ss") -(current-namespace (make-base-namespace)) + (define exec (make-parameter go/text)) (define unit-only? (make-parameter #f)) +(define int-only? (make-parameter #f)) +(define skip-all? #f) +(current-namespace (make-base-namespace)) (command-line #:once-each ["--unit" "run just the unit tests" (unit-only? #t)] + ["--int" "run just the integration tests" (int-only? #t)] + ["--nightly" "for the nightly builds" (when (eq? 'cgc (system-type 'gc)) + (set! skip-all? #t))] ["--gui" "run using the gui" - (current-namespace ((gui-dynamic-require 'make-gui-namespace))) - (exec go)]) -(unless (= 0 ((exec) (unit-only?))) - (error "Typed Scheme Tests did not pass.")) + (if (gui-available?) + (begin (exec go)) + (error "GUI not available"))]) + +(if skip-all? + (printf "Skipping Typed Racket tests.\n") + (unless (= 0 ((exec) (unit-only?) (int-only?))) + (error "Typed Racket Tests did not pass."))) From bc193f512c70803552a7767ed02fe4107fa493d9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 24 Jun 2010 16:47:25 -0400 Subject: [PATCH 118/198] Types are not quotable. original commit: 40ca16bc3059a029adddd5da1006680db578fa4c --- collects/typed-scheme/utils/utils.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index bf109ba9..4c81ab3f 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -152,9 +152,10 @@ at least theoretically. (syntax-parse stx [(form name (flds ...) printer:expr) #`(define-struct name (flds ...) + #:property prop:custom-print-quotable 'never #:property prop:custom-write (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c))) - #:inspector #f)])) + #:transparent)])) ;; turn contracts on and off - off by default for performance. From c898d882c61d087ac13f77d31fcc1e579dc6fcc1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 24 Jun 2010 16:48:10 -0400 Subject: [PATCH 119/198] recreate selector table automatically. original commit: a33f460b2547866d492bf01c81ded9b2a669ea26 --- collects/typed-scheme/rep/object-rep.rkt | 1 + collects/typed-scheme/typecheck/tc-toplevel.rkt | 9 ++++++--- collects/typed-scheme/types/type-table.rkt | 17 +++++++++++++++-- 3 files changed, 22 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/rep/object-rep.rkt b/collects/typed-scheme/rep/object-rep.rkt index e36c3a5a..3608a0e9 100644 --- a/collects/typed-scheme/rep/object-rep.rkt +++ b/collects/typed-scheme/rep/object-rep.rkt @@ -6,6 +6,7 @@ (dpe CarPE () [#:fold-rhs #:base]) (dpe CdrPE () [#:fold-rhs #:base]) (dpe SyntaxPE () [#:fold-rhs #:base]) +;; t is always a Name (can't put that into the contract b/c of circularity) (dpe StructPE ([t Type?] [idx natural-number/c]) [#:frees (free-vars* t) (free-idxs* t)] [#:fold-rhs (*StructPE (type-rec-id t) idx)]) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index e970654b..4fab6fc5 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -11,7 +11,7 @@ ;; to appease syntax-parse "internal-forms.rkt" (rep type-rep) - (types utils convenience) + (types utils convenience type-table) (private parse-type type-annotation type-contract) (env global-env init-envs type-name-env type-alias-env lexical-env) unstable/mutated-vars syntax/id-table @@ -19,7 +19,7 @@ "provide-handling.rkt" "def-binding.rkt" (prefix-in c: racket/contract) - racket/dict + racket/dict (for-template "internal-forms.rkt" unstable/location @@ -306,10 +306,13 @@ [(new-provs ...) (generate-prov def-tbl provide-tbl #'the-variable-reference)]) #`(begin - (define the-variable-reference (quote-module-path)) + #,(if (null? (syntax-e #'(new-provs ...))) + #'(begin) + #'(define the-variable-reference (quote-module-path))) #,(env-init-code syntax-provide? provide-tbl def-tbl) #,(tname-env-init-code) #,(talias-env-init-code) + (begin-for-syntax #,(make-struct-table-code)) (begin new-provs ...))))) ;; typecheck a whole module diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt index 78cc289c..154ac941 100644 --- a/collects/typed-scheme/types/type-table.rkt +++ b/collects/typed-scheme/types/type-table.rkt @@ -1,7 +1,8 @@ #lang scheme/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)) + (rep type-rep object-rep) (only-in (types abbrev utils) tc-results?) (utils tc-utils) + (env init-envs) mzlib/pconvert) (define table (make-hasheq)) @@ -25,9 +26,21 @@ [else #f])) (values (mk #f) (mk #t)))) +(define (make-struct-table-code) + (parameterize ([current-print-convert-hook converter] + [show-sharing #f]) + #`(begin #,@(for/list ([(k v) (in-dict struct-fn-table)] + #:when (bound-in-this-module k)) + (match v + [(list pe mut?) + #`(add-struct-fn! (quote-syntax #,k) + #,(print-convert pe) + #,mut?)]))))) + (p/c [add-typeof-expr (syntax? tc-results? . -> . any/c)] [type-of (syntax? . -> . tc-results?)] [reset-type-table (-> any/c)] [add-struct-fn! (identifier? StructPE? boolean? . -> . any/c)] [struct-accessor? (identifier? . -> . (or/c #f StructPE?))] - [struct-mutator? (identifier? . -> . (or/c #f StructPE?))]) \ No newline at end of file + [struct-mutator? (identifier? . -> . (or/c #f StructPE?))] + [make-struct-table-code (-> syntax?)]) \ No newline at end of file From a7b787db6ccddcc637c470d7f58b090af2619680 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 24 Jun 2010 17:54:23 -0400 Subject: [PATCH 120/198] Add Fixnum type. original commit: 4b1c62c9785a6578ba2f894a53a8ee6f1a03152f --- .../unit-tests/typecheck-tests.rkt | 107 +++++++++--------- collects/typed-scheme/private/base-env.rkt | 33 +++--- collects/typed-scheme/private/base-types.rkt | 2 + .../typed-scheme/typecheck/tc-expr-unit.rkt | 6 +- collects/typed-scheme/types/abbrev.rkt | 8 +- collects/typed-scheme/types/subtype.rkt | 18 ++- 6 files changed, 102 insertions(+), 72 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 34776dee..62314b0a 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -141,24 +141,24 @@ (+ 1 (car x)) 5)) N] - (tc-e/t (if (let ([y 12]) y) 3 4) -Pos) - (tc-e/t 3 -Pos) + (tc-e/t (if (let ([y 12]) y) 3 4) -PositiveFixnum) + (tc-e/t 3 -PositiveFixnum) (tc-e/t "foo" -String) (tc-e (+ 3 4) -Pos) - [tc-e/t (lambda: () 3) (t:-> -Pos : -true-lfilter)] - [tc-e/t (lambda: ([x : Number]) 3) (t:-> N -Pos : -true-lfilter)] - [tc-e/t (lambda: ([x : Number] [y : Boolean]) 3) (t:-> N B -Pos : -true-lfilter)] - [tc-e/t (lambda () 3) (t:-> -Pos : -true-lfilter)] - [tc-e (values 3 4) #:ret (ret (list -Pos -Pos) (list -true-filter -true-filter))] - [tc-e (cons 3 4) (-pair -Pos -Pos)] + [tc-e/t (lambda: () 3) (t:-> -PositiveFixnum : -true-lfilter)] + [tc-e/t (lambda: ([x : Number]) 3) (t:-> N -PositiveFixnum : -true-lfilter)] + [tc-e/t (lambda: ([x : Number] [y : Boolean]) 3) (t:-> N B -PositiveFixnum : -true-lfilter)] + [tc-e/t (lambda () 3) (t:-> -PositiveFixnum : -true-lfilter)] + [tc-e (values 3 4) #:ret (ret (list -PositiveFixnum -PositiveFixnum) (list -true-filter -true-filter))] + [tc-e (cons 3 4) (-pair -PositiveFixnum -PositiveFixnum)] [tc-e (cons 3 (ann '() : (Listof Integer))) (make-Listof -Integer)] [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-Vector -Pos)] - [tc-e/t '(2 3 4) (-lst* -Pos -Pos -Pos)] - [tc-e/t '(2 3 #t) (-lst* -Pos -Pos (-val #t))] - [tc-e/t #(2 3 #t) (make-Vector (t:Un -Pos (-val #t)))] + [tc-e/t #(3 4 5) (make-Vector -PositiveFixnum)] + [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-Vector (t:Un -PositiveFixnum (-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)))] @@ -169,9 +169,9 @@ [tc-e (let-values ([(x) 4]) (+ x 1)) -Pos] [tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y))) #:proc (syntax-parser [(_ ([(_ y) . _]) . _) (ret -Boolean (-FS -top -top))])] - [tc-e/t (values 3) -Pos] + [tc-e/t (values 3) -PositiveFixnum] [tc-e (values) #:ret (ret null)] - [tc-e (values 3 #f) #:ret (ret (list -Pos (-val #f)) (list (-FS -top -bot) (-FS -bot -top)))] + [tc-e (values 3 #f) #:ret (ret (list -PositiveFixnum (-val #f)) (list (-FS -top -bot) (-FS -bot -top)))] [tc-e (map #{values @ Symbol} '(a b c)) (-pair Sym (make-Listof Sym))] [tc-e (letrec: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))]) (fact 20)) @@ -201,8 +201,8 @@ 'bc)) N] [tc-e/t (let: ((x : Number 3)) (if (boolean? x) (not x) #t)) (-val #t)] - [tc-e/t (begin 3) -Pos] - [tc-e/t (begin #f 3) -Pos] + [tc-e/t (begin 3) -PositiveFixnum] + [tc-e/t (begin #f 3) -PositiveFixnum] [tc-e/t (begin #t) (-val #t)] [tc-e/t (begin0 #t) (-val #t)] [tc-e/t (begin0 #t 3) (-val #t)] @@ -210,14 +210,14 @@ [tc-e #f #:ret (ret (-val #f) (-FS -bot -top))] [tc-e/t '#t (-val #t)] [tc-e '#f #:ret (ret (-val #f) (-FS -bot -top))] - [tc-e/t (if #f 'a 3) -Pos] + [tc-e/t (if #f 'a 3) -PositiveFixnum] [tc-e/t (if #f #f #t) (t:Un (-val #t))] [tc-e (when #f 3) -Void] [tc-e/t '() (-val '())] [tc-e/t (let: ([x : (Listof Number) '(1)]) (cond [(pair? x) 1] [(null? x) 1])) - -Pos] + -PositiveFixnum] [tc-e/t (lambda: ([x : Number] . [y : Number *]) (car y)) (->* (list N) N N)] [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3) N] [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3 4 5) N] @@ -241,7 +241,7 @@ (if (list? x) (begin (car x) 1) 2)) - -Pos] + -PositiveFixnum] [tc-e (let: ([x : (U Number Boolean) 3]) @@ -250,7 +250,7 @@ 3)) N] - [tc-e (let ([x 1]) x) -Pos] + [tc-e (let ([x 1]) x) -PositiveFixnum] [tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean (-FS -bot -top))] [tc-e (boolean? number?) #:ret (ret -Boolean (-FS -bot -top))] @@ -271,9 +271,9 @@ (if (eq? x 1) 12 14)) - -Pos] + -PositiveFixnum] - [tc-e (car (append (list 1 2) (list 3 4))) -Pos] + [tc-e (car (append (list 1 2) (list 3 4))) -PositiveFixnum] [tc-e (let-syntax ([a @@ -283,8 +283,8 @@ (string-append "foo" (a v)))) -String] - [tc-e (apply (plambda: (a) [x : a *] x) '(5)) (-lst -Pos)] - [tc-e (apply append (list '(1 2 3) '(4 5 6))) (-lst -Pos)] + [tc-e (apply (plambda: (a) [x : a *] x) '(5)) (-lst -PositiveFixnum)] + [tc-e (apply append (list '(1 2 3) '(4 5 6))) (-lst -PositiveFixnum)] [tc-err ((case-lambda: [([x : Number]) x] [([y : Number] [x : Number]) x]) @@ -320,9 +320,9 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) x) - (t:Un (-val 'squarf) -Pos)] + (t:Un (-val 'squarf) -PositiveFixnum)] - [tc-e/t (if #t 1 2) -Pos] + [tc-e/t (if #t 1 2) -PositiveFixnum] ;; eq? as predicate @@ -347,12 +347,12 @@ [x (if (= 1 2) 3 sym)]) (if (eq? x sym) 3 x)) #:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) - (ret -Pos (-FS -top -top))])] + (ret -PositiveFixnum (-FS -top -top))])] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (eq? sym x) 3 x)) #:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) - (ret -Pos (-FS -top -top))])] + (ret -PositiveFixnum (-FS -top -top))])] ;; equal? as predicate for symbols [tc-e (let: ([x : (Un 'foo Number) 'foo]) (if (equal? x 'foo) 3 x)) @@ -365,22 +365,22 @@ [x (if (= 1 2) 3 sym)]) (if (equal? x sym) 3 x)) #:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) - (ret -Pos (-FS -top -top))])] + (ret -PositiveFixnum (-FS -top -top))])] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? sym x) 3 x)) #:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) - (ret -Pos (-FS -top -top))])] + (ret -PositiveFixnum (-FS -top -top))])] [tc-e (let: ([x : (Listof Symbol)'(a b c)]) (cond [(memq 'a x) => car] [else 'foo])) Sym] - [tc-e (list 1 2 3) (-lst* -Pos -Pos -Pos)] - [tc-e (list 1 2 3 'a) (-lst* -Pos -Pos -Pos (-val 'a))] + [tc-e (list 1 2 3) (-lst* -PositiveFixnum -PositiveFixnum -PositiveFixnum)] + [tc-e (list 1 2 3 'a) (-lst* -PositiveFixnum -PositiveFixnum -PositiveFixnum (-val 'a))] - [tc-e `(1 2 ,(+ 3 4)) (-lst* -Pos -Pos -Pos)] + [tc-e `(1 2 ,(+ 3 4)) (-lst* -PositiveFixnum -PositiveFixnum -Pos)] [tc-e (let: ([x : Any 1]) (when (and (list? x) (not (null? x))) @@ -399,7 +399,7 @@ 'foo)) (t:Un (-val 'foo) (-pair Univ (-lst Univ)))] - [tc-e (cadr (cadr (list 1 (list 1 2 3) 3))) -Pos] + [tc-e (cadr (cadr (list 1 (list 1 2 3) 3))) -PositiveFixnum] @@ -414,7 +414,7 @@ [tc-e/t (let: ([x : Any 3]) (if (and (list? x) (not (null? x))) (begin (car x) 1) 2)) - -Pos] + -PositiveFixnum] ;; set! tests [tc-e (let: ([x : Any 3]) @@ -471,7 +471,7 @@ [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (number? z))]) (lambda: ([x : Any]) (if (p? x) 11 12))) - (t:-> Univ -Pos : -true-lfilter)] + (t:-> Univ -PositiveFixnum : -true-lfilter)] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (number? z))]) (lambda: ([x : Any]) (if (p? x) x 12))) @@ -484,7 +484,7 @@ [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (not (number? z)))]) (lambda: ([x : Any]) (if (p? x) x 12))) - (t:-> Univ -Pos : -true-lfilter)] + (t:-> Univ -PositiveFixnum : -true-lfilter)] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) z)]) (lambda: ([x : Any]) (if (p? x) x 12))) @@ -515,7 +515,7 @@ ;; w-c-m [tc-e/t (with-continuation-mark 'key 'mark 3) - -Pos] + -PositiveFixnum] [tc-err (with-continuation-mark (5 4) 1 3)] [tc-err (with-continuation-mark 1 (5 4) @@ -544,14 +544,14 @@ [tc-err (call-with-values (lambda () (values 2 1)) (lambda: ([x : String] [y : Number]) (+ x y)))] ;; quote-syntax - [tc-e/t #'3 (-Syntax -Pos)] - [tc-e/t #'(1 2 3) (-Syntax (-lst* -Pos -Pos -Pos))] + [tc-e/t #'3 (-Syntax -PositiveFixnum)] + [tc-e/t #'(1 2 3) (-Syntax (-lst* -PositiveFixnum -PositiveFixnum -PositiveFixnum))] ;; testing some primitives [tc-e (let ([app apply] [f (lambda: [x : Number *] 3)]) (app f (list 1 2 3))) - -Pos] + -PositiveFixnum] [tc-e ((lambda () (call/cc (lambda: ([k : (Number -> (U))]) (if (read) 5 (k 10)))))) N] @@ -589,7 +589,7 @@ (+ z w))) (g 4)) 5) - -Pos] + -PositiveFixnum] [tc-err (let () (define x x) @@ -620,11 +620,11 @@ [tc-e/t (if #f 1 'foo) (-val 'foo)] - [tc-e (list* 1 2 3) (-pair -Pos (-pair -Pos -Pos))] + [tc-e (list* 1 2 3) (-pair -PositiveFixnum (-pair -PositiveFixnum -PositiveFixnum))] [tc-err (apply append (list 1) (list 2) (list 3) (list (list 1) "foo"))] - [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list 1))) (-lst -Pos)] - [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list "foo"))) (-lst (t:Un -String -Pos))] + [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list 1))) (-lst -PositiveFixnum)] + [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list "foo"))) (-lst (t:Un -String -PositiveFixnum))] [tc-err (plambda: (b ...) [y : b ... b] (apply append (map list y)))] [tc-e/t (plambda: (b ...) [y : (Listof Integer) ... b] (apply append y)) (-polydots (b) (->... (list) ((-lst -Integer) b) (-lst -Integer)))] @@ -652,12 +652,12 @@ ;; instantiating dotted terms [tc-e/t (inst (plambda: (a ...) [xs : a ... a] 3) Integer Boolean Integer) - (-Integer B -Integer . t:-> . -Pos : -true-lfilter)] + (-Integer B -Integer . t:-> . -PositiveFixnum : -true-lfilter)] [tc-e/t (inst (plambda: (a ...) [xs : (a ... a -> Integer) ... a] 3) Integer Boolean Integer) ((-Integer B -Integer . t:-> . -Integer) (-Integer B -Integer . t:-> . -Integer) (-Integer B -Integer . t:-> . -Integer) - . t:-> . -Pos : -true-filter)] + . t:-> . -PositiveFixnum : -true-filter)] [tc-e/t (plambda: (z x y ...) () (inst map z x y ... y)) (-polydots (z x y) (t:-> (cl->* @@ -744,7 +744,7 @@ [tc-e/t (ann (lambda (x) x) (All (a) (a -> a))) (-poly (a) (a . t:-> . a))] - [tc-e (apply values (list 1 2 3)) #:ret (ret (list -Pos -Pos -Pos))] + [tc-e (apply values (list 1 2 3)) #:ret (ret (list -PositiveFixnum -PositiveFixnum -PositiveFixnum))] [tc-e/t (ann (if #t 3 "foo") Integer) -Integer] @@ -784,7 +784,7 @@ (tc-e (or (string->number "7") 7) #:ret (ret -Number -true-filter)) [tc-e (let ([x 1]) (if x x (add1 x))) - #:ret (ret -Pos (-FS -top -top))] + #:ret (ret -PositiveFixnum (-FS -top -top))] [tc-e (let: ([x : (U (Vectorof Number) String) (vector 1 2 3)]) (if (vector? x) (vector-ref x 0) (string-length x))) -Number] @@ -835,7 +835,10 @@ (test-not-exn "Doesn't fail on equal types" (lambda () (check-type #'here N N)))) (test-suite "tc-literal tests" - (tc-l 5 -ExactPositiveInteger) + (tc-l 5 -PositiveFixnum) + (tc-l -5 -NegativeFixnum) + (tc-l 0 -Zero) + (tc-l 0.0 -Flonum) (tc-l 5# -Flonum) (tc-l 5.0 -Flonum) (tc-l 5.1 -Flonum) @@ -846,8 +849,8 @@ (tc-l #f (-val #f)) (tc-l #"foo" -Bytes) [tc-l () (-val null)] - [tc-l (3 . 4) (-pair -Pos -Pos)] - [tc-l #hash((1 . 2) (3 . 4)) (make-Hashtable -Pos -Pos)]) + [tc-l (3 . 4) (-pair -PositiveFixnum -PositiveFixnum)] + [tc-l #hash((1 . 2) (3 . 4)) (make-Hashtable -PositiveFixnum -PositiveFixnum)]) )) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index aca51a68..0552101c 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -217,8 +217,8 @@ [string? (make-pred-ty -String)] [string (->* '() -Char -String)] -[string-length (-String . -> . -Nat)] -[unsafe-string-length (-String . -> . -Nat)] +[string-length (-String . -> . -PositiveFixnum)] +[unsafe-string-length (-String . -> . -PositiveFixnum)] [symbol? (make-pred-ty Sym)] [keyword? (make-pred-ty -Keyword)] @@ -301,7 +301,7 @@ [reverse (-poly (a) (-> (-lst a) (-lst a)))] [append (-poly (a) (->* (list) (-lst a) (-lst a)))] -[length (-poly (a) (-> (-lst a) -Nat))] +[length (-poly (a) (-> (-lst a) -PositiveFixnum))] [memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))] [memv (-poly (a) (-> a (-lst a) (-opt (-lst a))))] [memf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt (-lst a))))] @@ -354,7 +354,7 @@ [char-downcase (-> -Char -Char)] [char-titlecase (-> -Char -Char)] [char-foldcase (-> -Char -Char)] -[char->integer (-> -Char -Nat)] +[char->integer (-> -Char -PositiveFixnum)] [integer->char (-> -Nat -Char)] [char-utf-8-length (-> -Char (apply Un (map -val '(1 2 3 4 5 6))))] @@ -481,16 +481,16 @@ [vector->list (-poly (a) (-> (-vec a) (-lst a)))] [list->vector (-poly (a) (-> (-lst a) (-vec a)))] -[vector-length ((make-VectorTop) . -> . -Nat)] +[vector-length ((make-VectorTop) . -> . -PositiveFixnum)] [vector (-poly (a) (->* (list) a (-vec a)))] [vector-immutable (-poly (a) (->* (list) a (-vec a)))] [vector->immutable-vector (-poly (a) (-> (-vec a) (-vec a)))] [vector-fill! (-poly (a) (-> (-vec a) a -Void))] [vector-argmax (-poly (a) (-> (-> a -Real) (-vec a) a))] [vector-argmin (-poly (a) (-> (-> a -Real) (-vec a) a))] -[vector-memq (-poly (a) (-> a (-vec a) (-opt -Nat)))] -[vector-memv (-poly (a) (-> a (-vec a) (-opt -Nat)))] -[vector-member (-poly (a) (a (-vec a) . -> . (-opt -Nat)))] +[vector-memq (-poly (a) (-> a (-vec a) (-opt -PositiveFixnum)))] +[vector-memv (-poly (a) (-> a (-vec a) (-opt -PositiveFixnum)))] +[vector-member (-poly (a) (a (-vec a) . -> . (-opt -PositiveFixnum)))] ;; [vector->values no good type here] @@ -548,7 +548,7 @@ [hash-remove! (-poly (a b) ((-HT a b) a . -> . -Void))] [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) -Nat))] +[hash-count (-poly (a b) (-> (-HT a b) -PositiveFixnum))] [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))] @@ -570,10 +570,9 @@ [bytes->immutable-bytes (-> -Bytes -Bytes)] [byte? (make-pred-ty -Nat)] [bytes-append (->* (list) -Bytes -Bytes)] -[bytes-length (-> -Bytes -Nat)] -[unsafe-bytes-length (-> -Bytes -Nat)] +[bytes-length (-> -Bytes -PositiveFixnum)] +[unsafe-bytes-length (-> -Bytes -PositiveFixnum)] [bytes-copy (-> -Bytes -Bytes)] -[unsafe-bytes-length (-> -Bytes -Nat)] [bytes->list (-> -Bytes (-lst -Nat))] [list->bytes (-> (-lst -Integer) -Bytes)] [bytes* (list -Bytes) -Bytes B)] @@ -712,7 +711,7 @@ (-lst a)) ((-lst b) b) . ->... . - -Nat))] + -PositiveFixnum))] [filter-map (-polydots (c a b) ((list ((list a) (b b) . ->... . (-opt c)) @@ -809,8 +808,8 @@ ;; unsafe -[unsafe-vector-length (-poly (a) ((-vec a) . -> . -Nat))] -[unsafe-vector*-length (-poly (a) ((-vec a) . -> . -Nat))] +[unsafe-vector-length (-poly (a) ((-vec a) . -> . -PositiveFixnum))] +[unsafe-vector*-length (-poly (a) ((-vec a) . -> . -PositiveFixnum))] [unsafe-car (-poly (a b) (cl->* (->acc (list (-pair a b)) a (list -car)) @@ -828,7 +827,7 @@ (-vec a)) ((-vec b) b) . ->... . - -Nat))] + -PositiveFixnum))] [vector-filter (-poly (a b) (cl->* ((make-pred-ty (list a) Univ b) (-vec a) @@ -905,6 +904,6 @@ (-> (-mlst a) (-mlst a) -Void)))] [mpair? (make-pred-ty (make-MPairTop))] [mlist (-poly (a) (->* (list) a (-mlst a)))] -[mlength (-poly (a) (-> (-mlst a) -Nat))] +[mlength (-poly (a) (-> (-mlst a) -PositiveFixnum))] [mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))] [mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))] diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index 0b9e7b8f..f20b9e4a 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -8,6 +8,8 @@ [Float -Flonum] [Exact-Positive-Integer -ExactPositiveInteger] [Exact-Nonnegative-Integer -ExactNonnegativeInteger] +[Positive-Fixnum -PositiveFixnum] +[Fixnum -Fixnum] [Natural -ExactNonnegativeInteger] [Zero (-val 0)] diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 8a55e2d3..522caa3f 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -13,6 +13,7 @@ (env lexical-env type-env-structs tvar-env index-env) racket/private/class-internal unstable/debug (except-in syntax/parse id) + unstable/function (only-in srfi/1 split-at)) (require (for-template scheme/base racket/private/class-internal)) @@ -33,10 +34,13 @@ [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 exact-positive-integer?)) -ExactPositiveInteger] [(~var i (3d exact-nonnegative-integer?)) -ExactNonnegativeInteger] [(~var i (3d exact-integer?)) -Integer] - [(~var i (3d (lambda (e) (and (number? e) (exact? e) (rational? e))))) -ExactRational] + [(~var i (3d (conjoin number? exact? rational?))) -ExactRational] [(~var i (3d inexact-real?)) -Flonum] [(~var i (3d real?)) -Real] [(~var i (3d number?)) -Number] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 0ab61f3d..3e353317 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -158,12 +158,18 @@ (define -ExactPositiveInteger (make-Base 'Exact-Positive-Integer #'exact-positive-integer?)) +(define -PositiveFixnum + (make-Base 'Positive-Fixnum #'(and/c number? fixnum? positive?))) +(define -NegativeFixnum + (make-Base 'Negative-Fixnum #'(and/c number? fixnum? negative?))) + (define -Zero (-val 0)) (define -Real (*Un -Flonum -ExactRational)) +(define -Fixnum (*Un -PositiveFixnum -NegativeFixnum -Zero)) (define -ExactNonnegativeInteger (*Un -ExactPositiveInteger -Zero)) (define -Nat -ExactNonnegativeInteger) -(define -Byte -Number) +(define -Byte -Integer) diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index fde4c808..a5167c48 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -237,11 +237,27 @@ [((Base: 'Exact-Positive-Integer _) (Base: 'Number _)) A0] [((Base: 'Exact-Positive-Integer _) (== -Nat =t)) A0] [((Base: 'Exact-Positive-Integer _) (Base: 'Integer _)) A0] + + [((Base: 'Positive-Fixnum _) (Base: 'Exact-Positive-Integer _)) A0] + [((Base: 'Positive-Fixnum _) (Base: 'Exact-Rational _)) A0] + [((Base: 'Positive-Fixnum _) (Base: 'Number _)) A0] + [((Base: 'Positive-Fixnum _) (== -Nat =t)) A0] + [((Base: 'Positive-Fixnum _) (Base: 'Integer _)) A0] + + [((Base: 'Negative-Fixnum _) (Base: 'Exact-Rational _)) A0] + [((Base: 'Negative-Fixnum _) (Base: 'Number _)) A0] + [((Base: 'Negative-Fixnum _) (Base: 'Integer _)) A0] + [((== -Nat =t) (Base: 'Number _)) A0] [((== -Nat =t) (Base: 'Exact-Rational _)) A0] [((== -Nat =t) (Base: 'Integer _)) A0] - ;; values are subtypes of their "type" + [((== -Fixnum =t) (Base: 'Number _)) A0] + [((== -Fixnum =t) (Base: 'Exact-Rational _)) A0] + [((== -Fixnum =t) (Base: 'Integer _)) A0] + + + ;; values are subtypes of their "type" [((Value: (? exact-integer? n)) (Base: 'Integer _)) A0] [((Value: (and n (? number?) (? exact?) (? rational?))) (Base: 'Exact-Rational _)) A0] [((Value: (? exact-nonnegative-integer? n)) (== -Nat =t)) A0] From 680e7fee29601fc4d84e6667d8689bf26c3df121 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 24 Jun 2010 18:17:01 -0400 Subject: [PATCH 121/198] More fixnum improvements. original commit: 3251712ef79832415b371a7ff2c6593da0372411 --- collects/typed-scheme/private/base-env-numeric.rkt | 2 +- collects/typed-scheme/typecheck/tc-app.rkt | 9 +++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index dd708b0b..cb561075 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -53,7 +53,7 @@ [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 -Flonum 0)))] -[fixnum? (asym-pred Univ B (-FS (-filter -Integer 0) -top))] +[fixnum? (make-pred-ty -Fixnum)] [positive? (-> -Real B)] [negative? (-> -Real B)] [exact-positive-integer? (make-pred-ty -Pos)] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index a03531ff..95707e7f 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -599,11 +599,12 @@ [_ (int-err "bad expected: ~a" expected)])] ;; special case for `-' used like `sub1' [(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1))) - (add-typeof-expr #'arg2 (ret -Nat)) + (add-typeof-expr #'arg2 (ret -PositiveFixnum)) (match-let ([(tc-result1: t) (single-value #'v)]) - (if (subtype t -ExactPositiveInteger) - (ret -Nat) - (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)))] + (cond + [(subtype t (Un -Zero -PositiveFixnum)) (ret -Fixnum)] + [(subtype t -ExactPositiveInteger) (ret -Nat)] + [else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))] ;; call-with-values [(#%plain-app call-with-values prod con) (match (tc/funapp #'prod #'() (single-value #'prod) null #f) From b8378a32a75e6ec2623b52a3d305212ff1072328 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 23 Jun 2010 19:37:23 -0400 Subject: [PATCH 122/198] Added better tracing to the optimizer. original commit: d47221c55dba99ecbce45affa92011203b02bb9e --- collects/typed-scheme/private/optimize.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 5d466deb..c415b1b4 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -63,8 +63,9 @@ (define *optimization-log-file* "opt-log") (define (log-optimization kind stx) (if *log-optimizations?* - (printf "~a line ~a col ~a - ~a\n" + (printf "~a line ~a col ~a - ~a - ~a\n" (syntax-source stx) (syntax-line stx) (syntax-column stx) + (syntax->datum stx) kind) #t)) From 92347a18b6321df5196f823070bee69275d24667 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 23 Jun 2010 16:58:18 -0400 Subject: [PATCH 123/198] Wrote a test harness and a couple of tests for Typed Scheme's optimizer. original commit: fd987546b3d0293edba097f940c33fbdbf6c3b86 --- .../optimizer/generic/begin-float.rkt | 4 +++ .../optimizer/generic/define-begin-float.rkt | 4 +++ .../optimizer/generic/define-call-float.rkt | 3 ++ .../optimizer/generic/define-float.rkt | 3 ++ .../optimizer/generic/define-pair.rkt | 3 ++ .../optimizer/generic/double-float.rkt | 3 ++ .../optimizer/generic/float-fun.rkt | 5 +++ .../optimizer/generic/float-promotion.rkt | 3 ++ .../generic/invalid-float-promotion.rkt | 3 ++ .../optimizer/generic/let-float.rkt | 4 +++ .../optimizer/generic/nested-float.rkt | 3 ++ .../optimizer/generic/nested-float2.rkt | 3 ++ .../optimizer/generic/nested-pair1.rkt | 3 ++ .../optimizer/generic/nested-pair2.rkt | 3 ++ .../optimizer/generic/pair-fun.rkt | 7 ++++ .../optimizer/generic/simple-float.rkt | 3 ++ .../optimizer/generic/simple-pair.rkt | 3 ++ .../optimizer/generic/unary-float.rkt | 3 ++ collects/tests/typed-scheme/optimizer/run.rkt | 32 +++++++++++++++++++ 19 files changed, 95 insertions(+) create mode 100644 collects/tests/typed-scheme/optimizer/generic/begin-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/define-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/define-pair.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/double-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/float-fun.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/let-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/nested-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/simple-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/unary-float.rkt create mode 100644 collects/tests/typed-scheme/optimizer/run.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt b/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt new file mode 100644 index 00000000..a3bb961e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/begin-float.rkt @@ -0,0 +1,4 @@ +(module begin-float typed/scheme #:optimize + (require racket/unsafe/ops) + (begin (- 2.0 3.0) + (* 2.0 3.0))) diff --git a/collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt b/collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt new file mode 100644 index 00000000..508bd0e5 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/define-begin-float.rkt @@ -0,0 +1,4 @@ +(module define-begin-float typed/scheme #:optimize + (require racket/unsafe/ops) + (define a (begin (display (- 2.0 3.0)) + (* 2.0 3.0)))) diff --git a/collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt b/collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt new file mode 100644 index 00000000..fe2ff165 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/define-call-float.rkt @@ -0,0 +1,3 @@ +(module define-call-float typed/scheme #:optimize + (require racket/unsafe/ops) + (define x (cons (+ 1.0 2.0) 3.0))) diff --git a/collects/tests/typed-scheme/optimizer/generic/define-float.rkt b/collects/tests/typed-scheme/optimizer/generic/define-float.rkt new file mode 100644 index 00000000..9dfeb431 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/define-float.rkt @@ -0,0 +1,3 @@ +(module define-float typed/scheme #:optimize + (require racket/unsafe/ops) + (define x (+ 1.0 2.0))) diff --git a/collects/tests/typed-scheme/optimizer/generic/define-pair.rkt b/collects/tests/typed-scheme/optimizer/generic/define-pair.rkt new file mode 100644 index 00000000..ec30e20c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/define-pair.rkt @@ -0,0 +1,3 @@ +(module define-pair typed/scheme #:optimize + (require racket/unsafe/ops) + (define x (car '(1 3)))) diff --git a/collects/tests/typed-scheme/optimizer/generic/double-float.rkt b/collects/tests/typed-scheme/optimizer/generic/double-float.rkt new file mode 100644 index 00000000..1d686451 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/double-float.rkt @@ -0,0 +1,3 @@ +(module double-float typed/scheme #:optimize + (require racket/unsafe/ops) + (+ 2.0 2.0 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/float-fun.rkt b/collects/tests/typed-scheme/optimizer/generic/float-fun.rkt new file mode 100644 index 00000000..788a2181 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/float-fun.rkt @@ -0,0 +1,5 @@ +(module float-fun typed/scheme #:optimize + (require racket/unsafe/ops) + (: f (Float -> Float)) + (define (f x) + (+ x 1.0))) diff --git a/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt new file mode 100644 index 00000000..3df6f684 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt @@ -0,0 +1,3 @@ +(module float-promotion typed/scheme #:optimize + (require racket/unsafe/ops racket/flonum) + (+ 1 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt new file mode 100644 index 00000000..ee0f3875 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt @@ -0,0 +1,3 @@ +(module float-promotion typed/scheme #:optimize + (require racket/unsafe/ops) + (/ 1 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/let-float.rkt b/collects/tests/typed-scheme/optimizer/generic/let-float.rkt new file mode 100644 index 00000000..98e6a9fe --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/let-float.rkt @@ -0,0 +1,4 @@ +(module let-float typed/scheme #:optimize + (require racket/unsafe/ops) + (let ((x (+ 3.0 2.0))) + (* 9.0 x))) diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt new file mode 100644 index 00000000..04950423 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/nested-float.rkt @@ -0,0 +1,3 @@ +(module nested-float typed/scheme #:optimize + (require racket/unsafe/ops) + (+ 2.0 (+ 3.0 4.0))) diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt new file mode 100644 index 00000000..ebe30a18 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/nested-float2.rkt @@ -0,0 +1,3 @@ +(module nested-float typed/scheme #:optimize + (require racket/unsafe/ops) + (+ 2.0 (* 3.0 4.0))) diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt new file mode 100644 index 00000000..744d0c83 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/nested-pair1.rkt @@ -0,0 +1,3 @@ +(module nested-pair typed/scheme #:optimize + (require racket/unsafe/ops) + (car (cdr '(1 2)))) diff --git a/collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt b/collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt new file mode 100644 index 00000000..a4c429d1 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/nested-pair2.rkt @@ -0,0 +1,3 @@ +(module nested-pair2 typed/scheme #:optimize + (require racket/unsafe/ops) + (car (cdr (cons 3 (cons (cons 2 '()) 1))))) diff --git a/collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt b/collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt new file mode 100644 index 00000000..2fea5497 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/pair-fun.rkt @@ -0,0 +1,7 @@ +(module pair-fun typed/scheme #:optimize + (require racket/unsafe/ops) + (: f ((Listof Integer) -> Integer)) + (define (f x) + (if (null? x) + 1 + (car x)))) diff --git a/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt b/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt new file mode 100644 index 00000000..90676b7a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/simple-float.rkt @@ -0,0 +1,3 @@ +(module simple-float typed/scheme #:optimize + (require racket/unsafe/ops) + (+ 2.0 3.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt b/collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt new file mode 100644 index 00000000..e5f69f70 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/simple-pair.rkt @@ -0,0 +1,3 @@ +(module simple-pair typed/scheme #:optimize + (require racket/unsafe/ops) + (car (cons 1 2))) diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt new file mode 100644 index 00000000..d57f3950 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/unary-float.rkt @@ -0,0 +1,3 @@ +(module float-unary typed/scheme #:optimize + (require racket/unsafe/ops) + (sin 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt new file mode 100644 index 00000000..331f3712 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/run.rkt @@ -0,0 +1,32 @@ +#lang racket + +;; since Typed Scheme's optimizer does source to source transformations, +;; we compare the expansion of automatically optimized and hand optimized +;; modules +(define (read-and-expand file) + (syntax->datum + (parameterize ([current-namespace (make-base-namespace)]) + (with-handlers + ([exn:fail? (lambda (exn) + (printf "~a\n" (exn-message exn)) + #'#f)]) + (expand (with-input-from-file file read-syntax)))))) + +(define (test gen) + (let-values (((base name _) (split-path gen))) + (or (regexp-match ".*~" name) ; we ignore backup files + (equal? (read-and-expand gen) + (read-and-expand (build-path base "../hand-optimized/" name))) + (begin (printf "~a failed\n\n" name) + #f)))) + +(let ((n-failures + (if (> (vector-length (current-command-line-arguments)) 0) + (if (test (format "generic/~a.rkt" + (vector-ref (current-command-line-arguments) 0))) + 0 1) + (for/fold ((n-failures 0)) + ((gen (in-directory "generic"))) + (+ n-failures (if (test gen) 0 1)))))) + (unless (= n-failures 0) + (error (format "~a tests failed." n-failures)))) From 773d817389a91797d0554d9d3010059665f6a1d1 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 24 Jun 2010 13:20:47 -0400 Subject: [PATCH 124/198] Typed Scheme now optimizes (fl)vector-length for all vectors and vector-(ref,set!) for vectors of known length. original commit: b345d5f0f0d2b8bbf02a5a97b335e288ef172e58 --- .../optimizer/generic/flvector-length.rkt | 3 ++ .../generic/invalid-float-promotion.rkt | 3 +- .../optimizer/generic/invalid-vector-ref.rkt | 2 + .../optimizer/generic/invalid-vector-set.rkt | 2 + .../typed-scheme/optimizer/generic/quote.rkt | 2 + .../generic/vector-length-nested.rkt | 7 ++++ .../optimizer/generic/vector-length.rkt | 3 ++ .../optimizer/generic/vector-ref-set-ref.rkt | 7 ++++ .../optimizer/generic/vector-ref.rkt | 3 ++ .../optimizer/generic/vector-set-quote.rkt | 5 +++ .../optimizer/generic/vector-set.rkt | 5 +++ collects/typed-scheme/private/optimize.rkt | 38 +++++++++++++++++++ 12 files changed, 78 insertions(+), 2 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/quote.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/vector-length-nested.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/vector-length.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/vector-ref-set-ref.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/vector-ref.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/vector-set-quote.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/vector-set.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt b/collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt new file mode 100644 index 00000000..34add429 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/flvector-length.rkt @@ -0,0 +1,3 @@ +(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/invalid-float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt index ee0f3875..169909be 100644 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-float-promotion.rkt @@ -1,3 +1,2 @@ (module float-promotion typed/scheme #:optimize - (require racket/unsafe/ops) - (/ 1 2.0)) + (/ 1 2.0)) ; result is not a float, 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 new file mode 100644 index 00000000..0336e109 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt @@ -0,0 +1,2 @@ +(module invalid-vector-ref typed/scheme #:optimize + (vector-ref (vector 1 2 3) 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 new file mode 100644 index 00000000..91f333c7 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt @@ -0,0 +1,2 @@ +(module invalid-vector-set 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/generic/quote.rkt b/collects/tests/typed-scheme/optimizer/generic/quote.rkt new file mode 100644 index 00000000..2d62416f --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/quote.rkt @@ -0,0 +1,2 @@ +(module quote typed/scheme #:optimize + '(+ 1.0 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 new file mode 100644 index 00000000..ade363e1 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/vector-length-nested.rkt @@ -0,0 +1,7 @@ +(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 new file mode 100644 index 00000000..51093a09 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/vector-length.rkt @@ -0,0 +1,3 @@ +(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 new file mode 100644 index 00000000..711633ea --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/vector-ref-set-ref.rkt @@ -0,0 +1,7 @@ +(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 new file mode 100644 index 00000000..00261f8a --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/vector-ref.rkt @@ -0,0 +1,3 @@ +(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-set-quote.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-set-quote.rkt new file mode 100644 index 00000000..063b78d3 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/vector-set-quote.rkt @@ -0,0 +1,5 @@ +(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 new file mode 100644 index 00000000..5f29aa5e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/vector-set.rkt @@ -0,0 +1,5 @@ +(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/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index c415b1b4..09c38d9f 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -54,6 +54,18 @@ (pattern (~literal car) #:with unsafe #'unsafe-car) (pattern (~literal cdr) #:with unsafe #'unsafe-cdr)) +(define-syntax-class vector-opt-expr + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (HeterogenousVector: _)) #t] + [_ #f]) + #:with opt #'e.opt)) + +(define-syntax-class vector-op + ;; 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!)) + (define-syntax-class opt-expr (pattern e:opt-expr* #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f))) @@ -90,6 +102,32 @@ #:with opt (begin (log-optimization "unary pair" #'op) #'(op.unsafe p.opt))) + ;; we can optimize vector-length on all vectors. + ;; since the program typechecked, we know the arg is a vector. + ;; we can optimize no matter what. + (pattern (#%plain-app (~literal vector-length) v:opt-expr) + #:with opt + (begin (log-optimization "vector" #'op) + #'(unsafe-vector*-length v.opt))) + ;; same for flvector-length + (pattern (#%plain-app (~literal flvector-length) v:opt-expr) + #:with opt + (begin (log-optimization "flvector" #'op) + #'(unsafe-flvector-length v.opt))) + ;; 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) + (pattern (#%plain-app op:vector-op v:vector-opt-expr i:opt-expr new:opt-expr ...) + #:when (let ((len (match (type-of #'v) + [(tc-result1: (HeterogenousVector: es)) (length es)] + [_ 0])) + (ival (or (syntax-parse #'i [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) + (match (type-of #'i) + [(tc-result1: (Value: (? number? i))) i] + [_ #f])))) + (and (integer? ival) (exact? ival) (<= 0 ival (sub1 len)))) + #:with opt + (begin (log-optimization "vector" #'op) + #'(op.unsafe v.opt i.opt new.opt ...))) ;; boring cases, just recur down (pattern (#%plain-lambda formals e:opt-expr ...) From fe3ce60a2619918065634acdd320bbbb1dfee4a7 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 24 Jun 2010 17:13:09 -0400 Subject: [PATCH 125/198] Typed Scheme now optimizes (exact->inexact ) to (->fl ). original commit: d6008f9191c5e00e335d2f683fecbc9d09c34475 --- collects/typed-scheme/private/optimize.rkt | 26 +++++++++++++++------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 09c38d9f..6d769493 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -12,18 +12,20 @@ [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) #:with opt #'e.opt)) +(define-syntax-class int-opt-expr + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -Integer (lambda (x y) (subtype y x)))) #t] [_ #f]) + #:with opt #'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 - (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (== -Integer (lambda (x y) (subtype y x)))) #t] [_ #f]) + (pattern e:int-opt-expr #:with opt #'(->fl e.opt)) - (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) + (pattern e:float-opt-expr #:with opt #'e.opt)) (define (mk-float-tbl generic) @@ -98,19 +100,27 @@ (for/fold ([o #'f1.opt]) ([e (syntax->list #'(f2.opt fs.opt ...))]) #`(op.unsafe #,o #,e)))) + + ;; we can optimize exact->inexact if we know we're giving it an Integer + (pattern (#%plain-app (~and op (~literal exact->inexact)) n:int-opt-expr) + #:with opt + (begin (log-optimization "int to float" #'op) + #'(->fl n.opt))) + (pattern (#%plain-app op:pair-unary-op p:pair-opt-expr) #:with opt (begin (log-optimization "unary pair" #'op) #'(op.unsafe p.opt))) + ;; we can optimize vector-length on all vectors. ;; since the program typechecked, we know the arg is a vector. ;; we can optimize no matter what. - (pattern (#%plain-app (~literal vector-length) v:opt-expr) + (pattern (#%plain-app (~and op (~literal vector-length)) v:opt-expr) #:with opt (begin (log-optimization "vector" #'op) #'(unsafe-vector*-length v.opt))) ;; same for flvector-length - (pattern (#%plain-app (~literal flvector-length) v:opt-expr) + (pattern (#%plain-app (~and op (~literal flvector-length)) v:opt-expr) #:with opt (begin (log-optimization "flvector" #'op) #'(unsafe-flvector-length v.opt))) From e96760613b1d5027c6a0e3a36021bb12efdcf64e Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 24 Jun 2010 18:47:42 -0400 Subject: [PATCH 126/198] Fixed the optimizer so that it optimizes float comparisons. original commit: 382a45ad6fe99f758451631b07fac393333893a8 --- collects/typed-scheme/private/optimize.rkt | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 6d769493..b77d9802 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -34,7 +34,9 @@ (dict-set (dict-set h g u) f u)))) (define binary-float-ops - (mk-float-tbl (list #'+ #'- #'* #'/ #'= #'<= #'< #'> #'>= #'min #'max))) + (mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max))) +(define binary-float-comps + (mk-float-tbl (list #'= #'<= #'< #'> #'>=))) (define unary-float-ops (mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp @@ -94,12 +96,21 @@ ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments (pattern (~and res (#%plain-app (~var op (float-op binary-float-ops)) f1:float-arg-expr f2:float-arg-expr fs:float-arg-expr ...)) #:when (match (type-of #'res) + ;; if the result is a float, we can coerce integers to floats and optimize [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) #:with opt (begin (log-optimization "binary float" #'op) (for/fold ([o #'f1.opt]) ([e (syntax->list #'(f2.opt fs.opt ...))]) #`(op.unsafe #,o #,e)))) + (pattern (~and res (#%plain-app (~var op (float-op binary-float-comps)) f1:float-opt-expr f2:float-opt-expr fs:float-opt-expr ...)) + #:when (match (type-of #'res) + [(tc-result1: (== -Boolean type-equal?)) #t] [_ #f]) + #:with opt + (begin (log-optimization "binary float comp" #'op) + (for/fold ([o #'f1.opt]) + ([e (syntax->list #'(f2.opt fs.opt ...))]) + #`(op.unsafe #,o #,e)))) ;; we can optimize exact->inexact if we know we're giving it an Integer (pattern (#%plain-app (~and op (~literal exact->inexact)) n:int-opt-expr) From db81a50276a65160b252a2db455a713f5afde365 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 25 Jun 2010 13:24:29 -0400 Subject: [PATCH 127/198] Fixed Typed Scheme's optimizer's test harness to work with drdr. original commit: 28acece484b050cd42f57c3826e47d92bde31aee --- collects/tests/typed-scheme/optimizer/run.rkt | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt index 331f3712..1ff2c4c8 100644 --- a/collects/tests/typed-scheme/optimizer/run.rkt +++ b/collects/tests/typed-scheme/optimizer/run.rkt @@ -1,4 +1,5 @@ #lang racket +(require racket/runtime-path) ;; since Typed Scheme's optimizer does source to source transformations, ;; we compare the expansion of automatically optimized and hand optimized @@ -20,13 +21,15 @@ (begin (printf "~a failed\n\n" name) #f)))) +(define-runtime-path here ".") + (let ((n-failures (if (> (vector-length (current-command-line-arguments)) 0) (if (test (format "generic/~a.rkt" (vector-ref (current-command-line-arguments) 0))) 0 1) (for/fold ((n-failures 0)) - ((gen (in-directory "generic"))) + ((gen (in-directory (build-path here "generic")))) (+ n-failures (if (test gen) 0 1)))))) (unless (= n-failures 0) (error (format "~a tests failed." n-failures)))) From e3f8fff0e84c05e8f9bd0c73af0bae05c7b3b7ef Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 27 Jun 2010 20:07:33 -0400 Subject: [PATCH 128/198] Generalize mutated variables when inferring types. original commit: 90d8a3cc13dd76ba8d1eaefa98ee5e3248e43b04 --- .../typed-scheme/private/type-annotation.rkt | 40 ++++++++----------- .../typed-scheme/typecheck/tc-let-unit.rkt | 10 ++--- 2 files changed, 21 insertions(+), 29 deletions(-) diff --git a/collects/typed-scheme/private/type-annotation.rkt b/collects/typed-scheme/private/type-annotation.rkt index 7bb90cb7..75c4db9a 100644 --- a/collects/typed-scheme/private/type-annotation.rkt +++ b/collects/typed-scheme/private/type-annotation.rkt @@ -112,49 +112,41 @@ (map (lambda (e) (get-type e #:default default)) stxs)) ;; list[identifier] stx (stx -> tc-results?) (stx tc-results? -> tc-results?) -> tc-results? +;; stxs : the identifiers, possibly with type annotations on them +;; expr : the RHS expression +;; tc-expr : a function like `tc-expr' from tc-expr-unit +;; tc-expr/check : a function like `tc-expr/check' from tc-expr-unit (d/c (get-type/infer stxs expr tc-expr tc-expr/check) ((listof identifier?) syntax? (syntax? . -> . tc-results?) (syntax? tc-results? . -> . tc-results?) . -> . tc-results?) (match stxs - ['() - (tc-expr/check expr (ret null))] - [(list stx) - (cond [(type-annotation stx #:infer #t) - => (lambda (ann) - (tc-expr/check expr (ret ann)))] - [else (tc-expr expr)])] [(list stx ...) (let ([anns (for/list ([s stxs]) (type-annotation s #:infer #t))]) (if (for/and ([a anns]) a) - (begin (tc-expr/check expr (ret anns))) + (tc-expr/check expr (ret anns)) (let ([ty (tc-expr expr)]) (match ty - [(tc-results: tys) + [(tc-results: tys fs os) (if (not (= (length stxs) (length tys))) (begin (tc-error/delayed "Expression should produce ~a values, but produces ~a values of types ~a" (length stxs) (length tys) (stringify tys)) (ret (map (lambda _ (Un)) stxs))) - (ret - (for/list ([stx stxs] [ty tys] [a anns]) - (cond [a => (lambda (ann) (check-type stx ty ann) ann)] - [else ty]))))] - [ty (tc-error/delayed - "Expression should produce ~a values, but produces one values of type ~a" - (length stxs) ty) - (ret (map (lambda _ (Un)) stxs))]))))])) - + (combine-results + (for/list ([stx stxs] [ty tys] [a anns] [f fs] [o os]) + (cond [a (check-type stx ty a) (ret a f o)] + ;; mutated variables get generalized, so that we don't infer too small a type + [(is-var-mutated? stx) (ret (generalize ty) f o)] + [else (ret ty f o)]))))]))))])) ;; check that e-type is compatible with ty in context of stx ;; otherwise, error ;; syntax type type -> void - (define (check-type stx e-type ty) - (let ([stx* (current-orig-stx)]) - (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))))) + (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)))) (define (dotted? stx) (cond [(syntax-property stx type-dotted-symbol) => syntax-e] diff --git a/collects/typed-scheme/typecheck/tc-let-unit.rkt b/collects/typed-scheme/typecheck/tc-let-unit.rkt index 32c6c355..2f64af3a 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-let-unit.rkt @@ -1,4 +1,4 @@ -#lang scheme/unit +#lang racket/unit (require (rename-in "../utils/utils.rkt" [infer r:infer])) (require "signatures.rkt" "tc-metafunctions.rkt" "tc-subst.rkt" @@ -7,12 +7,12 @@ (env lexical-env type-alias-env global-env type-env-structs) (rep type-rep) syntax/free-vars - mzlib/trace unstable/debug - scheme/match (prefix-in c: scheme/contract) - (except-in scheme/contract -> ->* one-of/c) + racket/trace unstable/debug + racket/match (prefix-in c: racket/contract) + (except-in racket/contract -> ->* one-of/c) syntax/kerncase syntax/parse (for-template - scheme/base + racket/base "internal-forms.rkt")) (require (only-in srfi/1/list s:member)) From 5883e7e81829dd6fa6a9f29f90dfe65d4137b395 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 27 Jun 2010 20:07:54 -0400 Subject: [PATCH 129/198] Use get-type/infer for un-annotated defines. original commit: 0bae63b516a3081276aefd1e2d46b28eba4f31be --- .../typed-scheme/typecheck/tc-toplevel.rkt | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index 4fab6fc5..3b6d5d14 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -34,8 +34,6 @@ (define unann-defs (make-free-id-table)) (define (tc-toplevel/pass1 form) - ;(printf "form-top: ~a~n" form) - ;; first, find the mutated variables: (parameterize ([current-orig-stx form]) (syntax-parse form #:literals (values define-type-alias-internal define-typed-struct-internal define-type-internal @@ -137,16 +135,14 @@ [(andmap (lambda (s) (lookup-type s (lambda () #f))) vars) (for-each finish-register-type vars) (map (lambda (s) (make-def-binding s (lookup-type s))) vars)] - ;; special case to infer types for top level defines - should handle the multiple values case here - [(= 1 (length vars)) - (match (tc-expr #'expr) - [(tc-result1: t) - (register-type (car vars) t) - (free-id-table-set! unann-defs (car vars) #t) - (list (make-def-binding (car vars) t))] - [t (int-err "~a is not a tc-result" t)])] + ;; special case to infer types for top level defines [else - (tc-error "Untyped definition : ~a" (map syntax-e vars))]))] + (match (get-type/infer vars #'expr tc-expr tc-expr/check) + [(tc-results: ts) + (for/list ([i (in-list vars)] [t (in-list ts)]) + (register-type i t) + (free-id-table-set! unann-defs i #t) + (make-def-binding i t))])]))] ;; to handle the top-level, we have to recur into begins [(begin . rest) From efa50529d0ec63c6c29909549a0cf4eeb9e11e28 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 27 Jun 2010 20:28:17 -0400 Subject: [PATCH 130/198] remove unneeded export original commit: a214f50812546e045ff9ca3c6273a06f89c4bdf9 --- collects/typed-scheme/typecheck/signatures.rkt | 3 +-- collects/typed-scheme/typecheck/tc-expr-unit.rkt | 2 +- collects/typed-scheme/typecheck/tc-let-unit.rkt | 8 +------- 3 files changed, 3 insertions(+), 10 deletions(-) diff --git a/collects/typed-scheme/typecheck/signatures.rkt b/collects/typed-scheme/typecheck/signatures.rkt index 14103c35..3411232e 100644 --- a/collects/typed-scheme/typecheck/signatures.rkt +++ b/collects/typed-scheme/typecheck/signatures.rkt @@ -37,8 +37,7 @@ (define-signature tc-let^ ([cnt tc/let-values ((syntax? syntax? syntax? syntax?) ((or/c #f tc-results?)) . ->* . tc-results?)] - [cnt tc/letrec-values (syntax? syntax? syntax? syntax? . -> . tc-results?)] - [cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? tc-results? . -> . tc-results?)])) + [cnt tc/letrec-values ((syntax? syntax? syntax? syntax?) ((or/c #f tc-results?)) . ->* . tc-results?)])) (define-signature tc-dots^ ([cnt tc/dots (syntax? . -> . (values Type/c symbol?))])) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 522caa3f..b1beaeb4 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -389,7 +389,7 @@ [(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/check #'((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))] )))) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.rkt b/collects/typed-scheme/typecheck/tc-let-unit.rkt index 2f64af3a..012ef3ee 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-let-unit.rkt @@ -83,12 +83,6 @@ expected) (run (tc-exprs (syntax->list body))))))) -(define (tc/letrec-values/check namess exprs body form expected) - (tc/letrec-values/internal namess exprs body form expected)) - -(define (tc/letrec-values namess exprs body form) - (tc/letrec-values/internal namess exprs body form #f)) - (define (tc-expr/maybe-expected/t e name) (define expecteds (map (lambda (stx) (lookup-type stx (lambda () #f))) name)) @@ -102,7 +96,7 @@ (tc-expr e))) tcr) -(define (tc/letrec-values/internal namess exprs body form expected) +(define (tc/letrec-values namess exprs body form [expected #f]) (let* ([names (map syntax->list (syntax->list namess))] [orig-flat-names (apply append names)] [exprs (syntax->list exprs)] From 7341d85d623576f9377be000b8a895c67f63d5f8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 28 Jun 2010 07:42:04 -0400 Subject: [PATCH 131/198] Remove bogus reference to 'sexpression', add docs for Sexp type, don't use Sexp where inappropriate original commit: 26e73cf61d80636246dd0bf5912b7670c30698d6 --- collects/typed-scheme/private/base-env.rkt | 6 +++--- collects/typed-scheme/scribblings/ts-reference.scrbl | 4 ++++ collects/typed-scheme/scribblings/types.scrbl | 2 +- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 0552101c..e6d8c3c3 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -190,7 +190,7 @@ 'must-truncate 'truncate/replace) #f -Output-Port)] -[read (->opt [-Input-Port] (Un -Sexp (-val eof)))] +[read (->opt [-Input-Port] Univ)] [ormap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))] [andmap (-polydots (a c d b) (cl->* ;; 1 means predicate on second argument @@ -616,11 +616,11 @@ [delete-file (-> -Pathlike -Void)] [make-namespace (->opt [(Un (-val 'empty) (-val 'initial))] -Namespace)] [make-base-namespace (-> -Namespace)] -[eval (-> -Sexp Univ)] +[eval (->opt Univ [-Namespace] Univ)] [exit (-> (Un))] -[module->namespace (-> -Sexp -Namespace)] +[module->namespace (-> (-mu x (-lst (Un -Symbol -String -Nat x (-val #f)))) -Namespace)] [current-namespace (-Param -Namespace -Namespace)] [getenv (-> -String (Un -String (-val #f)))] diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 8d8ae382..c831a506 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -178,6 +178,10 @@ corresponding to @racket[trest], where @racket[bound] @defform[(Promise t)]{A @rtech{promise} of @racket[t]. @ex[(delay 3)]} +@defidform[Sexp]{A recursive union containing types traversed by +@racket[datum->syntax]. Note that this is @emph{not} the type produced +by @racket[read].} + @subsection{Other Type Constructors} @defform*[#:id -> #:literals (* ...) diff --git a/collects/typed-scheme/scribblings/types.scrbl b/collects/typed-scheme/scribblings/types.scrbl index 467bd742..fdbf1dca 100644 --- a/collects/typed-scheme/scribblings/types.scrbl +++ b/collects/typed-scheme/scribblings/types.scrbl @@ -148,7 +148,7 @@ Typed Racket offers abstraction over types as well as values. @subsection{Polymorphic Data Structures} -Virtually every Racket program uses lists and sexpressions. Fortunately, Typed +Virtually every Racket program uses lists and other collections. Fortunately, Typed Racket can handle these as well. A simple list processing program can be written like this: From 7186e085fa097b30bdfba208310d34caba8464ed Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 28 Jun 2010 17:07:21 -0400 Subject: [PATCH 132/198] minor cleanups original commit: 3c4f1f39b8acf610576f4069c37929f071c60ec3 --- collects/typed-scheme/tc-setup.rkt | 2 ++ collects/typed-scheme/typecheck/tc-app.rkt | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/tc-setup.rkt b/collects/typed-scheme/tc-setup.rkt index 66d1ea32..e3288fe8 100644 --- a/collects/typed-scheme/tc-setup.rkt +++ b/collects/typed-scheme/tc-setup.rkt @@ -36,6 +36,8 @@ [infer-param infer] ;; do we report multiple errors [delay-errors? #t] + ;; do we print the fully-expanded syntax? + [print-syntax? #f] ;; this parameter is just for printing types ;; this is a parameter to avoid dependency issues [current-type-names diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 95707e7f..b3e57940 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -237,11 +237,11 @@ (tc/rec-lambda/check form args body lp (cons acc-ty ts) expected) expected)] ;; special case when argument needs inference - [(_ (body* ...) _) + [(_ body* _) (let ([ts (for/list ([ac (syntax->list actuals)] [f (syntax->list args)]) (let* ([infer-t (or (type-annotation f #:infer #t) - (find-annotation #'(begin body* ...) f))]) + (find-annotation #'(begin . body*) f))]) (if infer-t (begin (check-below (tc-expr/t ac) infer-t) infer-t) From 887f054a5547b7b5aa97a2362086fd70a7b8b106 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 28 Jun 2010 18:50:06 -0400 Subject: [PATCH 133/198] Refactor struct type representation. - fields now represented by fld struct. - mutability on per-field basis - accessors are per field This fixes lots of existing bugs, allows future #:mutable on fields. original commit: c01b2397796cce0ade2ed7515ffe33c9eb338c4f --- .../typed-scheme/unit-tests/subtype-tests.rkt | 15 ++- .../unit-tests/type-equal-tests.rkt | 9 +- collects/typed-scheme/env/init-envs.rkt | 4 +- collects/typed-scheme/infer/infer-unit.rkt | 27 ++-- .../typed-scheme/private/base-special-env.rkt | 2 +- .../typed-scheme/private/type-contract.rkt | 4 +- collects/typed-scheme/rep/rep-utils.rkt | 8 +- collects/typed-scheme/rep/type-rep.rkt | 18 ++- collects/typed-scheme/typecheck/tc-app.rkt | 23 ++-- collects/typed-scheme/typecheck/tc-envops.rkt | 30 +++-- .../typed-scheme/typecheck/tc-structs.rkt | 121 ++++++++++++------ .../typed-scheme/typecheck/tc-toplevel.rkt | 2 +- collects/typed-scheme/types/abbrev.rkt | 10 +- collects/typed-scheme/types/printer.rkt | 7 +- .../typed-scheme/types/remove-intersect.rkt | 33 +++-- collects/typed-scheme/types/subtype.rkt | 26 ++-- collects/typed-scheme/utils/utils.rkt | 14 +- 17 files changed, 225 insertions(+), 128 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt index 2851efd5..b6f5cf92 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.rkt @@ -112,11 +112,15 @@ [(-values (list -Number)) (-values (list Univ))] - [(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number a) null #'values)) . -> . (-lst a))) - ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'values)) + [(-poly (b) ((Un (make-Base 'foo #'dummy) + (-struct 'bar #f + (list (make-fld -Number #'values #f) (make-fld b #'values #f)) + #'values)) + . -> . (-lst b))) + ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values)) . -> . (-lst (-pair -Number (-v a))))] - [(-poly (a) ((-struct 'bar #f (list -Number a) null #'values) . -> . (-lst a))) - ((-struct 'bar #f (list -Number (-pair -Number (-v a))) null #'values) . -> . (-lst (-pair -Number (-v a))))] + [(-poly (b) ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f)) #'values) . -> . (-lst b))) + ((-struct 'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)) #'values) . -> . (-lst (-pair -Number (-v a))))] [(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))] [(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-v b))))] @@ -128,6 +132,9 @@ (FAIL (-> Univ) (null Univ . ->* . Univ)) [(cl->* (-Number . -> . -String) (-Boolean . -> . -String)) ((Un -Boolean -Number) . -> . -String)] + [(-struct 'a #f null #'values) (-struct 'a #f null #'values)] + [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld -String #'values #f)) #'values)] + [(-struct 'a #f (list (make-fld -String #'values #f)) #'values) (-struct 'a #f (list (make-fld Univ #'values #f)) #'values)] )) (define-go diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt b/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt index eaaa1939..3aa1b6f6 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.rkt @@ -24,6 +24,8 @@ #'(test-suite "Tests for type equality" cl1 ... cl2 ...))])) +(define (fld* t) (make-fld t (datum->syntax #'here 'values) #f)) + (define (type-equal-tests) (te-tests [-Number -Number] @@ -38,13 +40,12 @@ ;; found bug [FAIL (Un (-mu heap-node (-struct 'heap-node #f - (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty))) - null #'values)) + (map fld* (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty)))) + #'values)) (-base 'heap-empty)) (Un (-mu heap-node (-struct 'heap-node #f - (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty))) - null #'values)) + (map fld* (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))) #'values)) (-base 'heap-empty))])) (define-go diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt index c5c8e737..caed2eb2 100644 --- a/collects/typed-scheme/env/init-envs.rkt +++ b/collects/typed-scheme/env/init-envs.rkt @@ -25,11 +25,11 @@ [(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))] [(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))] [(Name: stx) `(make-Name (quote-syntax ,stx))] - [(Struct: name parent flds proc poly? pred-id cert acc-ids maker-id) + [(fld: t acc mut) `(make-fld ,(sub t) (quote-syntax acc) ,mut)] + [(Struct: name parent flds proc poly? pred-id cert maker-id) `(make-Struct ,(sub name) ,(sub parent) ,(sub flds) ,(sub proc) ,(sub poly?) (quote-syntax ,pred-id) (syntax-local-certifier) - (list ,@(for/list ([a acc-ids]) `(quote-syntax ,a))) (quote-syntax ,maker-id))] [(App: rator rands stx) `(make-App ,(sub rator) ,(sub rands) (quote-syntax ,stx))] [(Opaque: pred cert) `(make-Opaque (quote-syntax ,pred) (syntax-local-certifier))] diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 2ae4d286..c4a0064a 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -13,7 +13,7 @@ "signatures.rkt" scheme/match mzlib/etc - mzlib/trace racket/contract + racket/trace racket/contract unstable/sequence unstable/list unstable/debug unstable/hash scheme/list) @@ -22,7 +22,7 @@ (define (empty-set) '()) -(define current-seen (make-parameter (empty-set) #;pair?)) +(define current-seen (make-parameter (empty-set))) (define (seen-before s t) (cons (Type-seq s) (Type-seq t))) (define (remember s t A) (cons (seen-before s t) A)) @@ -259,6 +259,15 @@ (cset-meet* (list arg-mapping darg-mapping ret-mapping)))])] [(_ _) (fail! s-arr t-arr)])) +(define (cgen/flds V X Y flds-s flds-t) + (cset-meet* + (for/list ([s (in-list flds-s)] [t (in-list flds-t)]) + (match* (s t) + ;; mutable - invariant + [((fld: s _ #t) (fld: t _ #t)) (cset-meet (cgen V X Y s t) (cgen V X Y t s))] + ;; immutable - covariant + [((fld: s _ #f) (fld: t _ #f)) (cgen V X Y s t)])))) + ;; V : a set of variables not to mention in the constraints ;; X : the set of type variables to be constrained ;; Y : the set of index variables to be constrained @@ -328,13 +337,13 @@ ;; two structs with the same name and parent ;; just check pairwise on the fields - ;; FIXME - wrong for mutable structs! - [((Struct: nm p flds proc _ _ _ _ _) (Struct: nm p flds* proc* _ _ _ _ _)) - (let-values ([(flds flds*) - (cond [(and proc proc*) - (values (cons proc flds) (cons proc* flds*))] - [else (values flds flds*)])]) - (cgen/list V X Y flds flds*))] + [((Struct: nm p flds proc _ _ _ _) (Struct: nm p flds* proc* _ _ _ _)) + (let ([proc-c + (cond [(and proc proc*) + (cg proc proc*)] + [proc* (fail! S T)] + [else empty])]) + (cset-meet proc-c (cgen/flds V X Y flds flds*)))] ;; two struct names, need to resolve b/c one could be a parent [((Name: n) (Name: n*)) diff --git a/collects/typed-scheme/private/base-special-env.rkt b/collects/typed-scheme/private/base-special-env.rkt index 0ccb7b2e..a643b158 100644 --- a/collects/typed-scheme/private/base-special-env.rkt +++ b/collects/typed-scheme/private/base-special-env.rkt @@ -31,7 +31,7 @@ (define-hierarchy child (spec ...) grand ...) ...) (begin - (d-s parent ([name : type] ...) ()) + (d-s parent ([name : type] ...)) (define-sub-hierarchy [child parent] (type ...) (spec ...) grand ...) ...)])) diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt index 26b5b0d7..4d8d6bf8 100644 --- a/collects/typed-scheme/private/type-contract.rkt +++ b/collects/typed-scheme/private/type-contract.rkt @@ -30,7 +30,7 @@ (syntax-parse stx #:literals (define-values) [(define-values (n) _) (let ([typ (if maker? - ((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ) + ((map fld-t (Struct-flds (lookup-type-name (Name-id typ)))) #f . t:->* . typ) typ)]) (with-syntax ([cnt (type->contract typ @@ -165,7 +165,7 @@ #;#'class? #'(class/c (name fcn-cnt) ... (init [by-name-init by-name-cnt] ...)))] [(Value: '()) #'null?] - [(Struct: nm par flds proc poly? pred? cert acc-ids maker-id) + [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred? cert maker-id) (cond [(assf (λ (t) (type-equal? t ty)) structs-seen) => diff --git a/collects/typed-scheme/rep/rep-utils.rkt b/collects/typed-scheme/rep/rep-utils.rkt index 3f789813..36d54264 100644 --- a/collects/typed-scheme/rep/rep-utils.rkt +++ b/collects/typed-scheme/rep/rep-utils.rkt @@ -252,17 +252,11 @@ [stx (or/c #f syntax?)])) [replace-syntax (Rep? syntax? . -> . Rep?)]) - -(define (list-update l k v) - (if (zero? k) - (cons v (cdr l)) - (cons (car l) (list-update (cdr l) (sub1 k) v)))) - (define (replace-field val new-val idx) (define-values (type skipped) (struct-info val)) (define maker (struct-type-make-constructor type)) (define flds (cdr (vector->list (struct->vector val)))) - (apply maker (list-update flds idx new-val))) + (apply maker (list-set flds idx new-val))) (define (replace-syntax rep stx) (replace-field rep stx 3)) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index d0c122f1..203fb4bd 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -14,6 +14,7 @@ (and (Type? e) (not (Scope? e)) (not (arr? e)) + (not (fld? e)) (not (Values? e)) (not (ValuesDots? e)) (not (Result? e))))) @@ -224,21 +225,27 @@ [#:fold-rhs (*Function (map type-rec-id arities))]) +(dt fld ([t Type/c] [acc identifier?] [mutable? boolean?]) + [#:frees (λ (f) (if mutable? (make-invariant (f t)) (f t)))] + [#:fold-rhs (*fld (type-rec-id t) acc mutable?)] + [#:intern (list t (hash-id acc) mutable?)]) + ;; name : symbol ;; parent : Struct -;; flds : Listof[Type] +;; flds : Listof[fld] ;; proc : Function Type ;; poly? : is this a polymorphic type? ;; pred-id : identifier for the predicate of the struct ;; cert : syntax certifier for pred-id -(dt Struct ([name symbol?] - [parent (or/c #f Struct? Name?)] - [flds (listof Type/c)] +;; acc-ids : names of the accessors +;; maker-id : name of the constructor +(dt Struct ([name symbol?] + [parent (or/c #f Struct? Name?)] + [flds (listof fld?)] [proc (or/c #f Function?)] [poly? (or/c #f (listof symbol?))] [pred-id identifier?] [cert procedure?] - [acc-ids (listof identifier?)] [maker-id identifier?]) [#:intern (list name parent flds proc)] [#:frees (λ (f) (combine-frees (map f (append (if proc (list proc) null) @@ -251,7 +258,6 @@ poly? pred-id cert - acc-ids maker-id)] [#:key #f]) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index b3e57940..9644e5f2 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -465,8 +465,11 @@ [(#%plain-app (~and op (~or (~literal unsafe-struct-ref) (~literal unsafe-struct*-ref))) s e:expr) (let ([e-t (single-value #'e)]) (match (single-value #'s) - [(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _) - (? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _)))))) + [(tc-result1: + (and t (or (Struct: _ _ (list (fld: flds _ muts) ...) _ _ _ _ _) + (? needs-resolving? + (app resolve-once + (Struct: _ _ (list (fld: flds _ muts) ...) _ _ _ _ _)))))) (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) (match e-t [(tc-result1: (Value: (? number? i))) i] @@ -477,9 +480,11 @@ (check-below (ret (apply Un flds)) expected) (ret (apply Un flds)))] [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length flds)))) - (if expected - (check-below (ret (list-ref flds ival)) expected) - (ret (list-ref flds ival)))] + (let ([result (if (list-ref muts ival) + (ret (list-ref flds ival)) + ;; FIXME - could do something with paths here + (ret (list-ref flds ival)))]) + (if expected (check-below result expected) result))] [(not (and (integer? ival) (exact? ival))) (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for struct index, but got ~a" ival)] [(< ival 0) @@ -492,8 +497,10 @@ [(#%plain-app (~and op (~or (~literal unsafe-struct-set!) (~literal unsafe-struct*-set!))) s e:expr val:expr) (let ([e-t (single-value #'e)]) (match (single-value #'s) - [(tc-result1: (and t (or (Struct: _ _ flds _ _ _ _ _ _) - (? needs-resolving? (app resolve-once (Struct: _ _ flds _ _ _ _ _ _)))))) + [(tc-result1: (and t (or (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _) + (? needs-resolving? + (app resolve-once + (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _)))))) (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) (match e-t [(tc-result1: (Value: (? number? i))) i] @@ -916,7 +923,7 @@ (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) t argtys expected)] ;; procedural structs - [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _ _))) _) + [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _) (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)] ;; parameters are functions too [((tc-result1: (Param: in out)) (list)) (ret out)] diff --git a/collects/typed-scheme/typecheck/tc-envops.rkt b/collects/typed-scheme/typecheck/tc-envops.rkt index 33410c7f..c7c59fb5 100644 --- a/collects/typed-scheme/typecheck/tc-envops.rkt +++ b/collects/typed-scheme/typecheck/tc-envops.rkt @@ -9,17 +9,13 @@ (rep type-rep object-rep) (utils tc-utils) (types resolve) - (only-in (env type-env-structs lexical-env) env? update-type/lexical env-map env-props replace-props) + (only-in (env type-env-structs lexical-env) + env? update-type/lexical env-map env-props replace-props) scheme/contract scheme/match mzlib/trace unstable/debug unstable/struct (typecheck tc-metafunctions) (for-syntax scheme/base)) -(define (replace-nth l i f) - (cond [(null? l) (error 'replace-nth "list not long enough" l i f)] - [(zero? i) (cons (f (car l)) (cdr l))] - [else (cons (car l) (replace-nth (cdr l) (sub1 i) f))])) - ;(trace replace-nth) (define/contract (update t lo) @@ -42,15 +38,25 @@ (make-Syntax (update t (-not-filter u x rst)))] ;; struct ops - [((Struct: nm par flds proc poly pred cert acc-ids maker-id) + [((Struct: nm par flds proc poly pred cert maker-id) (TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x)) (make-Struct nm par - (replace-nth flds idx - (lambda (e) (update e (-filter u x rst)))) - proc poly pred cert acc-ids maker-id)] - [((Struct: nm par flds proc poly pred cert acc-ids maker-id) + (list-update flds idx + (match-lambda [(fld: e acc-id #f) + (make-fld + (update e (-filter u x rst)) + acc-id #f)] + [_ (int-err "update on mutable struct field")])) + proc poly pred cert maker-id)] + [((Struct: nm par flds proc poly pred cert maker-id) (NotTypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x)) - (make-Struct nm par (replace-nth flds idx (lambda (e) (update e (-not-filter u x rst)))) proc poly pred cert acc-ids maker-id)] + (make-Struct nm par (list-update flds idx + (match-lambda [(fld: e acc-id #f) + (make-fld + (update e (-not-filter u x rst)) + acc-id #f)] + [_ (int-err "update on mutable struct field")])) + proc poly pred cert maker-id)] ;; otherwise [(t (TypeFilter: u (list) _)) diff --git a/collects/typed-scheme/typecheck/tc-structs.rkt b/collects/typed-scheme/typecheck/tc-structs.rkt index 1942898d..c43bce64 100644 --- a/collects/typed-scheme/typecheck/tc-structs.rkt +++ b/collects/typed-scheme/typecheck/tc-structs.rkt @@ -13,6 +13,10 @@ unstable/debug racket/function scheme/match + (only-in racket/contract + listof any/c or/c + [->* c->*] + [-> c->]) (for-syntax scheme/base)) @@ -78,35 +82,54 @@ ;; Option[Struct-Ty] -> Listof[Type] (define (get-parent-flds p) (match p - [(Struct: _ _ flds _ _ _ _ _ _) flds] + [(Struct: _ _ flds _ _ _ _ _) flds] [(Name: n) (get-parent-flds (lookup-type-name n))] [#f null])) ;; construct all the various types for structs, and then register the approriate names -;; identifier listof[identifier] type listof[Type] listof[Type] boolean -> Type listof[Type] listof[Type] -(define (mk/register-sty nm flds parent parent-field-types types - #:wrapper [wrapper values] - #:type-wrapper [type-wrapper values] - #:pred-wrapper [pred-wrapper values] - #:mutable [setters? #f] - #:struct-info [si #f] - #:proc-ty [proc-ty #f] - #:maker [maker* #f] - #:predicate [pred* #f] - #:constructor-return [cret #f] - #:poly? [poly? #f] - #:type-only [type-only #f]) +;; identifier listof[identifier] type listof[fld] listof[Type] boolean -> Type listof[Type] listof[Type] +(d/c (mk/register-sty nm flds parent parent-fields types + #:wrapper [wrapper values] + #:type-wrapper [type-wrapper values] + #:pred-wrapper [pred-wrapper values] + #:mutable [setters? #f] + #:struct-info [si #f] + #:proc-ty [proc-ty #f] + #:maker [maker* #f] + #:predicate [pred* #f] + #:constructor-return [cret #f] + #:poly? [poly? #f] + #:type-only [type-only #f]) + (c->* (identifier? (listof identifier?) (or/c Type/c #f) (listof fld?) (listof Type/c)) + (#:wrapper procedure? + #:type-wrapper procedure? + #:pred-wrapper procedure? + #:mutable boolean? + #:struct-info any/c + #:proc-ty (or/c #f Type/c) + #:maker (or/c #f identifier?) + #:predicate (or/c #f identifier?) + #:constructor-return (or/c #f Type/c) + #:poly? (or/c #f (listof symbol?)) + #:type-only boolean?) + any/c) ;; create the approriate names that define-struct will bind (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?)) (let* ([name (syntax-e nm)] - [fld-types (append parent-field-types types)] - [sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier) getters (or maker* maker))] + [fld-names flds] + [this-flds (for/list ([t (in-list types)] + [g (in-list getters)]) + (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))] [external-fld-types/no-parent types] - [external-fld-types fld-types]) + [external-fld-types (map fld-t flds)]) (if type-only (register-type-name nm (wrapper sty)) - (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? + (register-struct-types nm sty fld-names external-fld-types + external-fld-types/no-parent setters? #:wrapper wrapper #:type-wrapper type-wrapper #:pred-wrapper pred-wrapper @@ -119,15 +142,25 @@ ;; generate names, and register the approriate types give field types and structure type ;; optionally wrap things ;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier -(define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? - #:wrapper [wrapper values] - #:struct-info [si #f] - #:type-wrapper [type-wrapper values] - #:pred-wrapper [pred-wrapper values] - #:maker [maker* #f] - #:predicate [pred* #f] - #:poly? [poly? #f] - #:constructor-return [cret #f]) +(d/c (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters? + #:wrapper [wrapper values] + #:struct-info [si #f] + #:type-wrapper [type-wrapper values] + #:pred-wrapper [pred-wrapper values] + #:maker [maker* #f] + #:predicate [pred* #f] + #:poly? [poly? #f] + #:constructor-return [cret #f]) + (c->* (identifier? Struct? (listof identifier?) (listof Type/c) (listof Type/c) boolean?) + (#:wrapper procedure? + #:type-wrapper procedure? + #:pred-wrapper procedure? + #:struct-info any/c + #:maker (or/c #f identifier?) + #:predicate (or/c #f identifier?) + #:constructor-return (or/c #f Type/c) + #:poly? (or/c #f (listof symbol?))) + list?) ;; create the approriate names that define-struct will bind (define-values (struct-type-id maker pred getters setters) (struct-names nm flds setters?)) ;; the type name that is used in all the types @@ -212,10 +245,18 @@ ;; typecheck a non-polymophic struct and register the approriate types ;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void -(define (tc/struct nm/par flds tys [proc-ty #f] - #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f] - #:predicate [pred #f] - #:type-only [type-only #f]) +(d/c (tc/struct nm/par flds tys [proc-ty #f] + #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f] + #:predicate [pred #f] + #:type-only [type-only #f]) + (c->* (syntax? (listof identifier?) (listof syntax?)) + ((or/c #f syntax?) + #:maker any/c + #:mutable boolean? + #:constructor-return any/c + #:predicate any/c + #:type-only boolean?) + any/c) ;; get the parent info and create some types and type variables (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par)) ;; parse the field types, and determine if the type is recursive @@ -239,9 +280,13 @@ ;; register a struct type ;; convenience function for built-in structs ;; tc/builtin-struct : identifier identifier Listof[identifier] Listof[Type] Listof[Type] -> void -(define (tc/builtin-struct nm parent flds tys parent-tys) - (let ([parent* (if parent (make-Name parent) #f)]) - (mk/register-sty nm flds parent* parent-tys tys +(d/c (tc/builtin-struct nm parent flds tys #;parent-tys) + (c-> identifier? (or/c #f identifier?) (listof identifier?) + (listof Type/c) #;(listof fld?) + any/c) + (let* ([parent-name (if parent (make-Name parent) #f)] + [parent-flds (if parent (get-parent-flds parent-name) null)]) + (mk/register-sty nm flds parent-name parent-flds tys #:mutable #t))) ;; syntax for tc/builtin-struct @@ -250,11 +295,9 @@ [(_ (nm par) ([fld : ty] ...) (par-ty ...)) #'(tc/builtin-struct #'nm #'par (list #'fld ...) - (list ty ...) - (list par-ty ...))] - [(_ nm ([fld : ty] ...) (par-ty ...)) + (list ty ...))] + [(_ nm ([fld : ty] ...)) #'(tc/builtin-struct #'nm #f (list #'fld ...) - (list ty ...) - (list par-ty ...))])) + (list ty ...))])) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index 3b6d5d14..5acdfdbb 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -72,7 +72,7 @@ [(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values))) (let* ([t (parse-type #'ty)] - [flds (Struct-flds (lookup-type-name (Name-id t)))] + [flds (map fld-t (Struct-flds (lookup-type-name (Name-id t))))] [mk-ty (flds #f . ->* . t)]) (register-type #'nm mk-ty) (list (make-def-binding #'nm mk-ty)))] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 3e353317..53c6ba84 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -86,12 +86,12 @@ ;; basic types -(define promise-str (string->uninterned-symbol "Promise")) +(define promise-sym (string->uninterned-symbol "Promise")) (define make-promise-ty - (let ([s promise-str]) + (let ([s promise-sym]) (lambda (t) - (make-Struct s #f (list t) #f #f #'promise? values (list #'values) #'values)))) + (make-Struct s #f (list (make-fld t #'values #f)) #f #f #'promise? values #'values)))) (define -Listof (-poly (list-elem) (make-Listof list-elem))) @@ -285,8 +285,8 @@ (define (make-arr-dots dom rng dty dbound) (make-arr* dom rng #:drest (cons dty dbound))) -(define (-struct name parent flds accs constructor [proc #f] [poly #f] [pred #'dummy] [cert values]) - (make-Struct name parent flds proc poly pred cert accs constructor)) +(define (-struct name parent flds constructor [proc #f] [poly #f] [pred #'dummy] [cert values]) + (make-Struct name parent flds proc poly pred cert constructor)) (d/c (-filter t i [p null]) (c:->* (Type/c name-ref/c) ((listof PathElem?)) Filter/c) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index ebfe3388..0c4ada27 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -144,9 +144,9 @@ (fp "~a" (cons 'List (tuple-elems t)))] [(Base: n cnt) (fp "~a" n)] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] - [(Struct: (== promise-str eq?) #f (list fld) _ _ _ _ _ _) (fp "(Promise ~a)" fld)] - [(Struct: nm par flds proc _ _ _ _ _) - (fp "#(struct:~a ~a" nm flds) + [(Struct: (== promise-sym) #f (list (fld: t _ _)) _ _ _ _ _) (fp "(Promise ~a)" t)] + [(Struct: nm par (list (fld: t _ _) ...) proc _ _ _ _) + (fp "#(struct:~a ~a" nm t) (when proc (fp " ~a" proc)) (fp ")")] @@ -223,6 +223,7 @@ (for ([t ts]) (fp " ~a" t)) (fp ")")] [(Error:) (fp "Error")] + [(fld: t a m) (fp "(fld ~a)" t)] [else (fp "(Unknown Type: ~a)" (struct->vector c))] )) diff --git a/collects/typed-scheme/types/remove-intersect.rkt b/collects/typed-scheme/types/remove-intersect.rkt index af4e5d54..a646a54c 100644 --- a/collects/typed-scheme/types/remove-intersect.rkt +++ b/collects/typed-scheme/types/remove-intersect.rkt @@ -50,25 +50,30 @@ [(or (list (Pair: _ _) _) (list _ (Pair: _ _))) #f] - [(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _ _)) - (list (Struct: n _ flds _ _ _ _ _ _) (Value: '()))) + [(or (list (Value: '()) (Struct: n _ flds _ _ _ _ _)) + (list (Struct: n _ flds _ _ _ _ _) (Value: '()))) #f] - [(list (Struct: n _ flds _ _ _ _ _ _) - (Struct: n _ flds* _ _ _ _ _ _)) - (for/and ([f flds] [f* flds*]) (overlap f f*))] - [(list (Struct: n #f _ _ _ _ _ _ _) - (StructTop: (Struct: n #f _ _ _ _ _ _ _))) + [(list (Struct: n _ flds _ _ _ _ _) + (Struct: n _ flds* _ _ _ _ _)) + (for/and ([f flds] [f* flds*]) + (match* (f f*) + [((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))] + [(list (Struct: n #f _ _ _ _ _ _) + (StructTop: (Struct: n #f _ _ _ _ _ _))) #t] ;; n and n* must be different, so there's no overlap - [(list (Struct: n #f flds _ _ _ _ _ _) - (Struct: n* #f flds* _ _ _ _ _ _)) + [(list (Struct: n #f flds _ _ _ _ _) + (Struct: n* #f flds* _ _ _ _ _)) #f] - [(list (Struct: n #f flds _ _ _ _ _ _) - (StructTop: (Struct: n* #f flds* _ _ _ _ _ _))) + [(list (Struct: n #f flds _ _ _ _ _) + (StructTop: (Struct: n* #f flds* _ _ _ _ _))) #f] - [(list (Struct: n p flds _ _ _ _ _ _) - (Struct: n* p* flds* _ _ _ _ _ _)) - (and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))] + [(list (Struct: n p flds _ _ _ _ _) + (Struct: n* p* flds* _ _ _ _ _)) + (and (= (length flds) (length flds*)) + (for/and ([f flds] [f* flds*]) + (match* (f f*) + [((fld: t _ _) (fld: t* _ _)) (overlap t t*)])))] [(list (== (-val eof)) (Function: _)) #f] diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index a5167c48..aee51187 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -16,7 +16,7 @@ (define-struct (exn:subtype exn:fail) (s t)) -;; inference failure - masked before it gets to the user program +;; subtyping failure - masked before it gets to the user program (define-syntax fail! (syntax-rules () [(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))])) @@ -196,6 +196,13 @@ [else (make-arr (apply map (lambda args (make-Union (sort args type List[(cons Number Number)] @@ -347,12 +354,13 @@ (fail! s t))] [(s (Union: es)) (or (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0) (fail! s t))] - ;; subtyping on immutable structs is covariant - [((Struct: nm _ flds #f _ _ _ _ _) (Struct: nm _ flds* #f _ _ _ _ _)) - (subtypes* A0 flds flds*)] - [((Struct: nm _ flds proc _ _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _ _)) - (subtypes* A0 (cons proc flds) (cons proc* flds*))] - [((Struct: _ _ _ _ _ _ _ _ _) (StructTop: (? (lambda (s2) (type-equal? s2 s))))) + ;; subtyping on immutable structs is covariant + [((Struct: nm _ flds proc _ _ _ _) (Struct: nm _ flds* proc* _ _ _ _)) + (let ([A (cond [(and proc proc*) (subtype* proc proc*)] + [proc* (fail! proc proc*)] + [else A0])]) + (subtype/flds* A flds flds*))] + [((Struct: _ _ _ _ _ _ _ _) (StructTop: (== s type-equal?))) A0] [((Box: _) (BoxTop:)) A0] [((Channel: _) (ChannelTop:)) A0] @@ -363,11 +371,11 @@ [((MPair: _ _) (MPairTop:)) A0] [((Hashtable: _ _) (HashtableTop:)) A0] ;; subtyping on structs follows the declared hierarchy - [((Struct: nm (? Type? parent) flds proc _ _ _ _ _) other) + [((Struct: nm (? Type? parent) flds proc _ _ _ _) other) ;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other) (subtype* A0 parent other)] ;; Promises are covariant - [((Struct: 'Promise _ (list t) _ _ _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _ _ _)) (subtype* A0 t t*)] + [((Struct: (== promise-sym) _ (list t) _ _ _ _ _) (Struct: (== promise-sym) _ (list t*) _ _ _ _ _)) (subtype* A0 t t*)] ;; subtyping on values is pointwise [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] ;; trivial case for Result diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index 4c81ab3f..37d40266 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -11,7 +11,7 @@ at least theoretically. scheme/pretty mzlib/pconvert syntax/parse) ;; to move to unstable -(provide reverse-begin) +(provide reverse-begin list-update list-set) (provide ;; optimization @@ -26,6 +26,7 @@ at least theoretically. rep utils typecheck infer env private types) (define optimize? (make-parameter #f)) +(define-for-syntax enable-contracts? #t) ;; fancy require syntax (define-syntax (define-requirer stx) @@ -159,7 +160,6 @@ at least theoretically. ;; turn contracts on and off - off by default for performance. -(define-for-syntax enable-contracts? #f) (provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c d/c/p) (define-syntax-rule (d/c/p (name . args) c . body) @@ -214,3 +214,13 @@ at least theoretically. (if enable-contracts? (list #'[contracted (nm cnt)]) (list #'nm))])) + +(define (list-update l i f) + (cond [(null? l) (error 'list-update "list not long enough" l i f)] + [(zero? i) (cons (f (car l)) (cdr l))] + [else (cons (car l) (list-update (cdr l) (sub1 i) f))])) + +(define (list-set l k v) + (if (zero? k) + (cons v (cdr l)) + (cons (car l) (list-set (cdr l) (sub1 k) v)))) From 19bb208f4f4e0d5bb9445a2acbd17e7eb03b8d31 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 29 Jun 2010 17:25:48 -0400 Subject: [PATCH 134/198] make subst structs transparent original commit: 18078400b77114880e99e1c39913f8df96a0faa2 --- collects/typed-scheme/types/substitute.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/types/substitute.rkt b/collects/typed-scheme/types/substitute.rkt index 20d5659b..a2957404 100644 --- a/collects/typed-scheme/types/substitute.rkt +++ b/collects/typed-scheme/types/substitute.rkt @@ -19,11 +19,11 @@ (for/hash ([v (in-list vs)] [t (in-list ts)]) (values v (t-subst t)))) -(d-s/c subst-rhs ()) -(d-s/c (t-subst subst-rhs) ([type Type/c])) -(d-s/c (i-subst subst-rhs) ([types (listof Type/c)])) -(d-s/c (i-subst/starred subst-rhs) ([types (listof Type/c)] [starred Type/c])) -(d-s/c (i-subst/dotted subst-rhs) ([types (listof Type/c)] [dty Type/c] [dbound symbol?])) +(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) +(d-s/c (i-subst/starred subst-rhs) ([types (listof Type/c)] [starred Type/c]) #:transparent) +(d-s/c (i-subst/dotted subst-rhs) ([types (listof Type/c)] [dty Type/c] [dbound symbol?]) #:transparent) (define substitution/c (hash/c symbol? subst-rhs? #:immutable #t)) From 4a5379ca01b4a548596c6a630ae54aa61d9cb03b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Wed, 30 Jun 2010 12:04:08 -0400 Subject: [PATCH 135/198] Forgot to disable this yet again. original commit: f7634043479125de58308197c3fb5fea75146db5 --- collects/typed-scheme/utils/utils.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index 37d40266..ad4f5e24 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -26,7 +26,7 @@ at least theoretically. rep utils typecheck infer env private types) (define optimize? (make-parameter #f)) -(define-for-syntax enable-contracts? #t) +(define-for-syntax enable-contracts? #f) ;; fancy require syntax (define-syntax (define-requirer stx) From 18155bf2c57b3fcba8974c9e31818006837a3111 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 25 Jun 2010 14:47:26 -0400 Subject: [PATCH 136/198] Added fixnums to more type signatures. original commit: cee39c4a38bb0ca41f79a4b8e9e159501e5d627d --- .../private/base-env-indexing-abs.rkt | 56 +++++------ .../typed-scheme/private/base-env-numeric.rkt | 93 +++++++++++++------ collects/typed-scheme/private/base-env.rkt | 42 ++++----- collects/typed-scheme/private/base-types.rkt | 1 + collects/typed-scheme/types/abbrev.rkt | 1 + 5 files changed, 114 insertions(+), 79 deletions(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index 8e9b7250..f54b1c34 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -30,31 +30,31 @@ [string-copy! (-String index-type -String [index-type index-type] . ->opt . -Void)] [read-string (index-type [-Input-Port] . ->opt . (Un -String (-val eof)))] - [read-string! (-String [-Input-Port index-type index-type] . ->opt . (Un -Nat (-val eof)))] + [read-string! (-String [-Input-Port index-type index-type] . ->opt . (Un -NonnegativeFixnum (-val eof)))] [read-bytes (index-type [-Input-Port] . ->opt . (Un -Bytes (-val eof)))] [write-byte (cl-> [(index-type) -Void] [(index-type -Output-Port) -Void])] - [write-string (cl-> [(-String) -Nat] - [(-String -Output-Port) -Nat] - [(-String -Output-Port index-type) -Nat] - [(-String -Output-Port index-type index-type) -Nat])] - [write-bytes (cl-> [(-Bytes) -Nat] - [(-Bytes -Output-Port) -Nat] - [(-Bytes -Output-Port index-type) -Nat] - [(-Bytes -Output-Port index-type index-type) -Nat])] - [write-bytes-avail (cl-> [(-Bytes) -Nat] - [(-Bytes -Output-Port) -Nat] - [(-Bytes -Output-Port index-type) -Nat] - [(-Bytes -Output-Port index-type index-type) -Nat])] - [write-bytes-avail* (cl-> [(-Bytes) (-opt -Nat)] - [(-Bytes -Output-Port) (-opt -Nat)] - [(-Bytes -Output-Port index-type) (-opt -Nat)] - [(-Bytes -Output-Port index-type index-type) (-opt -Nat)])] - [write-bytes-avail/enable-break (cl-> [(-Bytes) -Nat] - [(-Bytes -Output-Port) -Nat] - [(-Bytes -Output-Port index-type) -Nat] - [(-Bytes -Output-Port index-type index-type) -Nat])] + [write-string (cl-> [(-String) -NonnegativeFixnum] + [(-String -Output-Port) -NonnegativeFixnum] + [(-String -Output-Port index-type) -NonnegativeFixnum] + [(-String -Output-Port index-type index-type) -NonnegativeFixnum])] + [write-bytes (cl-> [(-Bytes) -NonnegativeFixnum] + [(-Bytes -Output-Port) -NonnegativeFixnum] + [(-Bytes -Output-Port index-type) -NonnegativeFixnum] + [(-Bytes -Output-Port index-type index-type) -NonnegativeFixnum])] + [write-bytes-avail (cl-> [(-Bytes) -NonnegativeFixnum] + [(-Bytes -Output-Port) -NonnegativeFixnum] + [(-Bytes -Output-Port index-type) -NonnegativeFixnum] + [(-Bytes -Output-Port index-type index-type) -NonnegativeFixnum])] + [write-bytes-avail* (cl-> [(-Bytes) (-opt -NonnegativeFixnum)] + [(-Bytes -Output-Port) (-opt -NonnegativeFixnum)] + [(-Bytes -Output-Port index-type) (-opt -NonnegativeFixnum)] + [(-Bytes -Output-Port index-type index-type) (-opt -NonnegativeFixnum)])] + [write-bytes-avail/enable-break (cl-> [(-Bytes) -NonnegativeFixnum] + [(-Bytes -Output-Port) -NonnegativeFixnum] + [(-Bytes -Output-Port index-type) -NonnegativeFixnum] + [(-Bytes -Output-Port index-type index-type) -NonnegativeFixnum])] @@ -109,7 +109,7 @@ [-StrRx (Un -String -Regexp -PRegexp)] [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] [-InpBts (Un -Input-Port -Bytes)]) - (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))] + (->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -NonnegativeFixnum -NonnegativeFixnum))))] [regexp-match-positions* (let ([?outp (-opt -Output-Port)] [?N (-opt index-type)] @@ -117,7 +117,7 @@ [-StrRx (Un -String -Regexp -PRegexp)] [-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)] [-InpBts (Un -Input-Port -Bytes)]) - (->opt -Pattern (Un -String -InpBts) [index-type ?N ?outp] (-lst (-pair -Nat -Nat))))] + (->opt -Pattern (Un -String -InpBts) [index-type ?N ?outp] (-lst (-pair -NonnegativeFixnum -NonnegativeFixnum))))] [take (-poly (a) ((-lst a) index-type . -> . (-lst a)))] @@ -140,8 +140,8 @@ [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Nat a))] [(index-type a) (-vec a)]))] - [bytes-ref (-> -Bytes index-type -Nat)] - [unsafe-bytes-ref (-> -Bytes index-type -Nat)] + [bytes-ref (-> -Bytes index-type -NonnegativeFixnum)] + [unsafe-bytes-ref (-> -Bytes index-type -NonnegativeFixnum)] [bytes-set! (-> -Bytes index-type index-type -Void)] [unsafe-bytes-set! (-> -Bytes index-type index-type -Void)] [subbytes (cl-> [(-Bytes index-type) -Bytes] [(-Bytes index-type index-type) -Bytes])] @@ -153,10 +153,10 @@ [string->bytes/utf-8 (-String [(Un (-val #f) index-type) index-type index-type] . ->opt . -Bytes)] [string->bytes/locale (-String [(Un (-val #f) index-type) index-type index-type] . ->opt . -Bytes)] [string->bytes/latin-1 (-String [(Un (-val #f) index-type) index-type index-type] . ->opt . -Bytes)] - [string-utf-8-length (-String [index-type index-type] . ->opt . -Nat)] - [bytes-utf-8-length (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -Nat)] + [string-utf-8-length (-String [index-type index-type] . ->opt . -NonnegativeFixnum)] + [bytes-utf-8-length (-Bytes [(Un (-val #f) -Char) index-type index-type] . ->opt . -NonnegativeFixnum)] [bytes-utf-8-ref (-Bytes [index-type (Un (-val #f) -Char) index-type index-type] . ->opt . -Char)] - [bytes-utf-8-index (-Bytes [index-type (Un (-val #f) -Char) index-type index-type] . ->opt . -Nat)] + [bytes-utf-8-index (-Bytes [index-type (Un (-val #f) -Char) index-type index-type] . ->opt . -NonnegativeFixnum)] [peek-char diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index cb561075..9ef60f87 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -20,7 +20,14 @@ (lambda (t [r t]) (t t . -> . r))) (define-for-syntax rounder - (cl->* (-> -ExactRational -Integer) (-> -Flonum -Flonum) (-> -Real -Real))) + (cl->* (-> -PositiveFixnum -PositiveFixnum) + (-> -NonnegativeFixnum -NonnegativeFixnum) + (-> -Fixnum -Fixnum) + (-> -Pos -Pos) + (-> -Nat -Nat) + (-> -ExactRational -Integer) + (-> -Flonum -Flonum) + (-> -Real -Real))) (define-for-syntax (unop t) (-> t t)) @@ -33,9 +40,11 @@ (define-for-syntax nat-op (binop -Nat)) (define-for-syntax fx-comp (binop -Integer B)) - (define-for-syntax fx-op (cl->* nat-op int-op)) - (define-for-syntax fx-intop int-op) - (define-for-syntax fx-unop (unop -Integer)) + (define-for-syntax fx-op (cl->* (-Pos -Pos . -> . -PositiveFixnum) + (-Nat -Nat . -> . -NonnegativeFixnum) + (-Integer -Integer . -> . -Fixnum))) + (define-for-syntax fx-intop (-Integer -Integer . -> . -Fixnum)) + (define-for-syntax fx-unop (-Integer . -> . -Fixnum)) (define-for-syntax real-comp (->* (list R R) R B)) ) @@ -62,7 +71,9 @@ [odd? (-> -Integer B)] [even? (-> -Integer B)] -[modulo (cl->* (-Nat -Nat . -> . -Nat) +[modulo (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . -NonnegativeFixnum) + (-Fixnum -Fixnum . -> . -Fixnum) + (-Nat -Nat . -> . -Nat) (-Integer -Integer . -> . -Integer))] [= (->* (list N N) N B)] @@ -107,8 +118,16 @@ (list (->* (list -Real) -Real -Real)) (list (->* (list N) N N))))] -[max (apply cl->* (->* (list -Pos) -Integer -Pos) (->* (list -Nat) -Integer -Nat) (for/list ([t all-num-types]) (->* (list t) t t)))] -[min (apply cl->* (for/list ([t all-num-types]) (->* (list t) t t)))] +[max (apply cl->* + (->* (list -PositiveFixnum) -Fixnum -PositiveFixnum) + (->* (list -NonnegativeFixnum) -Fixnum -NonnegativeFixnum) + (->* (list -Fixnum) -Fixnum -Fixnum) + (->* (list -Pos) -Integer -Pos) + (->* (list -Nat) -Integer -Nat) + (for/list ([t all-num-types]) (->* (list t) t t)))] +[min (apply cl->* + (->* (list -Fixnum) -Fixnum -Fixnum) + (for/list ([t all-num-types]) (->* (list t) t t)))] [add1 (cl->* (-> -Pos -Pos) @@ -126,28 +145,42 @@ (-> -Real -Real) (-> N N))] -[quotient (cl->* (-Nat -Nat . -> . -Nat) +[quotient (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . -NonnegativeFixnum) + (-Fixnum -Fixnum . -> . -Fixnum) + (-Nat -Nat . -> . -Nat) (-Integer -Integer . -> . -Integer))] -[remainder (cl->* (-Nat -Nat . -> . -Nat) +[remainder (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . -NonnegativeFixnum) + (-Fixnum -Fixnum . -> . -Fixnum) + (-Nat -Nat . -> . -Nat) (-Integer -Integer . -> . -Integer))] -[quotient/remainder (cl->* (-Nat -Nat . -> . (-values (list -Nat -Nat))) +[quotient/remainder (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . (-values (list -NonnegativeFixnum -NonnegativeFixnum))) + (-Fixnum -Fixnum . -> . (-values (list -Fixnum -Fixnum))) + (-Nat -Nat . -> . (-values (list -Nat -Nat))) (-Integer -Integer . -> . (-values (list -Integer -Integer))))] -[arithmetic-shift (cl->* (-Nat -Nat . -> . -Nat) +[arithmetic-shift (cl->* (-Fixnum (Un -NegativeFixnum (-val 0)) . -> . -Fixnum) + (-Nat -Nat . -> . -Nat) (-Integer -Integer . -> . -Integer))] -[bitwise-and (cl->* (null -Nat . ->* . -Nat) +[bitwise-and (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum) + (null -Fixnum . ->* . -Fixnum) + (null -Nat . ->* . -Nat) (null -Integer . ->* . -Integer))] -[bitwise-ior (cl->* (null -Nat . ->* . -Nat) +[bitwise-ior (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum) + (null -Fixnum . ->* . -Fixnum) + (null -Nat . ->* . -Nat) (null -Integer . ->* . -Integer))] -[bitwise-not (cl->* (null -Nat . ->* . -Nat) +[bitwise-not (cl->* (null -Fixnum . ->* . -Fixnum) (null -Integer . ->* . -Integer))] -[bitwise-xor (cl->* (null -Nat . ->* . -Nat) +[bitwise-xor (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum) + (null -Fixnum . ->* . -Fixnum) + (null -Nat . ->* . -Nat) (null -Integer . ->* . -Integer))] [bitwise-bit-set? (-> -Integer -Integer B)] [bitwise-bit-field (-> -Integer -Integer -Integer -Integer)] -[integer-length (-> -Integer -Nat)] +[integer-length (-> -Integer -NonnegativeFixnum)] -[abs (cl->* (-Integer . -> . -Nat) +[abs (cl->* (-Fixnum . -> . -NonnegativeFixnum) + (-Integer . -> . -Nat) (-Real . -> . -Real))] ;; exactness @@ -189,7 +222,7 @@ [acos (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] [asin (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] [atan (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N) (-Real -Real . -> . N))] -[gcd (null -Integer . ->* . -Integer)] +[gcd (cl->* (null -Fixnum . ->* . -Fixnum) (null -Integer . ->* . -Integer))] [lcm (null -Integer . ->* . -Integer)] ;; scheme/math @@ -243,14 +276,14 @@ [unsafe-fxquotient fx-intop] [unsafe-fxremainder fx-intop] [unsafe-fxmodulo fx-intop] -[unsafe-fxabs (-Integer . -> . -Nat)] +[unsafe-fxabs (-Integer . -> . (Un -PositiveFixnum (-val 0)))] -[unsafe-fxand fx-intop] -[unsafe-fxior fx-intop] -[unsafe-fxxor fx-intop] +[unsafe-fxand fx-op] +[unsafe-fxior fx-op] +[unsafe-fxxor fx-op] [unsafe-fxnot fx-unop] [unsafe-fxlshift fx-intop] -[unsafe-fxrshift fx-intop] +[unsafe-fxrshift (cl->* (-> -NonnegativeFixnum -NonnegativeFixnum -NonnegativeFixnum) fx-intop)] [unsafe-fx= fx-comp] [unsafe-fx< fx-comp] @@ -268,14 +301,14 @@ [fxquotient fx-intop] [fxremainder fx-intop] [fxmodulo fx-intop] -[fxabs (-Integer . -> . -Nat)] +[fxabs (-Integer . -> . (Un -PositiveFixnum (-val 0)))] -[fxand fx-intop] -[fxior fx-intop] -[fxxor fx-intop] +[fxand fx-op] +[fxior fx-op] +[fxxor fx-op] [fxnot fx-unop] [fxlshift fx-intop] -[fxrshift fx-intop] +[fxrshift (cl->* (-> -NonnegativeFixnum -NonnegativeFixnum -NonnegativeFixnum) fx-intop)] [fx= fx-comp] [fx< fx-comp] @@ -320,12 +353,12 @@ [flvector (->* (list) -Flonum -FlVector)] [make-flvector (cl->* (-> -Integer -FlVector) (-> -Integer -Flonum -FlVector))] -[flvector-length (-> -FlVector -Nat)] +[flvector-length (-> -FlVector -NonnegativeFixnum)] [flvector-ref (-> -FlVector -Integer -Flonum)] [flvector-set! (-> -FlVector -Integer -Flonum -Void)] ;; unsafe flvector ops -[unsafe-flvector-length (-> -FlVector -Nat)] +[unsafe-flvector-length (-> -FlVector -NonnegativeFixnum)] [unsafe-flvector-ref (-> -FlVector -Integer -Flonum)] [unsafe-flvector-set! (-> -FlVector -Integer -Flonum -Void)] diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index e6d8c3c3..d2252e2b 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -217,8 +217,8 @@ [string? (make-pred-ty -String)] [string (->* '() -Char -String)] -[string-length (-String . -> . -PositiveFixnum)] -[unsafe-string-length (-String . -> . -PositiveFixnum)] +[string-length (-String . -> . -NonnegativeFixnum)] +[unsafe-string-length (-String . -> . -NonnegativeFixnum)] [symbol? (make-pred-ty Sym)] [keyword? (make-pred-ty -Keyword)] @@ -301,7 +301,7 @@ [reverse (-poly (a) (-> (-lst a) (-lst a)))] [append (-poly (a) (->* (list) (-lst a) (-lst a)))] -[length (-poly (a) (-> (-lst a) -PositiveFixnum))] +[length (-poly (a) (-> (-lst a) -NonnegativeFixnum))] [memq (-poly (a) (-> a (-lst a) (-opt (-lst a))))] [memv (-poly (a) (-> a (-lst a) (-opt (-lst a))))] [memf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt (-lst a))))] @@ -354,8 +354,8 @@ [char-downcase (-> -Char -Char)] [char-titlecase (-> -Char -Char)] [char-foldcase (-> -Char -Char)] -[char->integer (-> -Char -PositiveFixnum)] -[integer->char (-> -Nat -Char)] +[char->integer (-> -Char -NonnegativeFixnum)] +[integer->char (-> -Integer -Char)] [char-utf-8-length (-> -Char (apply Un (map -val '(1 2 3 4 5 6))))] [string-normalize-nfd (-> -String -String)] @@ -481,16 +481,16 @@ [vector->list (-poly (a) (-> (-vec a) (-lst a)))] [list->vector (-poly (a) (-> (-lst a) (-vec a)))] -[vector-length ((make-VectorTop) . -> . -PositiveFixnum)] +[vector-length ((make-VectorTop) . -> . -NonnegativeFixnum)] [vector (-poly (a) (->* (list) a (-vec a)))] [vector-immutable (-poly (a) (->* (list) a (-vec a)))] [vector->immutable-vector (-poly (a) (-> (-vec a) (-vec a)))] [vector-fill! (-poly (a) (-> (-vec a) a -Void))] [vector-argmax (-poly (a) (-> (-> a -Real) (-vec a) a))] [vector-argmin (-poly (a) (-> (-> a -Real) (-vec a) a))] -[vector-memq (-poly (a) (-> a (-vec a) (-opt -PositiveFixnum)))] -[vector-memv (-poly (a) (-> a (-vec a) (-opt -PositiveFixnum)))] -[vector-member (-poly (a) (a (-vec a) . -> . (-opt -PositiveFixnum)))] +[vector-memq (-poly (a) (-> a (-vec a) (-opt -NonnegativeFixnum)))] +[vector-memv (-poly (a) (-> a (-vec a) (-opt -NonnegativeFixnum)))] +[vector-member (-poly (a) (a (-vec a) . -> . (-opt -NonnegativeFixnum)))] ;; [vector->values no good type here] @@ -548,7 +548,7 @@ [hash-remove! (-poly (a b) ((-HT a b) a . -> . -Void))] [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) -PositiveFixnum))] +[hash-count (-poly (a b) (-> (-HT a b) -NonnegativeFixnum))] [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))] @@ -568,12 +568,12 @@ [make-bytes (cl-> [(-Integer -Integer) -Bytes] [(-Integer) -Bytes])] [bytes->immutable-bytes (-> -Bytes -Bytes)] -[byte? (make-pred-ty -Nat)] +[byte? (make-pred-ty -NonnegativeFixnum)] [bytes-append (->* (list) -Bytes -Bytes)] -[bytes-length (-> -Bytes -PositiveFixnum)] -[unsafe-bytes-length (-> -Bytes -PositiveFixnum)] +[bytes-length (-> -Bytes -NonnegativeFixnum)] +[unsafe-bytes-length (-> -Bytes -NonnegativeFixnum)] [bytes-copy (-> -Bytes -Bytes)] -[bytes->list (-> -Bytes (-lst -Nat))] +[bytes->list (-> -Bytes (-lst -NonnegativeFixnum))] [list->bytes (-> (-lst -Integer) -Bytes)] [bytes* (list -Bytes) -Bytes B)] [bytes>? (->* (list -Bytes) -Bytes B)] @@ -671,7 +671,7 @@ [list->string ((-lst -Char) . -> . -String)] [string->list (-String . -> . (-lst -Char))] -[build-string (-Nat (-Nat . -> . -Char) . -> . -String)] +[build-string (-Nat (-Integer . -> . -Char) . -> . -String)] [sort (-poly (a b) (cl->* ((-lst a) (a a . -> . B) #:cache-keys? B #f @@ -711,7 +711,7 @@ (-lst a)) ((-lst b) b) . ->... . - -PositiveFixnum))] + -NonnegativeFixnum))] [filter-map (-polydots (c a b) ((list ((list a) (b b) . ->... . (-opt c)) @@ -744,7 +744,7 @@ [tcp-accept-ready? (-TCP-Listener . -> . B )] [tcp-addresses (cl->* (-Port [(-val #f)] . ->opt . (-values (list -String -String))) - (-Port (-val #t) . -> . (-values (list -String -Nat -String -Nat))))] + (-Port (-val #t) . -> . (-values (list -String -NonnegativeFixnum -String -NonnegativeFixnum))))] [tcp-close (-TCP-Listener . -> . -Void )] [tcp-connect (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] [tcp-connect/enable-break (-String -Integer . -> . (-values (list -Input-Port -Output-Port)))] @@ -808,8 +808,8 @@ ;; unsafe -[unsafe-vector-length (-poly (a) ((-vec a) . -> . -PositiveFixnum))] -[unsafe-vector*-length (-poly (a) ((-vec a) . -> . -PositiveFixnum))] +[unsafe-vector-length (-poly (a) ((-vec a) . -> . -NonnegativeFixnum))] +[unsafe-vector*-length (-poly (a) ((-vec a) . -> . -NonnegativeFixnum))] [unsafe-car (-poly (a b) (cl->* (->acc (list (-pair a b)) a (list -car)) @@ -827,7 +827,7 @@ (-vec a)) ((-vec b) b) . ->... . - -PositiveFixnum))] + -NonnegativeFixnum))] [vector-filter (-poly (a b) (cl->* ((make-pred-ty (list a) Univ b) (-vec a) @@ -904,6 +904,6 @@ (-> (-mlst a) (-mlst a) -Void)))] [mpair? (make-pred-ty (make-MPairTop))] [mlist (-poly (a) (->* (list) a (-mlst a)))] -[mlength (-poly (a) (-> (-mlst a) -PositiveFixnum))] +[mlength (-poly (a) (-> (-mlst a) -NonnegativeFixnum))] [mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))] [mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))] diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index f20b9e4a..a406ea74 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -9,6 +9,7 @@ [Exact-Positive-Integer -ExactPositiveInteger] [Exact-Nonnegative-Integer -ExactNonnegativeInteger] [Positive-Fixnum -PositiveFixnum] +[Nonnegative-Fixnum -NonnegativeFixnum] [Fixnum -Fixnum] [Natural -ExactNonnegativeInteger] [Zero (-val 0)] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 53c6ba84..f4a5b562 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -166,6 +166,7 @@ (define -Zero (-val 0)) (define -Real (*Un -Flonum -ExactRational)) (define -Fixnum (*Un -PositiveFixnum -NegativeFixnum -Zero)) +(define -NonnegativeFixnum (*Un -PositiveFixnum -Zero)) (define -ExactNonnegativeInteger (*Un -ExactPositiveInteger -Zero)) (define -Nat -ExactNonnegativeInteger) From d89e82755fc22da06e920d7e26fbbead78dcfb93 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 25 Jun 2010 16:50:06 -0400 Subject: [PATCH 137/198] Added fixnum optimizations. original commit: dfafc0b2958debe3953aa6c525a737f8c63859c8 --- .../optimizer/generic/binary-fixnum.rkt | 5 + .../generic/binary-nonzero-fixnum.rkt | 3 + .../optimizer/generic/exact-inexact.rkt | 3 + .../optimizer/generic/fixnum-comparison.rkt | 3 + .../optimizer/generic/float-comp.rkt | 3 + .../typed-scheme/optimizer/generic/fx-fl.rkt | 3 + .../generic/invalid-binary-nonzero-fixnum.rkt | 4 + .../generic/invalid-exact-inexact.rkt | 2 + .../optimizer/generic/invalid-float-comp.rkt | 3 + .../optimizer/generic/unary-fixnum-nested.rkt | 3 + .../optimizer/generic/unary-fixnum.rkt | 3 + collects/typed-scheme/private/optimize.rkt | 92 ++++++++++++++++--- 12 files changed, 116 insertions(+), 11 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/float-comp.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt b/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt new file mode 100644 index 00000000..6c1dcba3 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/binary-fixnum.rkt @@ -0,0 +1,5 @@ +(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 new file mode 100644 index 00000000..0e5c46a6 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/binary-nonzero-fixnum.rkt @@ -0,0 +1,3 @@ +(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/exact-inexact.rkt b/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt new file mode 100644 index 00000000..f19e3812 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/exact-inexact.rkt @@ -0,0 +1,3 @@ +(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 new file mode 100644 index 00000000..905b4c8b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/fixnum-comparison.rkt @@ -0,0 +1,3 @@ +(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 new file mode 100644 index 00000000..d644a1c9 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/float-comp.rkt @@ -0,0 +1,3 @@ +(module float-comp typed/scheme #:optimize + (require racket/unsafe/ops) + (< 1.0 2.0)) diff --git a/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt b/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt new file mode 100644 index 00000000..ee505dfd --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/fx-fl.rkt @@ -0,0 +1,3 @@ +(module fx-fl typed/scheme #:optimize + (require racket/unsafe/ops) + (exact->inexact 1)) 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 new file mode 100644 index 00000000..e1e94c47 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-binary-nonzero-fixnum.rkt @@ -0,0 +1,4 @@ +(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 new file mode 100644 index 00000000..f0fec025 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-exact-inexact.rkt @@ -0,0 +1,2 @@ +(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 new file mode 100644 index 00000000..1f972d6b --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-float-comp.rkt @@ -0,0 +1,3 @@ +(module float-comp typed/scheme #:optimize + (require racket/unsafe/ops) + (< 1.0 2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt new file mode 100644 index 00000000..710197af --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum-nested.rkt @@ -0,0 +1,3 @@ +(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 new file mode 100644 index 00000000..b9309084 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/unary-fixnum.rkt @@ -0,0 +1,3 @@ +(module unary-fixnum typed/scheme #:optimize + (require racket/unsafe/ops) + (bitwise-not 4)) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index b77d9802..6a786067 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require syntax/parse (for-template scheme/base scheme/flonum scheme/unsafe/ops) +(require syntax/parse (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops) "../utils/utils.rkt" unstable/match scheme/match unstable/syntax (rep type-rep) syntax/id-table racket/dict (types abbrev type-table utils subtype)) @@ -18,6 +18,20 @@ [(tc-result1: (== -Integer (lambda (x y) (subtype y x)))) #t] [_ #f]) #:with opt #'e.opt)) +(define-syntax-class fixnum-opt-expr + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -Fixnum (lambda (x y) (subtype y x)))) #t] [_ #f]) + #:with opt #'e.opt)) +(define-syntax-class nonzero-fixnum-opt-expr + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -PositiveFixnum type-equal?)) #t] + [(tc-result1: (== -NegativeFixnum type-equal?)) #t] + [_ #f]) + #:with opt #'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 @@ -28,16 +42,18 @@ (pattern e:float-opt-expr #:with opt #'e.opt)) -(define (mk-float-tbl generic) +(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern) (for/fold ([h (make-immutable-free-id-table)]) ([g generic]) - (let ([f (format-id g "fl~a" g)] [u (format-id g "unsafe-fl~a" g)]) + (let ([f (format-id g safe-pattern g)] [u (format-id g unsafe-pattern g)]) (dict-set (dict-set h g u) f u)))) +(define (mk-float-tbl generic) + (mk-unsafe-tbl generic "fl~a" "unsafe-fl~a")) + (define binary-float-ops (mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max))) (define binary-float-comps (mk-float-tbl (list #'= #'<= #'< #'> #'>=))) - (define unary-float-ops (mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp #'sqrt #'round #'floor #'ceiling #'truncate))) @@ -47,6 +63,42 @@ #:when (dict-ref tbl #'i #f) #:with unsafe (dict-ref tbl #'i))) + +(define (mk-fixnum-tbl generic) + (mk-unsafe-tbl generic "fx~a" "unsafe-fx~a")) + +;; due to undefined behavior when results are out of the fixnum range, only some +;; fixnum operations can be optimized +;; the following must be closed on fixnums +(define binary-fixnum-ops + (dict-set + (dict-set + (dict-set + (dict-set + (dict-set + (dict-set + (mk-fixnum-tbl (list #'= #'<= #'< #'> #'>= #'min #'max)) + #'bitwise-and #'unsafe-fxand) + #'fxand #'unsafe-fxand) + #'bitwise-ior #'unsafe-fxior) + #'fxior #'unsafe-fxior) + #'bitwise-xor #'unsafe-fxxor) + #'fxxor #'unsafe-fxxor)) +(define-syntax-class fixnum-unary-op + (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) + (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) + (pattern i:id + #:when (dict-ref tbl #'i #f) + #:with unsafe (dict-ref tbl #'i))) + + (define-syntax-class pair-opt-expr (pattern e:opt-expr #:when (match (type-of #'e) ; type of the operand @@ -85,6 +137,12 @@ kind) #t)) +;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments +(define (n-ary->binary op arg1 arg2 rest) + (for/fold ([o arg1]) + ([e (syntax->list #`(#,arg2 #,@rest))]) + #`(#,op #,o #,e))) + (define-syntax-class opt-expr* #:literal-sets (kernel-literals) @@ -93,24 +151,36 @@ #:with opt (begin (log-optimization "unary float" #'op) #'(op.unsafe f.opt))) - ;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments (pattern (~and res (#%plain-app (~var op (float-op binary-float-ops)) f1:float-arg-expr f2:float-arg-expr fs:float-arg-expr ...)) #:when (match (type-of #'res) ;; if the result is a float, we can coerce integers to floats and optimize [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) #:with opt (begin (log-optimization "binary float" #'op) - (for/fold ([o #'f1.opt]) - ([e (syntax->list #'(f2.opt fs.opt ...))]) - #`(op.unsafe #,o #,e)))) + (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-opt-expr f2:float-opt-expr fs:float-opt-expr ...)) #:when (match (type-of #'res) [(tc-result1: (== -Boolean type-equal?)) #t] [_ #f]) #:with opt (begin (log-optimization "binary float comp" #'op) - (for/fold ([o #'f1.opt]) - ([e (syntax->list #'(f2.opt fs.opt ...))]) - #`(op.unsafe #,o #,e)))) + (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) + + (pattern (#%plain-app op:fixnum-unary-op n:fixnum-opt-expr) + #:with opt + (begin (log-optimization "unary fixnum" #'op) + #'(op.unsafe n.opt))) + (pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops)) n1:fixnum-opt-expr n2:fixnum-opt-expr ns:fixnum-opt-expr ...) + #:with opt + (begin (log-optimization "binary fixnum" #'op) + (n-ary->binary #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...)))) + (pattern (#%plain-app op:nonzero-fixnum-binary-op n1:fixnum-opt-expr n2:nonzero-fixnum-opt-expr) + #:with opt + (begin (log-optimization "binary nonzero fixnum" #'op) + #'(op.unsafe n1.opt n2.opt))) + (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-opt-expr) + #:with opt + (begin (log-optimization "fixnum to float" #'op) + #'(unsafe-fx->fl n.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-opt-expr) From 783b505c9dc0282426098b8a44705385f643837c Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 11:04:44 -0400 Subject: [PATCH 138/198] Eliminate exact->inexact of floats. original commit: a6872c67a74e5d65a8a68b7fd5daa16b4225efe9 --- collects/typed-scheme/private/optimize.rkt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 6a786067..72c519a1 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -187,6 +187,11 @@ #: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 + (pattern (#%plain-app (~and op (~literal exact->inexact)) f:float-opt-expr) + #:with opt + (begin (log-optimization "float to float" #'op) + #'f.opt)) (pattern (#%plain-app op:pair-unary-op p:pair-opt-expr) #:with opt From be0e26235a8eb2c9a71d0291e38c3db10ec02895 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 11:18:04 -0400 Subject: [PATCH 139/198] Fixed build-vector's type. original commit: f27aac552fde4580850493dbde9fbb3d4a989e5a --- collects/typed-scheme/private/base-env-indexing-abs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index f54b1c34..a133aa12 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -132,7 +132,7 @@ [vector-ref (-poly (a) ((-vec a) index-type . -> . a))] [unsafe-vector-ref (-poly (a) ((-vec a) index-type . -> . a))] [unsafe-vector*-ref (-poly (a) ((-vec a) index-type . -> . a))] - [build-vector (-poly (a) (index-type (index-type . -> . a) . -> . (-vec a)))] + [build-vector (-poly (a) (index-type (-Nat . -> . a) . -> . (-vec a)))] [vector-set! (-poly (a) (-> (-vec a) index-type a -Void))] [unsafe-vector-set! (-poly (a) (-> (-vec a) index-type a -Void))] [unsafe-vector*-set! (-poly (a) (-> (-vec a) index-type a -Void))] From fc1a0a9e051501fa4dd337c16f85b0f26b3682f1 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 16:03:04 -0400 Subject: [PATCH 140/198] Added special case to the typechecker for (- 1). original commit: c6373ca7c09ec74e50e8b435b9a0387310c1b202 --- collects/typed-scheme/typecheck/tc-app.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 9644e5f2..2bcecb0f 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -608,7 +608,8 @@ [(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1))) (add-typeof-expr #'arg2 (ret -PositiveFixnum)) (match-let ([(tc-result1: t) (single-value #'v)]) - (cond + (cond + [(subtype t -PositiveFixnum) (ret (Un -Zero -PositiveFixnum))] [(subtype t (Un -Zero -PositiveFixnum)) (ret -Fixnum)] [(subtype t -ExactPositiveInteger) (ret -Nat)] [else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))] From 98738ea50af243ff6ae46668f8309f60184aac6a Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 16:17:37 -0400 Subject: [PATCH 141/198] Added a rule for valid float promotion when dividing. original commit: 8ec6d7ff3f835f88be73c07dddcf9e2dd6388e79 --- collects/typed-scheme/private/base-env-numeric.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 9ef60f87..a407d8ca 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -115,6 +115,8 @@ (append (list (->* (list -Integer) -Integer -ExactRational)) (for/list ([t (list -ExactRational -Flonum)]) (->* (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 -Real) -Real -Real)) (list (->* (list N) N N))))] From 431d91bf89e70f248b45b28a74073633d37a15df Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 18:09:30 -0400 Subject: [PATCH 142/198] Fixed the type for hash-ref! original commit: 90252c9bd33e7205a5494dd13fc823d6df78b477 --- collects/typed-scheme/private/base-env.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index d2252e2b..56651fef 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -536,7 +536,8 @@ (cl-> [((-HT a b) a) b] [((-HT a b) a (-> c)) (Un b c)]))] [hash-ref! (-poly (a b) - (cl-> [((-HT a b) a (-> b)) b]))] + (cl-> [((-HT a b) a b) b] + [((-HT a b) a (-> b)) b]))] [hash-has-key? (-poly (a b) (-> (-HT a b) a B))] [hash-update! (-poly (a b) (cl-> [((-HT a b) a (-> b b)) -Void] From 848b6f0e0277de6d40bfe8b290efcb39f2d9bbb9 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 19:38:40 -0400 Subject: [PATCH 143/198] Kept track of source location better in the for: macros and got rid of useless type ascriptions. original commit: 22a652ef8effe8cf670cd69221cb3dd4689b6a21 --- collects/typed-scheme/private/for-clauses.rkt | 32 ++++++++++++------- collects/typed-scheme/private/prims.rkt | 10 ++---- 2 files changed, 22 insertions(+), 20 deletions(-) diff --git a/collects/typed-scheme/private/for-clauses.rkt b/collects/typed-scheme/private/for-clauses.rkt index 305bb2f4..78c04cc8 100644 --- a/collects/typed-scheme/private/for-clauses.rkt +++ b/collects/typed-scheme/private/for-clauses.rkt @@ -9,18 +9,22 @@ (define-splicing-syntax-class for-clause ;; single-valued seq-expr - (pattern (var:annotated-name seq-expr:expr) - #:with (expand ...) (list #`(var.ann-name + (pattern (~and c (var:annotated-name seq-expr:expr)) + #:with (expand ...) (list (quasisyntax/loc + #'c + (var.ann-name #,(syntax-property #'seq-expr 'type-ascription - #'(Sequenceof var.ty))))) + #'(Sequenceof var.ty)))))) ;; multi-valued seq-expr ;; currently disabled because it triggers an internal error in the typechecker - #;(pattern (((v:annotated-name) ...) seq-expr:expr) - #:with (expand ...) (list #`((v.ann-name ...) + #;(pattern (~and c (((v:annotated-name) ...) seq-expr:expr)) + #:with (expand ...) (list (quasisyntax/loc + #'c + ((v.ann-name ...) #,(syntax-property #'seq-expr 'type-ascription - #'(Sequenceof (values v.ty ...)))))) + #'(Sequenceof (values v.ty ...))))))) ;; when clause (pattern (~seq #:when guard:expr) #:with (expand ...) (list #'#:when #'guard))) @@ -28,19 +32,23 @@ ;; intersperses "#:when #t" clauses to emulate the for* variants' semantics (define-splicing-syntax-class for*-clause ;; single-valued seq-expr - (pattern (var:annotated-name seq-expr:expr) - #:with (expand ...) (list #`(var.ann-name + (pattern (~and c (var:annotated-name seq-expr:expr)) + #:with (expand ...) (list (quasisyntax/loc + #'c + (var.ann-name #,(syntax-property #'seq-expr 'type-ascription - #'(Sequenceof var.ty))) + #'(Sequenceof var.ty)))) #'#:when #'#t)) ;; multi-valued seq-expr ;; currently disabled because it triggers an internal error in the typechecker - #;(pattern (((v:annotated-name) ...) seq-expr:expr) - #:with (expand ...) (list #`((v.ann-name ...) + #;(pattern (~and c (((v:annotated-name) ...) seq-expr:expr)) + #:with (expand ...) (list (quasisyntax/loc + #'c + ((v.ann-name ...) #,(syntax-property #'seq-expr 'type-ascription - #'(Sequenceof (values v.ty ...)))) + #'(Sequenceof (values v.ty ...))))) #'#:when #'#t)) ;; when clause (pattern (~seq #:when guard:expr) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index a1ae9550..e213f46d 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -518,10 +518,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (quasisyntax/loc stx (for/lists (var.ann-name ...) (clause.expand ... ...) - #,@(syntax-property - #'(c ...) - 'type-ascription - #'ty))) + c ...)) 'type-ascription #'ty)])) (define-syntax (for/fold: stx) @@ -534,10 +531,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (quasisyntax/loc stx (for/fold ((var.ann-name init) ...) (clause.expand ... ...) - #,@(syntax-property - #'(c ...) - 'type-ascription - #'ty))) + c ...)) 'type-ascription #'ty)])) From c6a22a53f48057e023b7e3919854194e5860ada7 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 16:38:39 -0400 Subject: [PATCH 144/198] Fixed the type of min and max to only operate on reals. original commit: ef576e27c5187783648209c55d4ca211ff693e05 --- .../typed-scheme/succeed/manual-examples.rkt | 4 ++-- .../typed-scheme/succeed/map-nonempty.rkt | 4 ++-- .../typed-scheme/succeed/new-metrics.rkt | 8 +++---- .../typed-scheme/private/base-env-numeric.rkt | 21 ++++++++++++++----- collects/typed-scheme/scribblings/begin.scrbl | 2 +- 5 files changed, 25 insertions(+), 14 deletions(-) diff --git a/collects/tests/typed-scheme/succeed/manual-examples.rkt b/collects/tests/typed-scheme/succeed/manual-examples.rkt index 5c6f9731..7541ae74 100644 --- a/collects/tests/typed-scheme/succeed/manual-examples.rkt +++ b/collects/tests/typed-scheme/succeed/manual-examples.rkt @@ -30,7 +30,7 @@ (define-typed-struct leaf ([val : Number])) (define-typed-struct node ([left : (Un node leaf)] [right : (Un node leaf)])) - (define: (tree-height [t : (Un node leaf)]) : Number + (define: (tree-height [t : (Un node leaf)]) : Integer (cond [(leaf? t) 1] [else (max (tree-height (node-left t)) (tree-height (node-right t)))])) @@ -46,7 +46,7 @@ (define-type-alias tree (Un node leaf)) - (define: (tree-height [t : tree]) : Number + (define: (tree-height [t : tree]) : Integer (cond [(leaf? t) 1] [else (max (tree-height (node-left t)) (tree-height (node-right t)))])) diff --git a/collects/tests/typed-scheme/succeed/map-nonempty.rkt b/collects/tests/typed-scheme/succeed/map-nonempty.rkt index 0fddf079..a501bb0a 100644 --- a/collects/tests/typed-scheme/succeed/map-nonempty.rkt +++ b/collects/tests/typed-scheme/succeed/map-nonempty.rkt @@ -1,6 +1,6 @@ #lang typed/scheme -(: x (Pair Number (Listof Number))) +(: x (Pair Integer (Listof Integer))) (define x (cons 1 (list 1 2 3 4))) -(apply max (ann (map add1 x) : (Pair Number (Listof Number)))) \ No newline at end of file +(apply max (ann (map add1 x) : (Pair Integer (Listof Integer)))) \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/new-metrics.rkt b/collects/tests/typed-scheme/succeed/new-metrics.rkt index a3316300..5513eda8 100644 --- a/collects/tests/typed-scheme/succeed/new-metrics.rkt +++ b/collects/tests/typed-scheme/succeed/new-metrics.rkt @@ -93,16 +93,16 @@ ;; ---------------------------------------- ;; depth -(: sexp-depth (Any -> Number)) +(: sexp-depth (Any -> Integer)) (define (sexp-depth sexp) (cond [(pair? sexp) (+ (max-sexp-depth sexp) 1)] [else 0])) -(: max-sexp-depth (Any -> Number)) +(: max-sexp-depth (Any -> Integer)) (define (max-sexp-depth losx) - (improper-foldr (λ: ([t : Any] [r : Number]) (max (sexp-depth t) r)) 0 losx)) + (improper-foldr (λ: ([t : Any] [r : Integer]) (max (sexp-depth t) r)) 0 losx)) (: avg-sexp-depth ((Listof Any) -> Number)) (define (avg-sexp-depth sexps) @@ -201,7 +201,7 @@ ;; ---------------------------------------- ;; expression size -(: atoms (Any -> Number)) +(: atoms (Any -> Integer)) (define (atoms sexp) (cond [(null? sexp) 0] diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index a407d8ca..ac078375 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -120,16 +120,27 @@ (list (->* (list -Real) -Real -Real)) (list (->* (list N) N N))))] -[max (apply cl->* - (->* (list -PositiveFixnum) -Fixnum -PositiveFixnum) +[max (cl->* (->* (list -PositiveFixnum) -Fixnum -PositiveFixnum) (->* (list -NonnegativeFixnum) -Fixnum -NonnegativeFixnum) + (->* (list -NegativeFixnum) -NegativeFixnum -NegativeFixnum) (->* (list -Fixnum) -Fixnum -Fixnum) (->* (list -Pos) -Integer -Pos) (->* (list -Nat) -Integer -Nat) - (for/list ([t all-num-types]) (->* (list t) t t)))] -[min (apply cl->* + (->* (list -Integer) -Integer -Integer) + (->* (list -ExactRational) -ExactRational -ExactRational) + (->* (list -Flonum) -Flonum -Flonum) + (->* (list -Real) -Real -Real))] +[min (cl->* (->* (list -PositiveFixnum) -PositiveFixnum -PositiveFixnum) + (->* (list -NonnegativeFixnum) -NonnegativeFixnum -NonnegativeFixnum) + (->* (list -NegativeFixnum) -Fixnum -NegativeFixnum) + (->* (list -Fixnum) -NegativeFixnum -NegativeFixnum) (->* (list -Fixnum) -Fixnum -Fixnum) - (for/list ([t all-num-types]) (->* (list t) t t)))] + (->* (list -Pos) -Pos -Pos) + (->* (list -Nat) -Nat -Nat) + (->* (list -Integer) -Integer -Integer) + (->* (list -ExactRational) -ExactRational -ExactRational) + (->* (list -Flonum) -Flonum -Flonum) + (->* (list -Real) -Real -Real))] [add1 (cl->* (-> -Pos -Pos) diff --git a/collects/typed-scheme/scribblings/begin.scrbl b/collects/typed-scheme/scribblings/begin.scrbl index 697c1056..137b8e29 100644 --- a/collects/typed-scheme/scribblings/begin.scrbl +++ b/collects/typed-scheme/scribblings/begin.scrbl @@ -74,7 +74,7 @@ typed/racket (define-struct: leaf ([val : Number])) (define-struct: node ([left : Tree] [right : Tree])) -(: tree-height (Tree -> Number)) +(: tree-height (Tree -> Integer)) (define (tree-height t) (cond [(leaf? t) 1] [else (max (+ 1 (tree-height (node-left t))) From b7d9ed75e2280d50c3d1557f9c250adc3f7f6f84 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 16:39:20 -0400 Subject: [PATCH 145/198] Added the Inexact-Complex type. original commit: dcfb2d8a94b1359217b9451b7a97d4afa425a6da --- .../typed-scheme/fail/inexact-complex.rkt | 9 +++ .../typed-scheme/succeed/inexact-complex.rkt | 9 +++ .../unit-tests/typecheck-tests.rkt | 4 ++ .../typed-scheme/private/base-env-numeric.rkt | 72 +++++++++++++------ collects/typed-scheme/private/base-types.rkt | 1 + .../scribblings/ts-reference.scrbl | 1 + .../typed-scheme/typecheck/tc-expr-unit.rkt | 3 + collects/typed-scheme/types/abbrev.rkt | 3 + collects/typed-scheme/types/subtype.rkt | 5 +- 9 files changed, 84 insertions(+), 23 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/inexact-complex.rkt create mode 100644 collects/tests/typed-scheme/succeed/inexact-complex.rkt diff --git a/collects/tests/typed-scheme/fail/inexact-complex.rkt b/collects/tests/typed-scheme/fail/inexact-complex.rkt new file mode 100644 index 00000000..1619911c --- /dev/null +++ b/collects/tests/typed-scheme/fail/inexact-complex.rkt @@ -0,0 +1,9 @@ +#; +(exn-pred 2) +#lang typed/scheme + +(ann 1+2i Inexact-Complex) + +(: f (Real -> Inexact-Complex)) +(define (f x) + (* x 2.0)) ; x can be exact 0 diff --git a/collects/tests/typed-scheme/succeed/inexact-complex.rkt b/collects/tests/typed-scheme/succeed/inexact-complex.rkt new file mode 100644 index 00000000..04e1c1b5 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/inexact-complex.rkt @@ -0,0 +1,9 @@ +#lang typed/scheme + +(ann 1.1+2.0i Inexact-Complex) +(ann 1+2.0i Inexact-Complex) +(ann (real-part 1.1+2.0i) Float) +(ann (real-part 1+2.0i) Float) +(ann (imag-part 1.1+2.0i) Float) +(ann (+ 2.0 2.0+2.0i) Inexact-Complex) +(ann (+ 2 2.0+2.0i) Inexact-Complex) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 62314b0a..46c300ab 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -842,6 +842,10 @@ (tc-l 5# -Flonum) (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 #t (-val #t)) (tc-l "foo" -String) (tc-l foo (-val 'foo)) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index ac078375..75d8e56c 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -61,7 +61,7 @@ [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 -Flonum 0)))] +[inexact? (asym-pred N B (-FS -top (-not-filter (Un -Flonum -InexactComplex) 0)))] [fixnum? (make-pred-ty -Fixnum)] [positive? (-> -Real B)] [negative? (-> -Real B)] @@ -94,6 +94,7 @@ [* (apply cl->* (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) (list (->* (list) -Real -Real)) + (list (->* (list) -InexactComplex -InexactComplex)) (list (->* (list) N N))))] [+ (apply cl->* (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) @@ -102,6 +103,9 @@ (list (->* (list -Flonum) -Real -Flonum)) (list (->* (list -Real -Flonum) -Real -Flonum)) (list (->* (list) -Real -Real)) + (list (->* (list -Real) -InexactComplex -InexactComplex)) + (list (->* (list -InexactComplex) -Real -InexactComplex)) + (list (->* (list) -InexactComplex -InexactComplex)) (list (->* (list) N N))))] [- (apply cl->* @@ -110,6 +114,9 @@ (list (->* (list -Flonum) -Real -Flonum)) (list (->* (list -Real -Flonum) -Real -Flonum)) (list (->* (list -Real) -Real -Real)) + (list (->* (list -Real) -InexactComplex -InexactComplex)) + (list (->* (list -InexactComplex) -Real -InexactComplex)) + (list (->* (list -InexactComplex) -InexactComplex -InexactComplex)) (list (->* (list N) N N))))] [/ (apply cl->* (append (list (->* (list -Integer) -Integer -ExactRational)) @@ -118,6 +125,7 @@ ;; only exact 0 as first argument can cause the result of a division involving inexacts to be exact (list (->* (list -Flonum) -Real -Flonum)) (list (->* (list -Real) -Real -Real)) + (list (->* (list -InexactComplex) -InexactComplex -InexactComplex)) (list (->* (list N) N N))))] [max (cl->* (->* (list -PositiveFixnum) -Fixnum -PositiveFixnum) @@ -149,6 +157,7 @@ (-> -ExactRational -ExactRational) (-> -Flonum -Flonum) (-> -Real -Real) + (-> -InexactComplex -InexactComplex) (-> N N))] [sub1 (cl->* (-> -Pos -Nat) @@ -156,6 +165,7 @@ (-> -ExactRational -ExactRational) (-> -Flonum -Flonum) (-> -Real -Real) + (-> -InexactComplex -InexactComplex) (-> N N))] [quotient (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . -NonnegativeFixnum) @@ -199,7 +209,7 @@ ;; exactness [exact->inexact (cl->* (-Real . -> . -Flonum) - (N . -> . N))] + (N . -> . -InexactComplex))] [inexact->exact (cl->* (-Real . -> . -ExactRational) (N . -> . N))] @@ -208,33 +218,47 @@ [ceiling rounder] [truncate rounder] [round rounder] -[make-rectangular (-Real -Real . -> . N)] -[make-polar (-Real -Real . -> . N)] -[real-part (N . -> . -Real)] -[imag-part (N . -> . -Real)] -[magnitude (N . -> . -Real)] -[angle (N . -> . -Real)] -[numerator (-Real . -> . -Real)] -[denominator (-Real . -> . -Real)] -[rationalize (-Real -Real . -> . N)] +[make-rectangular (cl->* (-Flonum -Flonum . -> . -InexactComplex) + (-Real -Real . -> . N))] +[make-polar (cl->* (-Flonum -Flonum . -> . -InexactComplex) + (-Real -Real . -> . N))] +[real-part (cl->* (-InexactComplex . -> . -Flonum) + (N . -> . -Real))] +[imag-part (cl->* (-InexactComplex . -> . -Flonum) + (N . -> . -Real))] +[magnitude (cl->* (-InexactComplex . -> . -Flonum) + (N . -> . -Real))] +[angle (cl->* (-InexactComplex . -> . -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))] [expt (cl->* (-Nat -Nat . -> . -Nat) (-Integer -Nat . -> . -Integer) (-Real -Integer . -> . -Real) + (-InexactComplex -InexactComplex . -> . -InexactComplex) (N N . -> . N))] [sqrt (cl->* (-Nat . -> . -Real) + (-InexactComplex . -> . -InexactComplex) (N . -> . N))] [log (cl->* (-Pos . -> . -Real) + (-InexactComplex . -> . -InexactComplex) (N . -> . N))] [exp (cl->* (-Real . -> . -Real) + (-InexactComplex . -> . -InexactComplex) (N . -> . N))] -[cos (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] -[sin (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] -[tan (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] -[acos (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] -[asin (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N))] -[atan (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (N . -> . N) (-Real -Real . -> . 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))] [gcd (cl->* (null -Fixnum . ->* . -Fixnum) (null -Integer . ->* . -Integer))] [lcm (null -Integer . ->* . -Integer)] @@ -248,12 +272,16 @@ (-> -ExactRational -ExactRational) (-> -Flonum -Flonum) (-> -Real -Real) + (-> -InexactComplex -InexactComplex) (-> N N))] -[sgn (N . -> . N)] -[conjugate (N . -> . N)] -[sinh (N . -> . N)] -[cosh (N . -> . N)] -[tanh (N . -> . N)] +[conjugate (cl->* (-InexactComplex . -> . -InexactComplex) + (N . -> . N))] +[sinh (cl->* (-InexactComplex . -> . -InexactComplex) + (N . -> . N))] +[cosh (cl->* (-InexactComplex . -> . -InexactComplex) + (N . -> . N))] +[tanh (cl->* (-InexactComplex . -> . -InexactComplex) + (N . -> . N))] ;; unsafe numeric ops [unsafe-flabs fl-unop] diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index a406ea74..9f8f775c 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -1,6 +1,7 @@ #lang s-exp "type-env-lang.rkt" [Complex -Number] +[Inexact-Complex -InexactComplex] [Number -Number] [Integer -Integer] [Real -Real] diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index c831a506..e96d08ef 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -34,6 +34,7 @@ any expression of this type will not evaluate to a value.} @deftogether[( @defidform[Number] @defidform[Complex] +@defidform[Inexact-Complex] @defidform[Real] @defidform[Float] @defidform[Exact-Rational] diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index b1beaeb4..2a213987 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -43,6 +43,9 @@ [(~var i (3d (conjoin number? exact? rational?))) -ExactRational] [(~var i (3d inexact-real?)) -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] [(~var i (3d number?)) -Number] [i:str -String] [i:char -Char] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index f4a5b562..bf40ffd2 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -150,6 +150,9 @@ ;; 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 -Flonum (make-Base 'Flonum #'inexact-real?)) (define -ExactRational diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index aee51187..8b9047c3 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -233,10 +233,11 @@ [((Union: (list)) _) A0] ;; value types [((Value: v1) (Value: v2)) (=> unmatch) (if (equal? v1 v2) A0 (unmatch))] - ;; now we encode the numeric hierarchy - bletch + ;; now we encode the numeric hierarchy - bletch [((Base: 'Integer _) (Base: 'Number _)) A0] [((Base: 'Flonum _) (== -Real =t)) A0] [((Base: 'Integer _) (== -Real =t)) A0] + [((Base: 'Flonum _) (Base: 'InexactComplex _)) A0] [((Base: 'Flonum _) (Base: 'Number _)) A0] [((Base: 'Exact-Rational _) (Base: 'Number _)) A0] [((Base: 'Integer _) (Base: 'Exact-Rational _)) A0] @@ -263,6 +264,8 @@ [((== -Fixnum =t) (Base: 'Exact-Rational _)) A0] [((== -Fixnum =t) (Base: 'Integer _)) A0] + [((Base: 'InexactComplex _) (Base: 'Number _)) A0] + ;; values are subtypes of their "type" [((Value: (? exact-integer? n)) (Base: 'Integer _)) A0] From f89158a144603fd3a88123b4fc131efef0268f7d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 20:03:20 -0400 Subject: [PATCH 146/198] Updated make-vector's type for fixnums. original commit: 06b636b2e31e32fed83d1a58293e1b8f36f8381a --- collects/typed-scheme/private/base-env-indexing-abs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index a133aa12..62b7a071 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -137,7 +137,7 @@ [unsafe-vector-set! (-poly (a) (-> (-vec a) index-type a -Void))] [unsafe-vector*-set! (-poly (a) (-> (-vec a) index-type a -Void))] [vector-copy! (-poly (a) ((-vec a) index-type (-vec a) [index-type index-type] . ->opt . -Void))] - [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Nat a))] + [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -NonnegativeFixnum a))] [(index-type a) (-vec a)]))] [bytes-ref (-> -Bytes index-type -NonnegativeFixnum)] From 9b7ee99d39ae445fe440a879001c421fca8a87da Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 28 Jun 2010 20:13:21 -0400 Subject: [PATCH 147/198] Extended type signatures for addition. original commit: e8c42cd20cc00e607e44bb6f172333d49b8a707d --- collects/typed-scheme/private/base-env-numeric.rkt | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 75d8e56c..614a8723 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -97,7 +97,9 @@ (list (->* (list) -InexactComplex -InexactComplex)) (list (->* (list) N N))))] [+ (apply cl->* - (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) + (append (list (->* (list -Pos) -Nat -Pos)) + (list (->* (list -Nat) -Pos -Pos)) + (for/list ([t (list -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) ;; 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 -Flonum) -Real -Flonum)) @@ -311,7 +313,10 @@ [unsafe-flsqrt fl-unop] [unsafe-fx->fl (-Integer . -> . -Flonum)] -[unsafe-fx+ fx-op] +[unsafe-fx+ (cl->* (-Pos -Nat . -> . -PositiveFixnum) + (-Nat -Pos . -> . -PositiveFixnum) + (-Nat -Nat . -> . -NonnegativeFixnum) + (-Integer -Integer . -> . -Fixnum))] [unsafe-fx- fx-intop] [unsafe-fx* fx-op] [unsafe-fxquotient fx-intop] @@ -336,7 +341,10 @@ ;; scheme/fixnum -[fx+ fx-op] +[fx+ (cl->* (-Pos -Nat . -> . -PositiveFixnum) + (-Nat -Pos . -> . -PositiveFixnum) + (-Nat -Nat . -> . -NonnegativeFixnum) + (-Integer -Integer . -> . -Fixnum))] [fx- fx-intop] [fx* fx-op] [fxquotient fx-intop] From e25b242c6a435d4a3a33d72282a606b717d2fffb Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 29 Jun 2010 14:49:02 -0400 Subject: [PATCH 148/198] Added filters for numeric comparisons. original commit: f026da5ecf4cd144dfc82ec5660c95542c49bb07 --- .../typed-scheme/private/base-env-numeric.rkt | 139 ++++++++++++++---- 1 file changed, 110 insertions(+), 29 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 614a8723..b4365578 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -47,6 +47,50 @@ (define-for-syntax fx-unop (-Integer . -> . -Fixnum)) (define-for-syntax real-comp (->* (list R R) R B)) + + ;; types for specific operations, to avoid repetition between safe and unsafe versions + (define-for-syntax fx+-type + (cl->* (-Pos -Nat . -> . -PositiveFixnum) + (-Nat -Pos . -> . -PositiveFixnum) + (-Nat -Nat . -> . -NonnegativeFixnum) + (-Integer -Integer . -> . -Fixnum))) + (define-for-syntax fx=-type + (cl->* + (-> -Integer (-val 0) B : (-FS (-filter (-val 0) 0) -top)) + (-> (-val 0) -Integer B : (-FS (-filter (-val 0) 1) -top)) + (-> -Integer -Pos B : (-FS (-filter -PositiveFixnum 0) -top)) + (-> -Pos -Integer B : (-FS (-filter -PositiveFixnum 1) -top)) + (-> -Integer -Nat B : (-FS (-filter -NonnegativeFixnum 0) -top)) + (-> -Nat -Integer B : (-FS (-filter -NonnegativeFixnum 1) -top)) + (-> -Integer -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top)) + (-> -NegativeFixnum -Integer B : (-FS (-filter -NegativeFixnum 1) -top)) + fx-comp)) + (define-for-syntax 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 + (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 + (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 + (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)) ) ;; numeric predicates @@ -54,7 +98,7 @@ (-not-filter -Zero 0)))] [number? (make-pred-ty N)] [integer? (asym-pred Univ B (-FS (-filter (Un -Integer -Flonum) 0) - (-not-filter -Integer 0)))] + (-not-filter -Integer 0)))] [exact-integer? (make-pred-ty -Integer)] [real? (make-pred-ty -Real)] [inexact-real? (make-pred-ty -Flonum)] @@ -63,12 +107,16 @@ [exact? (asym-pred N B (-FS -top (-not-filter -ExactRational 0)))] [inexact? (asym-pred N B (-FS -top (-not-filter (Un -Flonum -InexactComplex) 0)))] [fixnum? (make-pred-ty -Fixnum)] -[positive? (-> -Real B)] -[negative? (-> -Real B)] +[positive? (cl->* (-> -Fixnum B : (-FS (-filter -PositiveFixnum 0) -top)) + (-> -Integer B : (-FS (-filter -ExactPositiveInteger 0) -top)) + (-> -Real B))] +[negative? (cl->* (-> -Fixnum B : (-FS (-filter -NegativeFixnum 0) (-filter -NonnegativeFixnum 0))) + (-> -Integer B : (-FS -top (-filter -Nat 0))) + (-> -Real B))] [exact-positive-integer? (make-pred-ty -Pos)] [exact-nonnegative-integer? (make-pred-ty -Nat)] -[odd? (-> -Integer B)] +[odd? (-> -Integer B : (-FS -top (-filter (-val 0) 0)))] [even? (-> -Integer B)] [modulo (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . -NonnegativeFixnum) @@ -76,19 +124,58 @@ (-Nat -Nat . -> . -Nat) (-Integer -Integer . -> . -Integer))] -[= (->* (list N N) N B)] +[= (cl->* + (-> -Integer (-val 0) B : (-FS (-filter (-val 0) 0) -top)) + (-> (-val 0) -Integer B : (-FS (-filter (-val 0) 1) -top)) + (-> -Integer -PositiveFixnum B : (-FS (-filter -PositiveFixnum 0) -top)) + (-> -PositiveFixnum -Integer B : (-FS (-filter -PositiveFixnum 1) -top)) + (-> -Integer -NonnegativeFixnum B : (-FS (-filter -NonnegativeFixnum 0) -top)) + (-> -NonnegativeFixnum -Integer B : (-FS (-filter -NonnegativeFixnum 1) -top)) + (-> -Integer -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top)) + (-> -NegativeFixnum -Integer B : (-FS (-filter -NegativeFixnum 1) -top)) + (-> -Integer -Pos B : (-FS (-filter -Pos 0) -top)) + (-> -Pos -Integer B : (-FS (-filter -Pos 1) -top)) + (-> -Integer -Nat B : (-FS (-filter -Nat 0) -top)) + (-> -Nat -Integer B : (-FS (-filter -Nat 1) -top)) + (->* (list N N) N B))] -[>= real-comp] -[< (cl->* +[> (cl->* + (-> -Fixnum (-val 0) B : (-FS (-filter -PositiveFixnum 0) -top)) + (-> -Integer (-val 0) B : (-FS (-filter -Pos 0) -top)) + (-> -NegativeFixnum -Fixnum B : (-FS (-filter -NegativeFixnum 1) -top)) + (-> -Fixnum -NonnegativeFixnum B : (-FS (-filter -PositiveFixnum 1) -top)) + (-> -Fixnum -Nat B : (-FS (-filter -Fixnum 1) -top)) + (-> -Integer -Nat B : (-FS (-filter -ExactPositiveInteger 0) -top)) + real-comp)] +[>= (cl->* + (-> -Fixnum (-val 0) B : (-FS (-filter -NonnegativeFixnum 0) (-filter -NegativeFixnum 0))) + (-> -Integer (-val 0) B : (-FS (-filter -ExactNonnegativeInteger 0) -top)) + (-> -Fixnum -PositiveFixnum B : (-FS (-filter -PositiveFixnum 0) -top)) + (-> -Fixnum -NonnegativeFixnum B : (-FS (-filter -NonnegativeFixnum 0) -top)) + (-> -Fixnum -Pos B : (-FS (-filter -PositiveFixnum 1) -top)) + (-> -Fixnum -Nat B : (-FS (-filter -NonnegativeFixnum 1) -top)) + (-> -Integer -Pos B : (-FS (-filter -Pos 0) -top)) + (-> -Integer -Nat B : (-FS (-filter -Nat 0) -top)) + real-comp)] +[< (cl->* + (-> -Fixnum (-val 0) B : (-FS (-filter -NegativeFixnum 0) (-filter -NonnegativeFixnum 0))) + (-> -Integer (-val 0) B : (-FS -top (-filter -ExactNonnegativeInteger 0))) + (-> -NonnegativeFixnum -Fixnum B : (-FS (-filter -PositiveFixnum 1) -top)) + (-> -Fixnum -NegativeFixnum B : (-FS (-filter -NegativeFixnum 0) -top)) + (-> -Nat -Fixnum B : (-FS (-filter -NonnegativeFixnum 0) -top)) (-> -Nat -Integer B : (-FS (-filter -Pos 1) -top)) (-> -Integer -Nat B : (-FS -top (-filter -Nat 0))) - (-> -Integer (-val 0) B : (-FS -top (-filter -Nat 0))) real-comp)] -[<= (cl->* - (-> -Nat -Integer B : (-FS (-filter -Nat 1) -top)) +[<= (cl->* + (-> -Fixnum (-val 0) B : (-FS -top (-filter -PositiveFixnum 0))) + (-> -Integer (-val 0) B : (-FS -top (-filter -ExactPositiveInteger 0))) + (-> -PositiveFixnum -Fixnum B : (-FS (-filter -PositiveFixnum 1) -top)) + (-> -NonnegativeFixnum -Fixnum B : (-FS (-filter -NonnegativeFixnum 1) -top)) + (-> -Pos -Fixnum B : (-FS (-filter -PositiveFixnum 0) -top)) + (-> -Nat -Fixnum B : (-FS (-filter -NonnegativeFixnum 0) -top)) (-> -Pos -Integer B : (-FS (-filter -Pos 1) -top)) + (-> -Nat -Integer B : (-FS (-filter -Nat 1) -top)) real-comp)] -[> real-comp] [* (apply cl->* @@ -313,10 +400,7 @@ [unsafe-flsqrt fl-unop] [unsafe-fx->fl (-Integer . -> . -Flonum)] -[unsafe-fx+ (cl->* (-Pos -Nat . -> . -PositiveFixnum) - (-Nat -Pos . -> . -PositiveFixnum) - (-Nat -Nat . -> . -NonnegativeFixnum) - (-Integer -Integer . -> . -Fixnum))] +[unsafe-fx+ fx+-type] [unsafe-fx- fx-intop] [unsafe-fx* fx-op] [unsafe-fxquotient fx-intop] @@ -331,20 +415,17 @@ [unsafe-fxlshift fx-intop] [unsafe-fxrshift (cl->* (-> -NonnegativeFixnum -NonnegativeFixnum -NonnegativeFixnum) fx-intop)] -[unsafe-fx= fx-comp] -[unsafe-fx< fx-comp] -[unsafe-fx> fx-comp] -[unsafe-fx<= fx-comp] -[unsafe-fx>= fx-comp] +[unsafe-fx= fx=-type] +[unsafe-fx< fx<-type] +[unsafe-fx> fx>-type] +[unsafe-fx<= fx<=-type] +[unsafe-fx>= fx>=-type] [unsafe-fxmin fx-op] [unsafe-fxmax fx-op] ;; scheme/fixnum -[fx+ (cl->* (-Pos -Nat . -> . -PositiveFixnum) - (-Nat -Pos . -> . -PositiveFixnum) - (-Nat -Nat . -> . -NonnegativeFixnum) - (-Integer -Integer . -> . -Fixnum))] +[fx+ fx+-type] [fx- fx-intop] [fx* fx-op] [fxquotient fx-intop] @@ -359,11 +440,11 @@ [fxlshift fx-intop] [fxrshift (cl->* (-> -NonnegativeFixnum -NonnegativeFixnum -NonnegativeFixnum) fx-intop)] -[fx= fx-comp] -[fx< fx-comp] -[fx> fx-comp] -[fx<= fx-comp] -[fx>= fx-comp] +[fx= fx=-type] +[fx< fx<-type] +[fx> fx>-type] +[fx<= fx<=-type] +[fx>= fx>=-type] [fxmin fx-op] [fxmax fx-op] From 6dd9ffd7276f82f8edc889d253a0c743fe6cf29a Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 29 Jun 2010 12:12:41 -0400 Subject: [PATCH 149/198] Added the Nonnegative-Float type. original commit: 62a15df3eb2fd7dc5a8ef2455c0f20918697a668 --- .../typed-scheme/fail/nonnegative-float.rkt | 5 + .../succeed/nonnegative-float.rkt | 6 + .../tests/typed-scheme/succeed/pair-test3.rkt | 2 +- .../unit-tests/typecheck-tests.rkt | 16 +- .../typed-scheme/private/base-env-numeric.rkt | 145 +++++++++++++----- collects/typed-scheme/private/base-types.rkt | 1 + collects/typed-scheme/private/optimize.rkt | 12 +- .../scribblings/ts-reference.scrbl | 1 + .../typed-scheme/typecheck/tc-expr-unit.rkt | 4 + collects/typed-scheme/types/abbrev.rkt | 3 + collects/typed-scheme/types/subtype.rkt | 4 + 11 files changed, 149 insertions(+), 50 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/nonnegative-float.rkt create mode 100644 collects/tests/typed-scheme/succeed/nonnegative-float.rkt diff --git a/collects/tests/typed-scheme/fail/nonnegative-float.rkt b/collects/tests/typed-scheme/fail/nonnegative-float.rkt new file mode 100644 index 00000000..ac797481 --- /dev/null +++ b/collects/tests/typed-scheme/fail/nonnegative-float.rkt @@ -0,0 +1,5 @@ +#; +(exn-pred 1) +#lang typed/scheme + +(ann (- 1.0 0.5) Nonnegative-Float) ; can't prove it's nonnegative diff --git a/collects/tests/typed-scheme/succeed/nonnegative-float.rkt b/collects/tests/typed-scheme/succeed/nonnegative-float.rkt new file mode 100644 index 00000000..de361d76 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/nonnegative-float.rkt @@ -0,0 +1,6 @@ +#lang typed/scheme + +(ann (+ 1.0 2.1) Nonnegative-Float) +(ann (+ 1 2.1) Nonnegative-Float) +(ann (* 1.2 3.1) Nonnegative-Float) +(ann (sqrt 3.5) Nonnegative-Float) diff --git a/collects/tests/typed-scheme/succeed/pair-test3.rkt b/collects/tests/typed-scheme/succeed/pair-test3.rkt index 460b6cf9..e45bd796 100644 --- a/collects/tests/typed-scheme/succeed/pair-test3.rkt +++ b/collects/tests/typed-scheme/succeed/pair-test3.rkt @@ -11,7 +11,7 @@ '((((1 . "1") . (#t)) . ((#f . #\f) . ("2"))) . ((("3" . 4) . (1.0)) - . ((#(2.0 3.0 4.0) . #t) + . ((#(2.0 3.0 -4.0) . #t) . ((2.0 3.0 4.0) . #f))))) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 46c300ab..36f097a6 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -38,7 +38,6 @@ (define Sym -Symbol) (define -Pos -ExactPositiveInteger) (define R -Real) -(define F -Flonum) (define (g) (run typecheck-tests)) @@ -798,7 +797,8 @@ Univ] [tc-e (floor 1/2) -Integer] [tc-e (ceiling 1/2) -Integer] - [tc-e (truncate 0.5) -Flonum] + [tc-e (truncate 0.5) -NonnegativeFlonum] + [tc-e (truncate -0.5) -Flonum] [tc-e/t (ann (lambda (x) (lambda (x) x)) (Integer -> (All (X) (X -> X)))) (t:-> -Integer (-poly (x) (t:-> x x)))] @@ -838,10 +838,14 @@ (tc-l 5 -PositiveFixnum) (tc-l -5 -NegativeFixnum) (tc-l 0 -Zero) - (tc-l 0.0 -Flonum) - (tc-l 5# -Flonum) - (tc-l 5.0 -Flonum) - (tc-l 5.1 -Flonum) + (tc-l 0.0 -NonnegativeFlonum) + (tc-l -0.0 -Flonum) + (tc-l 5# -NonnegativeFlonum) + (tc-l 5.0 -NonnegativeFlonum) + (tc-l 5.1 -NonnegativeFlonum) + (tc-l -5# -Flonum) + (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) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index b4365578..11e8414c 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -26,6 +26,7 @@ (-> -Pos -Pos) (-> -Nat -Nat) (-> -ExactRational -Integer) + (-> -NonnegativeFlonum -NonnegativeFlonum) (-> -Flonum -Flonum) (-> -Real -Real))) @@ -34,7 +35,9 @@ (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 + (cl->* (-> -NonnegativeFlonum -NonnegativeFlonum) + (-> -Flonum -Flonum))) (define-for-syntax int-op (binop -Integer)) (define-for-syntax nat-op (binop -Nat)) @@ -91,10 +94,49 @@ (-> -Integer -Pos B : (-FS (-filter -Pos 0) -top)) (-> -Integer -Nat B : (-FS (-filter -Nat 0) -top)) fx-comp)) + (define-for-syntax fxmin-type + (cl->* + (-> -NegativeFixnum -Integer -NegativeFixnum) + (-> -Integer -NegativeFixnum -NegativeFixnum) + (-> -Pos -Pos -PositiveFixnum) + (-> -Nat -Nat -NonnegativeFixnum) + (-> -Integer -Integer -Fixnum))) + (define-for-syntax fxmax-type + (cl->* + (-> -NegativeFixnum -NegativeFixnum -NegativeFixnum) + (-> -Pos -Integer -PositiveFixnum) + (-> -Integer -Pos -PositiveFixnum) + (-> -Nat -Integer -NonnegativeFixnum) + (-> -Integer -Nat -NonnegativeFixnum) + (-> -Integer -Integer -Fixnum))) + + (define-for-syntax fl+*-type + (cl->* (-NonnegativeFlonum -NonnegativeFlonum . -> . -NonnegativeFlonum) + (-Flonum -Flonum . -> . -Flonum))) + (define-for-syntax 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 + (cl->* + (-> -NonnegativeFlonum -Flonum B : (-FS (-filter -NonnegativeFlonum 1) -top)) + fl-comp)) + (define-for-syntax fl>-type + (cl->* + (-> -Flonum -NonnegativeFlonum B : (-FS (-filter -NonnegativeFlonum 0) -top)) + fl-comp)) + (define-for-syntax flmin-type + (cl->* (-> -NonnegativeFlonum -NonnegativeFlonum -NonnegativeFlonum) + (-> -Flonum -Flonum -Flonum))) + (define-for-syntax flmax-type + (cl->* (-> -NonnegativeFlonum -Flonum -NonnegativeFlonum) + (-> -Flonum -NonnegativeFlonum -NonnegativeFlonum) + (-> -Flonum -Flonum -Flonum))) ) ;; numeric predicates -[zero? (asym-pred N B (-FS (-filter (Un -Flonum -Zero) 0) +[zero? (asym-pred N B (-FS (-filter (Un -NonnegativeFlonum -Zero) 0) (-not-filter -Zero 0)))] [number? (make-pred-ty N)] [integer? (asym-pred Univ B (-FS (-filter (Un -Integer -Flonum) 0) @@ -109,9 +151,11 @@ [fixnum? (make-pred-ty -Fixnum)] [positive? (cl->* (-> -Fixnum B : (-FS (-filter -PositiveFixnum 0) -top)) (-> -Integer B : (-FS (-filter -ExactPositiveInteger 0) -top)) + (-> -Flonum B : (-FS (-filter -NonnegativeFlonum 0) -top)) (-> -Real B))] [negative? (cl->* (-> -Fixnum B : (-FS (-filter -NegativeFixnum 0) (-filter -NonnegativeFixnum 0))) (-> -Integer B : (-FS -top (-filter -Nat 0))) + (-> -Flonum B : (-FS -top (-filter -NonnegativeFlonum 0))) (-> -Real B))] [exact-positive-integer? (make-pred-ty -Pos)] [exact-nonnegative-integer? (make-pred-ty -Nat)] @@ -146,6 +190,8 @@ (-> -Fixnum -NonnegativeFixnum B : (-FS (-filter -PositiveFixnum 1) -top)) (-> -Fixnum -Nat B : (-FS (-filter -Fixnum 1) -top)) (-> -Integer -Nat B : (-FS (-filter -ExactPositiveInteger 0) -top)) + (-> -Flonum -NonnegativeFlonum B : (-FS (-filter -NonnegativeFlonum 0) -top)) + (-> -NonnegativeFlonum -Flonum B : (-FS -top (-filter -NonnegativeFlonum 1))) real-comp)] [>= (cl->* (-> -Fixnum (-val 0) B : (-FS (-filter -NonnegativeFixnum 0) (-filter -NegativeFixnum 0))) @@ -156,6 +202,8 @@ (-> -Fixnum -Nat B : (-FS (-filter -NonnegativeFixnum 1) -top)) (-> -Integer -Pos B : (-FS (-filter -Pos 0) -top)) (-> -Integer -Nat B : (-FS (-filter -Nat 0) -top)) + (-> -Flonum -NonnegativeFlonum B : (-FS (-filter -NonnegativeFlonum 0) -top)) + (-> -NonnegativeFlonum -Flonum B : (-FS -top (-filter -NonnegativeFlonum 1))) real-comp)] [< (cl->* (-> -Fixnum (-val 0) B : (-FS (-filter -NegativeFixnum 0) (-filter -NonnegativeFixnum 0))) @@ -165,6 +213,8 @@ (-> -Nat -Fixnum B : (-FS (-filter -NonnegativeFixnum 0) -top)) (-> -Nat -Integer B : (-FS (-filter -Pos 1) -top)) (-> -Integer -Nat B : (-FS -top (-filter -Nat 0))) + (-> -NonnegativeFlonum -Flonum B : (-FS (-filter -NonnegativeFlonum 1) -top)) + (-> -Flonum -NonnegativeFlonum B : (-FS -top (-filter -NonnegativeFlonum 0))) real-comp)] [<= (cl->* (-> -Fixnum (-val 0) B : (-FS -top (-filter -PositiveFixnum 0))) @@ -175,18 +225,26 @@ (-> -Nat -Fixnum B : (-FS (-filter -NonnegativeFixnum 0) -top)) (-> -Pos -Integer B : (-FS (-filter -Pos 1) -top)) (-> -Nat -Integer B : (-FS (-filter -Nat 1) -top)) + (-> -NonnegativeFlonum -Flonum B : (-FS (-filter -NonnegativeFlonum 1) -top)) + (-> -Flonum -NonnegativeFlonum B : (-FS -top (-filter -NonnegativeFlonum 0))) real-comp)] [* (apply cl->* - (append (for/list ([t (list -Pos -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) + (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) -Real -Real)) (list (->* (list) -InexactComplex -InexactComplex)) (list (->* (list) N N))))] [+ (apply cl->* (append (list (->* (list -Pos) -Nat -Pos)) (list (->* (list -Nat) -Pos -Pos)) - (for/list ([t (list -Nat -Integer -ExactRational -Flonum)]) (->* (list) t t)) + (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 -Flonum) -Real -Flonum)) @@ -225,6 +283,7 @@ (->* (list -Nat) -Integer -Nat) (->* (list -Integer) -Integer -Integer) (->* (list -ExactRational) -ExactRational -ExactRational) + (->* (list -NonnegativeFlonum) -Flonum -NonnegativeFlonum) (->* (list -Flonum) -Flonum -Flonum) (->* (list -Real) -Real -Real))] [min (cl->* (->* (list -PositiveFixnum) -PositiveFixnum -PositiveFixnum) @@ -236,6 +295,7 @@ (->* (list -Nat) -Nat -Nat) (->* (list -Integer) -Integer -Integer) (->* (list -ExactRational) -ExactRational -ExactRational) + (->* (list -NonnegativeFlonum) -NonnegativeFlonum -NonnegativeFlonum) (->* (list -Flonum) -Flonum -Flonum) (->* (list -Real) -Real -Real))] @@ -244,6 +304,7 @@ (-> -Nat -Pos) (-> -Integer -Integer) (-> -ExactRational -ExactRational) + (-> -NonnegativeFlonum -NonnegativeFlonum) (-> -Flonum -Flonum) (-> -Real -Real) (-> -InexactComplex -InexactComplex) @@ -291,8 +352,11 @@ [bitwise-bit-field (-> -Integer -Integer -Integer -Integer)] [integer-length (-> -Integer -NonnegativeFixnum)] -[abs (cl->* (-Fixnum . -> . -NonnegativeFixnum) +[abs (cl->* (-PositiveFixnum . -> . -PositiveFixnum) + (-Fixnum . -> . -NonnegativeFixnum) + (-Pos . -> . -Pos) (-Integer . -> . -Nat) + (-Flonum . -> . -NonnegativeFlonum) (-Real . -> . -Real))] ;; exactness @@ -333,13 +397,15 @@ (N N . -> . N))] [sqrt (cl->* (-Nat . -> . -Real) + (-NonnegativeFlonum . -> . -NonnegativeFlonum) (-InexactComplex . -> . -InexactComplex) (N . -> . N))] [log (cl->* (-Pos . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))] -[exp (cl->* (-Real . -> . -Real) +[exp (cl->* (-Flonum . -> . -Flonum) + (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))] [cos (cl->* (-Flonum . -> . -Flonum) (-Real . -> . -Real) (-InexactComplex . -> . -InexactComplex) (N . -> . N))] @@ -354,11 +420,12 @@ ;; scheme/math [sgn (-Real . -> . -Real)] -[pi -Flonum] +[pi -NonnegativeFlonum] [sqr (cl->* (-> -Pos -Pos) - (-> -Nat -Nat) + (-> -Nat -Nat) (-> -Integer -Integer) (-> -ExactRational -ExactRational) + (-> -NonnegativeFlonum -NonnegativeFlonum) (-> -Flonum -Flonum) (-> -Real -Real) (-> -InexactComplex -InexactComplex) @@ -373,22 +440,22 @@ (N . -> . N))] ;; unsafe numeric ops -[unsafe-flabs fl-unop] -[unsafe-fl+ fl-op] +[unsafe-flabs (-> -Flonum -NonnegativeFlonum)] +[unsafe-fl+ fl+*-type] [unsafe-fl- fl-op] -[unsafe-fl* fl-op] +[unsafe-fl* fl+*-type] [unsafe-fl/ fl-op] -[unsafe-fl= fl-comp] -[unsafe-fl<= fl-comp] -[unsafe-fl>= fl-comp] -[unsafe-fl> fl-comp] -[unsafe-fl< fl-comp] -[unsafe-flmin fl-op] -[unsafe-flmax fl-op] -[unsafe-flround fl-unop] -[unsafe-flfloor fl-unop] -[unsafe-flceiling fl-unop] -[unsafe-fltruncate fl-unop] +[unsafe-fl= fl=-type] +[unsafe-fl<= fl<-type] +[unsafe-fl>= fl>-type] +[unsafe-fl> fl>-type] +[unsafe-fl< fl<-type] +[unsafe-flmin flmin-type] +[unsafe-flmax flmax-type] +[unsafe-flround fl-rounder] +[unsafe-flfloor fl-rounder] +[unsafe-flceiling fl-rounder] +[unsafe-fltruncate fl-rounder] [unsafe-flsin fl-unop] [unsafe-flcos fl-unop] [unsafe-fltan fl-unop] @@ -396,9 +463,9 @@ [unsafe-flasin fl-unop] [unsafe-flacos fl-unop] [unsafe-fllog fl-unop] -[unsafe-flexp fl-unop] -[unsafe-flsqrt fl-unop] -[unsafe-fx->fl (-Integer . -> . -Flonum)] +[unsafe-flexp fl-rounder] +[unsafe-flsqrt fl-rounder] +[unsafe-fx->fl (cl->* (-Nat . -> . -NonnegativeFlonum) (-Integer . -> . -Flonum))] [unsafe-fx+ fx+-type] [unsafe-fx- fx-intop] @@ -450,22 +517,22 @@ ;; safe flonum ops -[flabs fl-unop] -[fl+ fl-op] +[flabs (-> -Flonum -NonnegativeFlonum)] +[fl+ fl+*-type] [fl- fl-op] -[fl* fl-op] +[fl* fl+*-type] [fl/ fl-op] -[fl= fl-comp] -[fl<= fl-comp] -[fl>= fl-comp] -[fl> fl-comp] -[fl< fl-comp] -[flmin fl-op] -[flmax fl-op] -[flround fl-unop] -[flfloor fl-unop] -[flceiling fl-unop] -[fltruncate fl-unop] +[fl= fl=-type] +[fl<= fl<-type] +[fl>= fl>-type] +[fl> fl>-type] +[fl< fl<-type] +[flmin flmin-type] +[flmax flmax-type] +[flround fl-rounder] +[flfloor fl-rounder] +[flceiling fl-rounder] +[fltruncate fl-rounder] [flsin fl-unop] [flcos fl-unop] [fltan fl-unop] diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index 9f8f775c..5b51c829 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -7,6 +7,7 @@ [Real -Real] [Exact-Rational -ExactRational] [Float -Flonum] +[Nonnegative-Float -NonnegativeFlonum] [Exact-Positive-Integer -ExactPositiveInteger] [Exact-Nonnegative-Integer -ExactNonnegativeInteger] [Positive-Fixnum -PositiveFixnum] diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 72c519a1..a3922b87 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -6,22 +6,26 @@ (types abbrev type-table utils subtype)) (provide optimize) +;; for use in match +(define (subtypeof x y) + (subtype y x)) + (define-syntax-class float-opt-expr (pattern e:opt-expr #:when (match (type-of #'e) - [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) + [(tc-result1: (== -Flonum subtypeof)) #t] [_ #f]) #:with opt #'e.opt)) (define-syntax-class int-opt-expr (pattern e:opt-expr #:when (match (type-of #'e) - [(tc-result1: (== -Integer (lambda (x y) (subtype y x)))) #t] [_ #f]) + [(tc-result1: (== -Integer subtypeof)) #t] [_ #f]) #:with opt #'e.opt)) (define-syntax-class fixnum-opt-expr (pattern e:opt-expr #:when (match (type-of #'e) - [(tc-result1: (== -Fixnum (lambda (x y) (subtype y x)))) #t] [_ #f]) + [(tc-result1: (== -Fixnum subtypeof)) #t] [_ #f]) #:with opt #'e.opt)) (define-syntax-class nonzero-fixnum-opt-expr (pattern e:opt-expr @@ -154,7 +158,7 @@ (pattern (~and res (#%plain-app (~var op (float-op binary-float-ops)) f1:float-arg-expr f2:float-arg-expr fs:float-arg-expr ...)) #:when (match (type-of #'res) ;; if the result is a float, we can coerce integers to floats and optimize - [(tc-result1: (== -Flonum type-equal?)) #t] [_ #f]) + [(tc-result1: (== -Flonum subtypeof)) #t] [_ #f]) #:with opt (begin (log-optimization "binary float" #'op) (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index e96d08ef..4e063ef2 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -37,6 +37,7 @@ any expression of this type will not evaluate to a value.} @defidform[Inexact-Complex] @defidform[Real] @defidform[Float] +@defidform[Nonnegative-Float] @defidform[Exact-Rational] @defidform[Integer] @defidform[Natural] diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 2a213987..cc65b03f 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -41,6 +41,10 @@ [(~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? + (lambda (x) (or (positive? x) (zero? x))) + (lambda (x) (not (eq? x -0.0)))))) + -NonnegativeFlonum] [(~var i (3d inexact-real?)) -Flonum] [(~var i (3d real?)) -Real] ;; a complex number can't have an inexact imaginary part and an exact real part diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index bf40ffd2..a8203f4e 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -154,6 +154,9 @@ (define -InexactComplex (make-Base 'InexactComplex #'(and/c number? (lambda (x) (inexact-real? (imag-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)))))) (define -ExactRational (make-Base 'Exact-Rational #'(and/c number? rational? exact?))) diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index 8b9047c3..6fa2969c 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -264,6 +264,10 @@ [((== -Fixnum =t) (Base: 'Exact-Rational _)) A0] [((== -Fixnum =t) (Base: 'Integer _)) A0] + [((Base: 'Nonnegative-Flonum _) (Base: 'Flonum _)) A0] + [((Base: 'Nonnegative-Flonum _) (Base: 'InexactComplex _)) A0] + [((Base: 'Nonnegative-Flonum _) (Base: 'Number _)) A0] + [((Base: 'InexactComplex _) (Base: 'Number _)) A0] From eb326dd443a08a4970f145ac79f000581db0385a Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 30 Jun 2010 14:19:53 -0400 Subject: [PATCH 150/198] Better types for modulo and remainder involving fixnums. original commit: adf5c8c030656026d70a627009a0655bd1546af7 --- collects/typed-scheme/private/base-env-numeric.rkt | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index 11e8414c..e42c0b77 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -163,8 +163,8 @@ [odd? (-> -Integer B : (-FS -top (-filter (-val 0) 0)))] [even? (-> -Integer B)] -[modulo (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . -NonnegativeFixnum) - (-Fixnum -Fixnum . -> . -Fixnum) +[modulo (cl->* (-Nat -NonnegativeFixnum . -> . -NonnegativeFixnum) + (-Integer -Fixnum . -> . -Fixnum) (-Nat -Nat . -> . -Nat) (-Integer -Integer . -> . -Integer))] @@ -322,12 +322,14 @@ (-Fixnum -Fixnum . -> . -Fixnum) (-Nat -Nat . -> . -Nat) (-Integer -Integer . -> . -Integer))] -[remainder (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . -NonnegativeFixnum) - (-Fixnum -Fixnum . -> . -Fixnum) +[remainder (cl->* (-Nat -NonnegativeFixnum . -> . -NonnegativeFixnum) + (-Integer -Fixnum . -> . -Fixnum) (-Nat -Nat . -> . -Nat) (-Integer -Integer . -> . -Integer))] [quotient/remainder (cl->* (-NonnegativeFixnum -NonnegativeFixnum . -> . (-values (list -NonnegativeFixnum -NonnegativeFixnum))) + (-Nat -NonnegativeFixnum . -> . (-values (list -Nat -NonnegativeFixnum))) (-Fixnum -Fixnum . -> . (-values (list -Fixnum -Fixnum))) + (-Integer -Fixnum . -> . (-values (list -Integer -Fixnum))) (-Nat -Nat . -> . (-values (list -Nat -Nat))) (-Integer -Integer . -> . (-values (list -Integer -Integer))))] From 2229399d2c923087fa76643bf8c7de7e25dcefda Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 30 Jun 2010 14:34:13 -0400 Subject: [PATCH 151/198] Updated build-list and build-vector's types for fixnums. original commit: 1fe70704a2cbe4462f9bd1b116db9f356d06b4ea --- collects/typed-scheme/private/base-env-indexing-abs.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index 62b7a071..37c1a694 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -20,7 +20,7 @@ (define-syntax-rule (indexing index-type) (make-env - [build-list (-poly (a) (index-type (-Nat . -> . a) . -> . (-lst a)))] + [build-list (-poly (a) (index-type (-NonnegativeFixnum . -> . a) . -> . (-lst a)))] [make-list (-poly (a) (index-type a . -> . (-lst a)))] [string-ref (-> -String index-type -Char)] @@ -132,7 +132,7 @@ [vector-ref (-poly (a) ((-vec a) index-type . -> . a))] [unsafe-vector-ref (-poly (a) ((-vec a) index-type . -> . a))] [unsafe-vector*-ref (-poly (a) ((-vec a) index-type . -> . a))] - [build-vector (-poly (a) (index-type (-Nat . -> . a) . -> . (-vec a)))] + [build-vector (-poly (a) (index-type (-NonnegativeFixnum . -> . a) . -> . (-vec a)))] [vector-set! (-poly (a) (-> (-vec a) index-type a -Void))] [unsafe-vector-set! (-poly (a) (-> (-vec a) index-type a -Void))] [unsafe-vector*-set! (-poly (a) (-> (-vec a) index-type a -Void))] From 023c51aec2801af28e442f70f9a6b690e8436b9a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Jul 2010 08:01:54 -0400 Subject: [PATCH 152/198] Support syntax errors blaming multiple syntaxes. original commit: efbdfd3e6e8e561858df08385f4da3acd37a599f --- collects/typed-scheme/utils/tc-utils.rkt | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/collects/typed-scheme/utils/tc-utils.rkt b/collects/typed-scheme/utils/tc-utils.rkt index d6a1c317..90a96e0f 100644 --- a/collects/typed-scheme/utils/tc-utils.rkt +++ b/collects/typed-scheme/utils/tc-utils.rkt @@ -109,15 +109,16 @@ don't depend on any other portion of the system ;; produce a type error, using the current syntax (define (tc-error msg . rest) - (let ([stx (locate-stx (current-orig-stx))]) + (let* ([ostx (current-orig-stx)] + [ostxs (if (list? ostx) ostx (list ostx))] + [stxs (map locate-stx ostxs)]) ;; If this isn't original syntax, then we can get some pretty bogus error messages. Note ;; that this is from a macro expansion, so that introduced vars and such don't confuse the user. (cond - [(not (orig-module-stx)) - (raise-typecheck-error (apply format msg rest) (list stx))] - [(eq? (syntax-source (current-orig-stx)) (syntax-source (orig-module-stx))) - (raise-typecheck-error (apply format msg rest) (list stx))] - [else (raise-typecheck-error (apply format (string-append "Error in macro expansion -- " msg) rest) (list stx))]))) + [(or (not (orig-module-stx)) + (for/and ([s ostxs]) (eq? (syntax-source s) (syntax-source (orig-module-stx))))) + (raise-typecheck-error (apply format msg rest) stxs)] + [else (raise-typecheck-error (apply format (string-append "Error in macro expansion -- " msg) rest) stxs)]))) ;; produce a type error, given a particular syntax (define (tc-error/stx stx msg . rest) From 63b18963f32b93cb890ef7935b2c8d6ccdb52b60 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Jul 2010 08:04:24 -0400 Subject: [PATCH 153/198] Better error message for multiple -> Closes PR 10493. original commit: 75bd26d3265d807406db3d7014e4a02ec826630c --- .../typed-scheme/fail/multi-arr-parse.rkt | 6 ++++++ collects/typed-scheme/private/parse-type.rkt | 19 ++++++++++++++----- 2 files changed, 20 insertions(+), 5 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/multi-arr-parse.rkt diff --git a/collects/tests/typed-scheme/fail/multi-arr-parse.rkt b/collects/tests/typed-scheme/fail/multi-arr-parse.rkt new file mode 100644 index 00000000..bd9cdbd9 --- /dev/null +++ b/collects/tests/typed-scheme/fail/multi-arr-parse.rkt @@ -0,0 +1,6 @@ +#; +(exn-pred 1 ".*once in a form.*") +#lang typed/scheme + +(: foo : (Integer -> Integer -> Integer)) +(define foo 1) diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index ee9cd9dd..509c6acf 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -204,6 +204,12 @@ (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) (add-type-name-reference #'kw) ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty @@ -247,11 +253,14 @@ ;; use expr to rule out keywords [(dom:expr ... kws:keyword-tys ... (~and kw t:->) rng) (add-type-name-reference #'kw) - (make-Function - (list (make-arr - (map parse-type (syntax->list #'(dom ...))) - (parse-values-type #'rng) - #:kws (attribute kws.Keyword))))] + (let ([doms (for/list ([d (syntax->list #'(dom ...))]) + (let ([dt (parse-type d)]) + (if (type-equal? dt Err) Univ dt)))]) + (make-Function + (list (make-arr + doms + (parse-values-type #'rng) + #:kws (attribute kws.Keyword)))))] [id:identifier (cond From 2a2a54c438776d59cdfa0c8d41cedf2a4a850f6c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Jul 2010 13:45:52 -0400 Subject: [PATCH 154/198] Fix error spec for this test. original commit: 4f3e3625b30adb9ec7af9d0139230d8b85150310 --- collects/tests/typed-scheme/fail/multi-arr-parse.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/fail/multi-arr-parse.rkt b/collects/tests/typed-scheme/fail/multi-arr-parse.rkt index bd9cdbd9..10e1171c 100644 --- a/collects/tests/typed-scheme/fail/multi-arr-parse.rkt +++ b/collects/tests/typed-scheme/fail/multi-arr-parse.rkt @@ -1,5 +1,5 @@ #; -(exn-pred 1 ".*once in a form.*") +(exn-pred #rx".*once in a form.*") #lang typed/scheme (: foo : (Integer -> Integer -> Integer)) From b837057b1dfb493bcd14cee5b85414e7bfca4f5a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Jul 2010 13:46:16 -0400 Subject: [PATCH 155/198] Fix error reporting regression. original commit: 829689eb9d93f19a7872a31c8d536be542ed8675 --- collects/typed-scheme/private/parse-type.rkt | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index 509c6acf..23285bcd 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -253,9 +253,8 @@ ;; use expr to rule out keywords [(dom:expr ... kws:keyword-tys ... (~and kw t:->) rng) (add-type-name-reference #'kw) - (let ([doms (for/list ([d (syntax->list #'(dom ...))]) - (let ([dt (parse-type d)]) - (if (type-equal? dt Err) Univ dt)))]) + (let ([doms (for/list ([d (syntax->list #'(dom ...))]) + (parse-type d))]) (make-Function (list (make-arr doms From 4b3b0cdf418356e697ae95528d2385b88581e90a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Jul 2010 13:47:02 -0400 Subject: [PATCH 156/198] Add --just flag for running tests. original commit: 3d347f117b9ba648536094eb9e0bf1ab1653ea76 --- collects/tests/typed-scheme/main.rkt | 45 ++++++++++++++++++++-------- collects/tests/typed-scheme/run.rkt | 13 ++++---- 2 files changed, 39 insertions(+), 19 deletions(-) diff --git a/collects/tests/typed-scheme/main.rkt b/collects/tests/typed-scheme/main.rkt index ac68c30a..418df654 100644 --- a/collects/tests/typed-scheme/main.rkt +++ b/collects/tests/typed-scheme/main.rkt @@ -23,8 +23,9 @@ [(number? e) (and (exn:fail:syntax? val) (= e (length (exn:fail:syntax-exprs val))))] - [else - (regexp-match e (exn-message val))])))) + [(or (string? e) (regexp? e)) + (regexp-match e (exn-message val))] + [else (error 'exn-pred "bad argument" e)])))) args)) (define (exn-pred p) @@ -61,9 +62,8 @@ (make-test-suite dir tests))) (define (dr p) - #;((compile-zos #f) (list p) 'auto) (parameterize ([current-namespace (make-base-empty-namespace)]) - (dynamic-require `(file ,(path->string p)) #f))) + (dynamic-require `(file ,(if (string? p) p (path->string p))) #f))) (define succ-tests (mk-tests "succeed" dr @@ -86,16 +86,35 @@ (test-suite "Typed Scheme Tests" unit-tests int-tests)) -(define (go [unit? #f] [int? #f]) (test/gui (cond [unit? unit-tests] - [int? int-tests] - [else tests]))) -(define (go/text [unit? #f] [int? #f]) (run-tests - (cond [unit? unit-tests] - [int? int-tests] - [else tests]) - 'verbose)) +(provide tests int-tests unit-tests) -(provide go go/text) +(define (go tests) (test/gui tests)) +(define (go/text tests) (run-tests tests 'verbose)) + +(define (just-one p*) + (define-values (path p b) (split-path p*)) + (define f + (if (equal? "fail/" (path->string path)) + (lambda (p thnk) + (define-values (pred info) (exn-pred p)) + (parameterize ([error-display-handler void]) + (with-check-info + (['predicates info]) + (check-exn pred thnk)))) + (lambda (p thnk) (check-not-exn thnk)))) + (test-suite + (path->string p) + (f + (build-path path p) + (lambda () + (parameterize ([read-accept-reader #t] + [current-load-relative-directory + (path->complete-path path)] + [current-directory path] + [current-output-port (open-output-nowhere)]) + (dr p)))))) + +(provide go go/text just-one) diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-scheme/run.rkt index efde19fe..b2776667 100644 --- a/collects/tests/typed-scheme/run.rkt +++ b/collects/tests/typed-scheme/run.rkt @@ -4,22 +4,23 @@ (require "main.ss") (define exec (make-parameter go/text)) -(define unit-only? (make-parameter #f)) -(define int-only? (make-parameter #f)) +(define the-tests (make-parameter tests)) (define skip-all? #f) (current-namespace (make-base-namespace)) (command-line #:once-each - ["--unit" "run just the unit tests" (unit-only? #t)] - ["--int" "run just the integration tests" (int-only? #t)] + ["--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" (when (eq? 'cgc (system-type 'gc)) (set! skip-all? #t))] + ["--just" path "run only this test" (the-tests (just-one path))] ["--gui" "run using the gui" (if (gui-available?) (begin (exec go)) - (error "GUI not available"))]) + (error "GUI not available"))] + ) (if skip-all? (printf "Skipping Typed Racket tests.\n") - (unless (= 0 ((exec) (unit-only?) (int-only?))) + (unless (= 0 ((exec) (the-tests))) (error "Typed Racket Tests did not pass."))) From 75ea7fcd2597e3af907c88ae77f617a187e9c291 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Jul 2010 16:48:06 -0400 Subject: [PATCH 157/198] add `displayln' original commit: 6f7c0112d3310a3e189874974c0a623a0c330537 --- collects/typed-scheme/private/base-env.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 56651fef..27cfc600 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -274,6 +274,7 @@ [match-equality-test (-Param (Univ Univ . -> . Univ) (Univ Univ . -> . Univ))] [matchable? (make-pred-ty (Un -String -Bytes))] [display (Univ [-Output-Port] . ->opt . -Void)] +[displayln (Univ [-Output-Port] . ->opt . -Void)] [write (Univ [-Output-Port] . ->opt . -Void)] [print (Univ [-Output-Port] . ->opt . -Void)] [void (->* '() Univ -Void)] From 09d59a56bf9b00f80180dfd4b047fdfdcea51fef Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Jul 2010 16:48:27 -0400 Subject: [PATCH 158/198] Avoid some quotes while printing types. original commit: 9a1c08e230d2a76cb052dab1ab231974ddc652ad --- collects/typed-scheme/types/printer.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 0c4ada27..2569ab18 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -142,7 +142,7 @@ [else (fp "~a" v)])] [(? tuple? t) (fp "~a" (cons 'List (tuple-elems t)))] - [(Base: n cnt) (fp "~a" n)] + [(Base: n cnt) (fp "~s" n)] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] [(Struct: (== promise-sym) #f (list (fld: t _ _)) _ _ _ _ _) (fp "(Promise ~a)" t)] [(Struct: nm par (list (fld: t _ _) ...) proc _ _ _ _) @@ -176,8 +176,8 @@ [(F: nm) (fp "~a" nm)] ;; FIXME [(Values: (list v)) (fp "~a" v)] - [(Values: (list v ...)) (fp "~a" (cons 'values v))] - [(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))] + [(Values: (list v ...)) (fp "~s" (cons 'values v))] + [(ValuesDots: v dty dbound) (fp "~s" (cons 'values (append v (list dty '... dbound))))] [(Param: in out) (if (equal? in out) (fp "(Parameterof ~a)" in) From 2fd9e3236c32c723ee974bdbccf8395b5bf9a42b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Jul 2010 16:49:02 -0400 Subject: [PATCH 159/198] Better typing for `make-sequence'. original commit: 71bb63c128f8331dc19455bb75a8918dc5055e03 --- collects/tests/typed-scheme/succeed/for-ann.rkt | 3 +++ collects/typed-scheme/typecheck/tc-app.rkt | 12 +++++++++++- 2 files changed, 14 insertions(+), 1 deletion(-) create mode 100644 collects/tests/typed-scheme/succeed/for-ann.rkt diff --git a/collects/tests/typed-scheme/succeed/for-ann.rkt b/collects/tests/typed-scheme/succeed/for-ann.rkt new file mode 100644 index 00000000..a400999a --- /dev/null +++ b/collects/tests/typed-scheme/succeed/for-ann.rkt @@ -0,0 +1,3 @@ +#lang typed/racket + +(ann (for ([#{i : Integer} '(1 2 3)]) (display i)) Void) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 2bcecb0f..ee589873 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -461,6 +461,16 @@ [(tc-result1: t) (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) + (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)))) + (list (ret Univ) (single-value #'arg)) + expected)])] ;; unsafe struct operations [(#%plain-app (~and op (~or (~literal unsafe-struct-ref) (~literal unsafe-struct*-ref))) s e:expr) (let ([e-t (single-value #'e)]) @@ -990,7 +1000,7 @@ (open-Result r o-a t-a))) (ret t-r f-r o-r)))] [((arr: _ _ _ drest '()) _) - (int-err "funapp with drest args ~a NYI" drest)] + (int-err "funapp with drest args ~a ~a NYI" drest argtys)] [((arr: _ _ _ _ kws) _) (int-err "funapp with keyword args ~a NYI" kws)])) From 4340fd29094253f272e2bf5ce2d33f407d9db256 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 1 Jul 2010 17:32:16 -0400 Subject: [PATCH 160/198] Better handling of expected types for `vector' original commit: ed88b9dd1a84908d75855e826f2b1e1d60a407a9 --- collects/typed-scheme/typecheck/tc-app.rkt | 55 +++++++++++++--------- 1 file changed, 33 insertions(+), 22 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index ee589873..9613f06c 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -18,7 +18,7 @@ (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 type-rep filter-rep object-rep rep-utils) (r:infer infer) '#%paramz (for-template @@ -593,27 +593,38 @@ (let ([arg-tys (list v-ty e-t (single-value #'val))]) (tc/funapp #'op #'(v e val) (single-value #'op) arg-tys expected))]))] [(#%plain-app (~and op (~literal vector)) args:expr ...) - (match expected - [(tc-result1: (Vector: t)) - (for ([e (in-list (syntax->list #'(args ...)))]) - (tc-expr/check e (ret t))) - expected] - [(tc-result1: (HeterogenousVector: ts)) - (unless (= (length ts) (length (syntax->list #'(args ...)))) - (tc-error/expr "expected vector with ~a elements, but got ~a" - (length ts) - (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...)))))) - (for ([e (in-list (syntax->list #'(args ...)))] - [t (in-list ts)]) - (tc-expr/check e (ret t))) - expected] - [(or #f (tc-result1: _)) - (let ([arg-tys (map single-value (syntax->list #'(args ...)))]) - (tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected)) - #;#; - (tc-error/expr "expected ~a, but got ~a" t (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...))))) - expected] - [_ (int-err "bad expected: ~a" expected)])] + (let loop ([expected expected]) + (match expected + [(tc-result1: (Vector: t)) + (for ([e (in-list (syntax->list #'(args ...)))]) + (tc-expr/check e (ret t))) + expected] + [(tc-result1: (HeterogenousVector: ts)) + (unless (= (length ts) (length (syntax->list #'(args ...)))) + (tc-error/expr "expected vector with ~a elements, but got ~a" + (length ts) + (make-HeterogenousVector (map tc-expr/t (syntax->list #'(args ...)))))) + (for ([e (in-list (syntax->list #'(args ...)))] + [t (in-list ts)]) + (tc-expr/check e (ret t))) + expected] + [(tc-result1: (? needs-resolving? e) f o) + (loop (ret (resolve-once e) f o))] + [(tc-result1: (and T (Union: (app (λ (ts) + (for/list ([t ts] + #:when (let ([k (Type-key t)]) + (eq? 'vector k))) + t)) + ts)))) + (if (null? ts) + (let ([arg-tys (map single-value (syntax->list #'(args ...)))]) + (tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected)) + (check-below (for/first ([t ts]) (loop (ret t))) + expected))] + [(or #f (tc-result1: _)) + (let ([arg-tys (map single-value (syntax->list #'(args ...)))]) + (tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected))] + [_ (int-err "bad expected: ~a" expected)]))] ;; special case for `-' used like `sub1' [(#%plain-app (~and op (~literal -)) v (~and arg2 ((~literal quote) 1))) (add-typeof-expr #'arg2 (ret -PositiveFixnum)) From 1ebe111f88c752c4520a01cf289647225b244c44 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 1 Jul 2010 13:41:11 -0400 Subject: [PATCH 161/198] Fixed the type of real->decimal-string. original commit: cdfbbc5476b6c2df62aedc8813ad13bc28cb2619 --- collects/typed-scheme/private/base-env-indexing-abs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index 37c1a694..0743861d 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -165,7 +165,7 @@ (cl->* [->opt [-Input-Port index-type] (Un -Byte (-val eof))])] ;; string.rkt - [real->decimal-string (N [index-type] . ->opt . -String)] + [real->decimal-string (-Real [index-type] . ->opt . -String)] [random (cl-> [(index-type) -Nat] [() -Real])] From fbf7cbd494d35cdbdf5ad8c96890cbd2959c2c79 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 1 Jul 2010 14:12:42 -0400 Subject: [PATCH 162/198] Fixed the behavior of the optimizer on sqrt. original commit: 351de3f767cd7b32fe75963e206c7c8da379d26b --- .../optimizer/generic/invalid-sqrt.rkt | 2 ++ .../typed-scheme/optimizer/generic/sqrt.rkt | 5 ++++ collects/typed-scheme/private/optimize.rkt | 24 +++++++++---------- 3 files changed, 18 insertions(+), 13 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/sqrt.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt new file mode 100644 index 00000000..39b0336c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-sqrt.rkt @@ -0,0 +1,2 @@ +(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/sqrt.rkt b/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt new file mode 100644 index 00000000..411ff900 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/sqrt.rkt @@ -0,0 +1,5 @@ +(module sqrt typed/scheme #:optimize + (require racket/unsafe/ops) + (: f (Nonnegative-Float -> Nonnegative-Float)) + (define (f x) + (sqrt x))) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index a3922b87..e998e9b4 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -6,26 +6,24 @@ (types abbrev type-table utils subtype)) (provide optimize) -;; for use in match -(define (subtypeof x y) - (subtype y x)) +;; is the syntax object s's type a subtype of t? +(define (subtypeof s t) + (match (type-of s) + [(tc-result1: (== t (lambda (x y) (subtype y x)))) #t] [_ #f])) (define-syntax-class float-opt-expr (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (== -Flonum subtypeof)) #t] [_ #f]) + #:when (subtypeof #'e -Flonum) #:with opt #'e.opt)) (define-syntax-class int-opt-expr (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (== -Integer subtypeof)) #t] [_ #f]) + #:when (subtypeof #'e -Integer) #:with opt #'e.opt)) (define-syntax-class fixnum-opt-expr (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (== -Fixnum subtypeof)) #t] [_ #f]) + #:when (subtypeof #'e -Fixnum) #:with opt #'e.opt)) (define-syntax-class nonzero-fixnum-opt-expr (pattern e:opt-expr @@ -151,14 +149,14 @@ #:literal-sets (kernel-literals) ;; interesting cases, where something is optimized - (pattern (#%plain-app (~var op (float-op unary-float-ops)) f:float-opt-expr) + (pattern (~and res (#%plain-app (~var op (float-op unary-float-ops)) f:float-opt-expr)) + #:when (subtypeof #'res -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 ...)) - #:when (match (type-of #'res) - ;; if the result is a float, we can coerce integers to floats and optimize - [(tc-result1: (== -Flonum subtypeof)) #t] [_ #f]) + ;; if the result is a float, we can coerce integers to floats and optimize + #:when (subtypeof #'res -Flonum) #:with opt (begin (log-optimization "binary float" #'op) (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) From 93d8f8839cd58720a2558690cb6f149017f72952 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 1 Jul 2010 15:24:52 -0400 Subject: [PATCH 163/198] Literal vectors are now given HeterogenousVector types to preserve length information. original commit: 8c25e46141da263e7f8b75813eb5b09af43e0aee --- collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt | 4 ++-- collects/typed-scheme/typecheck/tc-expr-unit.rkt | 5 ++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt index 90f1d6e9..406dc955 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.rkt @@ -154,10 +154,10 @@ [tc-e (void) -Void] [tc-e (void 3 4) -Void] [tc-e (void #t #f '(1 2 3)) -Void] - [tc-e/t #(3 4 5) (make-Vector -Nat)] + [tc-e/t #(3 4 5) (make-HeterogenousVector (list -Nat -Nat -Nat))] [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-Vector (t:Un -Nat (-val #t)))] + [tc-e/t #(2 3 #t) (make-HeterogenousVector (list -Nat -Nat (-val #t)))] [tc-e/t '(#t #f) (-lst* (-val #t) (-val #f))] [tc-e/t (plambda: (a) ([l : (Listof a)]) (car l)) (make-Poly '(a) (t:-> (make-Listof (-v a)) (-v a)))] diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index c5b18542..4e3f12e7 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -80,9 +80,8 @@ [t (in-list ts)]) (tc-literal l t)))] ;; errors are handled elsewhere - [_ (make-Vector (apply Un - (for/list ([l (syntax-e #'i)]) - (generalize (tc-literal l #f)))))])] + [_ (make-HeterogenousVector (for/list ([l (syntax-e #'i)]) + (generalize (tc-literal l #f))))])] [(~var i (3d hash?)) (let* ([h (syntax-e #'i)] [ks (hash-map h (lambda (x y) (tc-literal x)))] From e431a658e68feb13f03e9a9e730d982ef7654a33 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 1 Jul 2010 18:30:22 -0400 Subject: [PATCH 164/198] Fixed types for the unsafe versions of vector-length. original commit: 843621398b1086f492f6b9130a7a93a65c2fe4f3 --- collects/typed-scheme/private/base-env.rkt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 27cfc600..fcd52e0f 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -810,8 +810,8 @@ ;; unsafe -[unsafe-vector-length (-poly (a) ((-vec a) . -> . -NonnegativeFixnum))] -[unsafe-vector*-length (-poly (a) ((-vec a) . -> . -NonnegativeFixnum))] +[unsafe-vector-length ((make-VectorTop) . -> . -NonnegativeFixnum)] +[unsafe-vector*-length ((make-VectorTop) . -> . -NonnegativeFixnum)] [unsafe-car (-poly (a b) (cl->* (->acc (list (-pair a b)) a (list -car)) From 39d245984ae1ab453992d879ad50d5be566b1e1e Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 1 Jul 2010 18:32:21 -0400 Subject: [PATCH 165/198] Calls to vector now return heterogenous vectors, to preserve length information. original commit: f79f617ee80417059c15d9228489ec1cb716448a --- collects/typed-scheme/typecheck/tc-app.rkt | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index b328aac7..4902b6d4 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -623,11 +623,8 @@ expected))] ;; since vectors are mutable, if there is no expected type, we want to generalize the element type [(or #f (tc-result1: _)) - (let ([arg-tys (map (lambda (x) - (match (single-value x) - [(tc-result1: t) (ret (generalize t))])) - (syntax->list #'(args ...)))]) - (tc/funapp #'op #'(args ...) (single-value #'op) arg-tys expected))] + (ret (make-HeterogenousVector (map (lambda (x) (generalize (tc-expr/t x))) + (syntax->list #'(args ...)))))] [_ (int-err "bad expected: ~a" expected)]))] ;; since vectors are mutable, if there is no expected type, we want to generalize the element type [(#%plain-app (~and op (~literal make-vector)) n elt) From 228f9a971b661bc7c11b8919bfd1d0924f360011 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Jul 2010 11:47:51 -0400 Subject: [PATCH 166/198] Fixed some tests that used to test for an invalid optimization that is now valid. original commit: f6077b02f121c4300a761de4f5f2f1a18c361d7e --- .../typed-scheme/optimizer/generic/invalid-vector-ref.rkt | 4 +++- .../typed-scheme/optimizer/generic/invalid-vector-set.rkt | 4 +++- collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt | 3 +++ collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt | 3 +++ 4 files changed, 12 insertions(+), 2 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt index 0336e109..74714405 100644 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-ref.rkt @@ -1,2 +1,4 @@ (module invalid-vector-ref typed/scheme #:optimize - (vector-ref (vector 1 2 3) 0)) ; type is (Vectorof Integer), length is unknown, can't 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 index 91f333c7..b02fbdc0 100644 --- a/collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-vector-set.rkt @@ -1,2 +1,4 @@ (module invalid-vector-set typed/scheme #:optimize - (vector-set! (vector 1 2) 0 2)) ; type is (Vectorof Integer), length is ot known, can't 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/vector-ref2.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt new file mode 100644 index 00000000..434fa07c --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/vector-ref2.rkt @@ -0,0 +1,3 @@ +(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-set2.rkt b/collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt new file mode 100644 index 00000000..910575d5 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/vector-set2.rkt @@ -0,0 +1,3 @@ +(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 From f121650526ca17d59fc1e52fa2863c5b612626d2 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Jul 2010 11:51:51 -0400 Subject: [PATCH 167/198] Added support for the 2 versions of optimizer tests to be written in different languages. original commit: 1886572906c40c11eb777a3eb1e273ce3877037b --- .../optimizer/generic/different-langs.rkt | 4 ++++ collects/tests/typed-scheme/optimizer/run.rkt | 18 +++++++++++------- 2 files changed, 15 insertions(+), 7 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/different-langs.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/different-langs.rkt b/collects/tests/typed-scheme/optimizer/generic/different-langs.rkt new file mode 100644 index 00000000..9754b392 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/different-langs.rkt @@ -0,0 +1,4 @@ +;; 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)) diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt index 1ff2c4c8..8bee3094 100644 --- a/collects/tests/typed-scheme/optimizer/run.rkt +++ b/collects/tests/typed-scheme/optimizer/run.rkt @@ -5,13 +5,17 @@ ;; we compare the expansion of automatically optimized and hand optimized ;; modules (define (read-and-expand file) - (syntax->datum - (parameterize ([current-namespace (make-base-namespace)]) - (with-handlers - ([exn:fail? (lambda (exn) - (printf "~a\n" (exn-message exn)) - #'#f)]) - (expand (with-input-from-file file read-syntax)))))) + ;; 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 + (cdddr + (syntax->datum + (parameterize ([current-namespace (make-base-namespace)]) + (with-handlers + ([exn:fail? (lambda (exn) + (printf "~a\n" (exn-message exn)) + #'(#f #f #f #f))]) ; for cdddr + (expand (with-input-from-file file read-syntax))))))) (define (test gen) (let-values (((base name _) (split-path gen))) From d1687b5b2b95fe5b59483276f5e7f180e866d32d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 29 Jun 2010 15:45:47 -0400 Subject: [PATCH 168/198] Added optimization when iterating over lists. original commit: 458b6b65c9c281c0da2f2c63de068037d3d55703 --- .../optimizer/generic/in-list.rkt | 4 +++ collects/typed-scheme/private/for-clauses.rkt | 26 +++++-------------- collects/typed-scheme/private/optimize.rkt | 26 +++++++++++++++++-- collects/typed-scheme/private/prims.rkt | 10 ++----- 4 files changed, 37 insertions(+), 29 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/in-list.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/in-list.rkt b/collects/tests/typed-scheme/optimizer/generic/in-list.rkt new file mode 100644 index 00000000..6d9dde83 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/in-list.rkt @@ -0,0 +1,4 @@ +(module in-list typed/scheme #:optimize + (require racket/unsafe/ops) + (for: ((i : Natural '(1 2 3))) + (display i))) diff --git a/collects/typed-scheme/private/for-clauses.rkt b/collects/typed-scheme/private/for-clauses.rkt index 78c04cc8..3d9bea9b 100644 --- a/collects/typed-scheme/private/for-clauses.rkt +++ b/collects/typed-scheme/private/for-clauses.rkt @@ -10,21 +10,15 @@ (define-splicing-syntax-class for-clause ;; single-valued seq-expr (pattern (~and c (var:annotated-name seq-expr:expr)) - #:with (expand ...) (list (quasisyntax/loc + #:with (expand ...) (list (syntax/loc #'c - (var.ann-name - #,(syntax-property #'seq-expr - 'type-ascription - #'(Sequenceof var.ty)))))) + (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)) - #:with (expand ...) (list (quasisyntax/loc + #:with (expand ...) (list (syntax/loc #'c - ((v.ann-name ...) - #,(syntax-property #'seq-expr - 'type-ascription - #'(Sequenceof (values v.ty ...))))))) + ((v.ann-name ...) seq-expr)))) ;; when clause (pattern (~seq #:when guard:expr) #:with (expand ...) (list #'#:when #'guard))) @@ -33,22 +27,16 @@ (define-splicing-syntax-class for*-clause ;; single-valued seq-expr (pattern (~and c (var:annotated-name seq-expr:expr)) - #:with (expand ...) (list (quasisyntax/loc + #:with (expand ...) (list (syntax/loc #'c - (var.ann-name - #,(syntax-property #'seq-expr - 'type-ascription - #'(Sequenceof var.ty)))) + (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)) #:with (expand ...) (list (quasisyntax/loc #'c - ((v.ann-name ...) - #,(syntax-property #'seq-expr - 'type-ascription - #'(Sequenceof (values v.ty ...))))) + ((v.ann-name ...) seq-expr)) #'#:when #'#t)) ;; when clause (pattern (~seq #:when guard:expr) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index e998e9b4..fecbaaba 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -1,7 +1,7 @@ #lang scheme/base -(require syntax/parse (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops) - "../utils/utils.rkt" unstable/match scheme/match unstable/syntax +(require syntax/parse (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for) + "../utils/utils.rkt" "../utils/tc-utils.rkt" unstable/match scheme/match unstable/syntax (rep type-rep) syntax/id-table racket/dict (types abbrev type-table utils subtype)) (provide optimize) @@ -124,6 +124,15 @@ (pattern (~literal vector-ref) #:with unsafe #'unsafe-vector*-ref) (pattern (~literal vector-set!) #:with unsafe #'unsafe-vector*-set!)) +(define-syntax-class list-opt-expr + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (Listof: _)) #t] + [(tc-result1: (List: _)) #t] + [_ #f]) + #:with opt #'e.opt)) + + (define-syntax-class opt-expr (pattern e:opt-expr* #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f))) @@ -227,6 +236,19 @@ (begin (log-optimization "vector" #'op) #'(op.unsafe v.opt i.opt new.opt ...))) + ;; 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) + #:when (id-from? #'op 'make-sequence 'racket/private/for) + #:with l*:list-opt-expr #'l + #:with opt + (begin (log-optimization "in-list" #'op) + #'(let ((i l*.opt)) + (values unsafe-car unsafe-cdr i + (lambda (x) (not (null? x))) + (lambda (x) #t) + (lambda (x y) #t))))) + ;; boring cases, just recur down (pattern (#%plain-lambda formals e:opt-expr ...) #:with opt #'(#%plain-lambda formals e.opt ...)) diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index e213f46d..cef82b22 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -428,17 +428,11 @@ This file defines two sorts of primitives. All of them are provided into any mod ;; 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) - #:with expand #`(var.ann-name - #,(syntax-property #'seq-expr - 'type-ascription - #'(Sequenceof var.ty)))) + #: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) - #:with expand #`((v.ann-name ...) - #,(syntax-property #'seq-expr - 'type-ascription - #'(Sequenceof (values v.ty ...)))))) + #:with expand #'((v.ann-name ...) seq-expr))) (syntax-parse clauses [(head:for-clause next:for-clause ... #:when rest ...) (syntax-property From 49addde4056930c60c0b638ca55e19a9ab938715 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Jul 2010 13:15:13 -0400 Subject: [PATCH 169/198] Added support for recursive types to vector-ref and vector-set!. original commit: 40988d6d547366a520668074cc685e3f2ab22b8e --- collects/typed-scheme/typecheck/tc-app.rkt | 108 +++++++++++---------- 1 file changed, 57 insertions(+), 51 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 4902b6d4..c086e6e8 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -539,59 +539,65 @@ ;; vector-ref on het vectors [(#%plain-app (~and op (~or (~literal vector-ref) (~literal unsafe-vector-ref) (~literal unsafe-vector*-ref))) v e:expr) (let ([e-t (single-value #'e)]) - (match (single-value #'v) - [(tc-result1: (and t (HeterogenousVector: es))) - (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) - (match e-t - [(tc-result1: (Value: (? number? i))) i] - [_ #f]))]) - (cond [(not ival) - (check-below e-t -Integer) - (if expected - (check-below (ret (apply Un es)) expected) - (ret (apply Un es)))] - [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es)))) - (if expected - (check-below (ret (list-ref es ival)) expected) - (ret (list-ref es ival)))] - [(not (and (integer? ival) (exact? ival))) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)] - [(< ival 0) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)] - [(not (<= ival (sub1 (length es)))) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))] - [v-ty - (let ([arg-tys (list v-ty e-t)]) - (tc/funapp #'op #'(v e) (single-value #'op) arg-tys expected))]))] + (let loop ((v-t (single-value #'v))) + (match v-t + [(tc-result1: (and t (HeterogenousVector: es))) + (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) + (match e-t + [(tc-result1: (Value: (? number? i))) i] + [_ #f]))]) + (cond [(not ival) + (check-below e-t -Integer) + (if expected + (check-below (ret (apply Un es)) expected) + (ret (apply Un es)))] + [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es)))) + (if expected + (check-below (ret (list-ref es ival)) expected) + (ret (list-ref es ival)))] + [(not (and (integer? ival) (exact? ival))) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)] + [(< ival 0) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)] + [(not (<= ival (sub1 (length es)))) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))] + [(tc-result1: (? needs-resolving? e) f o) + (loop (ret (resolve-once e) f o))] + [v-ty + (let ([arg-tys (list v-ty e-t)]) ;; TODO problem is that 2 rec types are not equal, but why? + (tc/funapp #'op #'(v e) (single-value #'op) arg-tys expected))])))] [(#%plain-app (~and op (~or (~literal vector-set!) (~literal unsafe-vector-set!) (~literal unsafe-vector*-set!))) v e:expr val:expr) (let ([e-t (single-value #'e)]) - (match (single-value #'v) - [(tc-result1: (and t (HeterogenousVector: es))) - (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) - (match e-t - [(tc-result1: (Value: (? number? i))) i] - [_ #f]))]) - (cond [(not ival) - (tc-error/expr #:stx #'e - #:return (or expected (ret -Void)) - "expected statically known index for heterogenous vector, but got ~a" (match e-t [(tc-result1: t) t]))] - [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es)))) - (tc-expr/check #'val (ret (list-ref es ival))) - (if expected - (check-below (ret -Void) expected) - (ret -Void))] - [(not (and (integer? ival) (exact? ival))) - (single-value #'val) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)] - [(< ival 0) - (single-value #'val) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)] - [(not (<= ival (sub1 (length es)))) - (single-value #'val) - (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))] - [v-ty - (let ([arg-tys (list v-ty e-t (single-value #'val))]) - (tc/funapp #'op #'(v e val) (single-value #'op) arg-tys expected))]))] + (let loop ((v-t (single-value #'v))) + (match v-t + [(tc-result1: (and t (HeterogenousVector: es))) + (let ([ival (or (syntax-parse #'e [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) + (match e-t + [(tc-result1: (Value: (? number? i))) i] + [_ #f]))]) + (cond [(not ival) + (tc-error/expr #:stx #'e + #:return (or expected (ret -Void)) + "expected statically known index for heterogenous vector, but got ~a" (match e-t [(tc-result1: t) t]))] + [(and (integer? ival) (exact? ival) (<= 0 ival (sub1 (length es)))) + (tc-expr/check #'val (ret (list-ref es ival))) + (if expected + (check-below (ret -Void) expected) + (ret -Void))] + [(not (and (integer? ival) (exact? ival))) + (single-value #'val) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "expected exact integer for vector index, but got ~a" ival)] + [(< ival 0) + (single-value #'val) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too small for vector ~a" ival t)] + [(not (<= ival (sub1 (length es)))) + (single-value #'val) + (tc-error/expr #:stx #'e #:return (or expected (ret (Un))) "index ~a too large for vector ~a" ival t)]))] + [(tc-result1: (? needs-resolving? e) f o) + (loop (ret (resolve-once e) f o))] + [v-ty + (let ([arg-tys (list v-ty e-t (single-value #'val))]) + (tc/funapp #'op #'(v e val) (single-value #'op) arg-tys expected))])))] [(#%plain-app (~and op (~literal vector)) args:expr ...) (let loop ([expected expected]) (match expected From c6d892cd0facac015d247de26cfcc62dda3b8fd8 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Jul 2010 15:14:00 -0400 Subject: [PATCH 170/198] Fixed make-vector's type to reflect generalization on vectors. original commit: ed4f7b7bd7bc452b6accfd32ae14402fc60532c7 --- collects/typed-scheme/private/base-env-indexing-abs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index 0743861d..20945835 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -137,7 +137,7 @@ [unsafe-vector-set! (-poly (a) (-> (-vec a) index-type a -Void))] [unsafe-vector*-set! (-poly (a) (-> (-vec a) index-type a -Void))] [vector-copy! (-poly (a) ((-vec a) index-type (-vec a) [index-type index-type] . ->opt . -Void))] - [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -NonnegativeFixnum a))] + [make-vector (-poly (a) (cl-> [(index-type) (-vec (Un -Nat a))] [(index-type a) (-vec a)]))] [bytes-ref (-> -Bytes index-type -NonnegativeFixnum)] From 6aa8cbee9ddf34014705ede881ba38da14eebb47 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 2 Jul 2010 12:03:20 -0400 Subject: [PATCH 171/198] Generalize fixed-length lists to listofs. Closes PR10057. original commit: 570df7d6658d4ff0b88c12fb6d3af4917a1a3fa3 --- collects/tests/typed-scheme/succeed/pr10057.rkt | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 collects/tests/typed-scheme/succeed/pr10057.rkt diff --git a/collects/tests/typed-scheme/succeed/pr10057.rkt b/collects/tests/typed-scheme/succeed/pr10057.rkt new file mode 100644 index 00000000..a4f1829d --- /dev/null +++ b/collects/tests/typed-scheme/succeed/pr10057.rkt @@ -0,0 +1,5 @@ +#lang typed-scheme +(require scheme/match) +(ann (match '(a b c) + [(list sym more ...) 1] + [else 1]) Integer) \ No newline at end of file From c67aef8622befd981cd1b6621037fb6bc10189d6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 2 Jul 2010 15:02:48 -0400 Subject: [PATCH 172/198] Refactoring of tc-app. - Move `check-below' into its own module - Move `tc/apply' to its own unit - Move `tc/funapp' and `tc/funapp1' to own module, outside of unit original commit: 219682bbbef3f1593bde169796087b56e354a7fc --- .../typed-scheme/typecheck/check-below.rkt | 102 ++++++ .../typed-scheme/typecheck/signatures.rkt | 7 +- collects/typed-scheme/typecheck/tc-app.rkt | 344 +----------------- collects/typed-scheme/typecheck/tc-apply.rkt | 211 +++++++++++ .../typed-scheme/typecheck/tc-expr-unit.rkt | 92 +---- collects/typed-scheme/typecheck/tc-funapp.rkt | 171 +++++++++ collects/typed-scheme/typecheck/tc-if.rkt | 12 +- .../typed-scheme/typecheck/tc-lambda-unit.rkt | 2 +- .../typed-scheme/typecheck/tc-let-unit.rkt | 1 + .../typed-scheme/typecheck/typechecker.rkt | 4 +- 10 files changed, 507 insertions(+), 439 deletions(-) create mode 100644 collects/typed-scheme/typecheck/check-below.rkt create mode 100644 collects/typed-scheme/typecheck/tc-apply.rkt create mode 100644 collects/typed-scheme/typecheck/tc-funapp.rkt diff --git a/collects/typed-scheme/typecheck/check-below.rkt b/collects/typed-scheme/typecheck/check-below.rkt new file mode 100644 index 00000000..9f06b138 --- /dev/null +++ b/collects/typed-scheme/typecheck/check-below.rkt @@ -0,0 +1,102 @@ +#lang racket/base + +(require (rename-in "../utils/utils.rkt" [private private-in]) + racket/match (prefix-in - racket/contract) + (types utils convenience union subtype remove-intersect type-table filter-ops) + (private-in parse-type type-annotation) + (rep type-rep) + (only-in (infer infer) restrict) + (except-in (utils tc-utils stxclass-util)) + (env lexical-env type-env-structs tvar-env index-env) + (except-in syntax/parse id) + (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?)])]) + +(define (print-object o) + (match o + [(Empty:) "no object"] + [_ (format "object ~a" o)])) + +;; check-below : (/\ (Results Type -> Result) +;; (Results Results -> Result) +;; (Type Results -> Type) +;; (Type Type -> Type)) +(define (check-below tr1 expected) + (define (filter-better? f1 f2) + (match* (f1 f2) + [(f f) #t] + [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-)) + (and (implied-atomic? f2+ f1+) + (implied-atomic? f2- f1-))] + [(_ _) #f])) + (define (object-better? o1 o2) + (match* (o1 o2) + [(o o) #t] + [(o (or (NoObject:) (Empty:))) #t] + [(_ _) #f])) + (match* (tr1 expected) + ;; these two have to be first so that errors can be allowed in cases where multiple values are expected + [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) (tc-results: ts2 (NoFilter:) (NoObject:))) + (ret ts2)] + [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _) + expected] + + [((tc-results: ts fs os) (tc-results: ts2 (NoFilter:) (NoObject:))) + (unless (= (length ts) (length ts2)) + (tc-error/expr "Expected ~a values, but got ~a" (length ts2) (length ts))) + (unless (for/and ([t ts] [s ts2]) (subtype t s)) + (tc-error/expr "Expected ~a, but got ~a" (stringify ts2) (stringify ts))) + (if (= (length ts) (length ts2)) + (ret ts2 fs os) + (ret ts2))] + [((tc-result1: t1 f1 o1) (tc-result1: t2 (FilterSet: (Top:) (Top:)) (Empty:))) + (cond + [(not (subtype t1 t2)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)]) + expected] + [((tc-result1: t1 f1 o1) (tc-result1: t2 f2 o2)) + (cond + [(not (subtype t1 t2)) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)] + [(and (not (filter-better? f1 f2)) + (object-better? o1 o2)) + (tc-error/expr "Expected result with filter ~a, got filter ~a" f2 f1)] + [(and (filter-better? f1 f2) + (not (object-better? o1 o2))) + (tc-error/expr "Expected result with object ~a, got object ~a" o2 o1)] + [(and (not (filter-better? f1 f2)) + (not (object-better? o1 o2))) + (tc-error/expr "Expected result with filter ~a and ~a, got filter ~a and ~a" f2 (print-object o2) f1 (print-object o1))]) + expected] + [((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound)) + (unless (andmap subtype t1 t2) + (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1))) + expected] + [((tc-results: t1 fs os) (tc-results: t2 fs os)) + (unless (= (length t1) (length t2)) + (tc-error/expr "Expected ~a values, but got ~a" (length t2) (length t1))) + (unless (for/and ([t t1] [s t2]) (subtype t s)) + (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1))) + expected] + [((tc-result1: t1 f o) (? Type? t2)) + (unless (subtype t1 t2) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + (ret t2 f o)] + [((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:))) + (unless (subtype t1 t2) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + t1] + [((? Type? t1) (tc-result1: t2 f o)) + (if (subtype t1 t2) + (tc-error/expr "Expected result with filter ~a and ~a, got ~a" f (print-object o) t1) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + t1] + [((? Type? t1) (? Type? t2)) + (unless (subtype t1 t2) + (tc-error/expr "Expected ~a, but got ~a" t2 t1)) + expected] + [((tc-results: ts fs os dty dbound) (tc-results: ts* fs* os* dty* dbound*)) + (int-err "dotted types in check-below nyi: ~a ~a" dty dty*)] + [(a b) (int-err "unexpected input for check-below: ~a ~a" a b)])) diff --git a/collects/typed-scheme/typecheck/signatures.rkt b/collects/typed-scheme/typecheck/signatures.rkt index 3411232e..0e12899a 100644 --- a/collects/typed-scheme/typecheck/signatures.rkt +++ b/collects/typed-scheme/typecheck/signatures.rkt @@ -11,7 +11,6 @@ [cnt tc-literal (->* (syntax?) ((or/c #f Type/c)) Type/c)] [cnt tc-expr/check (syntax? tc-results? . -> . tc-results?)] [cnt tc-expr/check/t (syntax? tc-results? . -> . Type/c)] - [cnt check-below (->d ([s (or/c Type/c tc-results?)] [t (or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])] [cnt tc-exprs ((listof syntax?) . -> . tc-results?)] [cnt tc-exprs/check ((listof syntax?) tc-results? . -> . tc-results?)] [cnt tc-expr/t (syntax? . -> . Type/c)] @@ -32,8 +31,10 @@ (define-signature tc-app^ ([cnt tc/app (syntax? . -> . tc-results?)] - [cnt tc/app/check (syntax? tc-results? . -> . tc-results?)] - [cnt tc/funapp (syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)])) + [cnt tc/app/check (syntax? tc-results? . -> . tc-results?)])) + +(define-signature tc-apply^ + ([cnt tc/apply (syntax? syntax? . -> . tc-results?)])) (define-signature tc-let^ ([cnt tc/let-values ((syntax? syntax? syntax? syntax?) ((or/c #f tc-results?)) . ->* . tc-results?)] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index c086e6e8..5215073c 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -1,12 +1,12 @@ -#lang scheme/unit +#lang racket/unit (require (rename-in "../utils/utils.rkt" [infer r:infer]) - "signatures.rkt" "tc-metafunctions.rkt" - "tc-app-helper.rkt" "find-annotation.rkt" - "tc-subst.rkt" (prefix-in c: scheme/contract) - syntax/parse scheme/match mzlib/trace scheme/list + "signatures.rkt" "tc-metafunctions.rkt" "check-below.rkt" + "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 - ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy + ;; fixme - don't need to be bound in this phase - only to make tests work scheme/bool racket/unsafe/ops (only-in racket/private/class-internal make-object do-make-object) @@ -27,7 +27,7 @@ "internal-forms.rkt" scheme/base scheme/bool '#%paramz (only-in racket/private/class-internal make-object do-make-object))) -(import tc-expr^ tc-lambda^ tc-let^) +(import tc-expr^ tc-lambda^ tc-let^ tc-apply^) (export tc-app^) @@ -249,193 +249,6 @@ (tc/rec-lambda/check form args body lp ts expected) expected)])) -(define (tc/apply f args) - (define (do-ret t) - (match t - [(Values: (list (Result: ts _ _) ...)) (ret ts)] - [(ValuesDots: (list (Result: ts _ _) ...) dty dbound) (ret ts (for/list ([t ts]) (-FS null null)) (for/list ([t ts]) (make-Empty)) dty dbound)] - [_ (int-err "do-ret fails: ~a" t)])) - (define f-ty (single-value f)) - ;; produces the first n-1 elements of the list, and the last element - (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))]) - (values f (car r)))) - (define-values (fixed-args tail) - (let ([args* (syntax->list args)]) - (if (null? args*) - (tc-error "apply requires a final list argument, given only a function argument of type ~a" (match f-ty [(tc-result1: t) t])) - (split args*)))) - - (match f-ty - ;; apply of simple function - [(tc-result1: (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)]) - (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)))] - ;; 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 - (subtype (apply -lst* arg-tys #:tail tail-ty) - (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))) - (do-ret (car rngs*))] - ;; the function expects a dotted rest arg, so make sure we have a ListDots - [(and (car drests*) - (match tail-ty - [(ListDots: tail-ty tail-bound) - ;; the check that it's the same bound - (and (eq? (cdr (car drests*)) tail-bound) - ;; and that the types are correct - (subtypes arg-tys (car doms*)) - (subtype tail-ty (car (car drests*))))] - [_ #f])) - (do-ret (car rngs*))] - ;; otherwise, nothing worked, move on to the next case - [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)] - [(tail-ty tail-bound) (match (tc-expr/t tail) - [(ListDots: tail-ty tail-bound) - (values tail-ty tail-bound)] - [t (values t #f)])]) - (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)))])] - ;; the actual work, when we have a * function and a list final argument - [(and (car rests*) - (not tail-bound) - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars null - (cons tail-ty arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*))) - => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] - ;; actual work, when we have a * function and ... final arg - [(and (car rests*) - tail-bound - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg vars null - (cons (make-Listof tail-ty) arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*))) - => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] - ;; ... function, ... arg - [(and (car drests*) - tail-bound - (eq? tail-bound (cdr (car drests*))) - (= (length (car doms*)) - (length arg-tys)) - (infer vars null (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) - (car rngs*))) - => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] - ;; if nothing matches, around the loop again - [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result1: (Poly: vars (Function: '()))) - (tc-error/expr #:return (ret (Un)) - "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)] - [(tail-ty tail-bound) (match (tc-expr/t tail) - [(ListDots: tail-ty tail-bound) - (values tail-ty tail-bound)] - [t (values t #f)])]) - (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) - (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)))])] - ;; the actual work, when we have a * function and a list final argument - [(and (car rests*) - (not tail-bound) - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg fixed-vars (list dotted-var) - (cons tail-ty arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*))) - => finish] - ;; actual work, when we have a * function and ... final arg - [(and (car rests*) - tail-bound - (<= (length (car doms*)) - (length arg-tys)) - (infer/vararg fixed-vars (list dotted-var) - (cons (make-Listof tail-ty) arg-tys) - (cons (make-Listof (car rests*)) - (car doms*)) - (car rests*) - (car rngs*))) - => finish] - ;; ... function, ... arg, same bound on ... - [(and (car drests*) - tail-bound - (eq? tail-bound (cdr (car drests*))) - (= (length (car doms*)) - (length arg-tys)) - (infer fixed-vars (list dotted-var) - (cons (make-ListDots tail-ty tail-bound) arg-tys) - (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*)) - (car rngs*))) - => finish] - ;; ... function, ... arg, different bound on ... - [(and (car drests*) - tail-bound - (not (eq? tail-bound (cdr (car drests*)))) - (= (length (car doms*)) - (length arg-tys)) - (extend-tvars (list tail-bound (cdr (car drests*))) - (extend-indexes (cdr (car drests*)) - ;; don't need to add tail-bound - it must already be an index - (infer fixed-vars (list dotted-var) - (cons (make-ListDots tail-ty tail-bound) arg-tys) - (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*)) - (car rngs*))))) - => finish] - ;; ... function, (List A B C etc) arg - [(and (car drests*) - (not tail-bound) - (eq? (cdr (car drests*)) dotted-var) - (= (length (car doms*)) - (length arg-tys)) - (untuple tail-ty) - (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) - (car (car drests*)) (car rngs*) (fv (car rngs*)))) - => finish] - ;; if nothing matches, around the loop again - [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result1: (PolyDots: vars (Function: '()))) - (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)])) ;; the main dispatching function ;; syntax tc-results? -> tc-results? @@ -908,147 +721,4 @@ (in-range (length dom))) -(define-syntax (handle-clauses stx) - (syntax-parse stx - [(_ (lsts ... arrs) f-stx args-stx pred infer t argtys expected) - (with-syntax ([(vars ... a) (generate-temporaries #'(lsts ... arrs))]) - (syntax/loc stx - (or (for/or ([vars lsts] ... [a arrs] - #:when (pred vars ... a)) - (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))))])) - -(define (tc/funapp f-stx args-stx ftype0 argtys expected) - ;(syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results?) . -> . 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: (list (Result: t-r lf-r lo-r) ...)) rest #f kws)))))) - argtys) - (tc/funapp1 f-stx args-stx a argtys expected)] - [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests (and drests #f) kws) ...))))) - (and argtys (list (tc-result1: argtys-t) ...))) - (or - ;; find the first function where the argument types match - (for/first ([dom doms] [rng rngs] [rest rests] [a arrs] - #:when (subtypes/varargs argtys-t dom rest)) - ;; then typecheck here - ;; 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))))] - ;; any kind of dotted polymorphic function without mandatory keyword args - [((tc-result1: (and t (PolyDots: - (and vars (list fixed-vars ... dotted-var)) - (Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...))))) - (list (tc-result1: argtys-t) ...)) - (handle-clauses (doms rngs rests drests arrs) f-stx args-stx - ;; only try inference if the argument lengths are appropriate - (lambda (dom _ rest drest a) - (cond [rest (<= (length dom) (length argtys))] - [drest (and (<= (length dom) (length argtys)) - (eq? dotted-var (cdr drest)))] - [else (= (length dom) (length argtys))])) - ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) - ;; note that we have to use argtys-t here, since argtys is a list of tc-results - (lambda (dom rng rest drest a) - (cond - [drest - (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) - #:expected (and expected (tc-results->values expected)))] - [rest - (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng - (and expected (tc-results->values expected)))] - ;; no rest or drest - [else (infer fixed-vars (list dotted-var) argtys-t dom rng - (and expected (tc-results->values expected)))])) - t argtys expected)] - ;; regular polymorphic functions without dotted rest, and without mandatory keyword args - [((tc-result1: - (and t - (Poly: - vars - (Function: (list (and arrs (arr: doms rngs rests (and drests #f) (list (Keyword: _ _ #f) ...))) ...))))) - (list (tc-result1: argtys-t) ...)) - (handle-clauses (doms rngs rests arrs) f-stx args-stx - ;; only try inference if the argument lengths are appropriate - (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) - ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) - ;; note that we have to use argtys-t here, since argtys is a list of tc-results - (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) - t argtys expected)] - ;; procedural structs - [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _) - (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)] - ;; parameters are functions too - [((tc-result1: (Param: in out)) (list)) (ret out)] - [((tc-result1: (Param: in out)) (list (tc-result1: t))) - (if (subtype t in) - (ret -Void true-filter) - (tc-error/expr #:return (ret -Void true-filter) - "Wrong argument to parameter - expected ~a and got ~a" in t))] - [((tc-result1: (Param: _ _)) _) - (tc-error/expr #:return (ret (Un)) - "Wrong number of arguments to parameter - expected 0 or 1, got ~a" - (length argtys))] - ;; resolve names, polymorphic apps, mu, etc - [((tc-result1: (? needs-resolving? t) f o) _) - (tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)] - ;; a union of functions can be applied if we can apply all of the elements - [((tc-result1: (Union: (and ts (list (Function: _) ...)))) _) - (ret (for/fold ([result (Un)]) ([fty ts]) - (match (tc/funapp f-stx args-stx (ret fty) argtys expected) - [(tc-result1: t) (Un result t)])))] - ;; error type is a perfectly good fcn type - [((tc-result1: (Error:)) _) (ret (make-Error))] - ;; otherwise fail - [((tc-result1: f-ty) _) - ;(printf "ft: ~a argt: ~a~n" ftype0 argtys) - (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?) - ;(printf "got to here 0~a~n" args-stx) - (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) ...)) - ;(printf "got to here 1~a~n" args-stx) - (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)))) - ;(printf "got to here 2 ~a ~a ~a ~n" dom names o-a) - (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-apply.rkt b/collects/typed-scheme/typecheck/tc-apply.rkt new file mode 100644 index 00000000..a28ef371 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-apply.rkt @@ -0,0 +1,211 @@ +#lang racket/unit + +(require (rename-in "../utils/utils.rkt" [infer r:infer]) + "signatures.rkt" "tc-app-helper.rkt" + racket/match racket/list + (for-syntax (utils tc-utils)) + (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) + (r:infer infer) + '#%paramz + (for-template + racket/unsafe/ops + (only-in '#%kernel [apply k:apply]) + "internal-forms.rkt" racket/base racket/bool '#%paramz + (only-in racket/private/class-internal make-object do-make-object))) + +(import tc-expr^ tc-lambda^ tc-let^ tc-app^) +(export tc-apply^) + +(define (do-ret t) + (match t + [(Values: (list (Result: ts _ _) ...)) (ret ts)] + [(ValuesDots: (list (Result: ts _ _) ...) dty dbound) (ret ts (for/list ([t ts]) (-FS null null)) (for/list ([t ts]) (make-Empty)) dty dbound)] + [_ (int-err "do-ret fails: ~a" t)])) + +(define (tc/apply f args) + (define f-ty (single-value f)) + ;; produces the first n-1 elements of the list, and the last element + (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))]) + (values f (car r)))) + (define-values (fixed-args tail) + (let ([args* (syntax->list args)]) + (if (null? args*) + (tc-error "apply requires a final list argument, given only a function argument of type ~a" (match f-ty [(tc-result1: t) t])) + (split args*)))) + + (match f-ty + ;; apply of simple function + [(tc-result1: (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)]) + (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)))] + ;; 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 + (subtype (apply -lst* arg-tys #:tail tail-ty) + (apply -lst* (car doms*) #:tail (make-Listof (car rests*))))) + (do-ret (car rngs*))] + ;; the function expects a dotted rest arg, so make sure we have a ListDots + [(and (car drests*) + (match tail-ty + [(ListDots: tail-ty tail-bound) + ;; the check that it's the same bound + (and (eq? (cdr (car drests*)) tail-bound) + ;; and that the types are correct + (subtypes arg-tys (car doms*)) + (subtype tail-ty (car (car drests*))))] + [_ #f])) + (do-ret (car rngs*))] + ;; otherwise, nothing worked, move on to the next case + [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)] + [(tail-ty tail-bound) (match (tc-expr/t tail) + [(ListDots: tail-ty tail-bound) + (values tail-ty tail-bound)] + [t (values t #f)])]) + (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)))])] + ;; the actual work, when we have a * function and a list final argument + [(and (car rests*) + (not tail-bound) + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars null + (cons tail-ty arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*))) + => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] + ;; actual work, when we have a * function and ... final arg + [(and (car rests*) + tail-bound + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg vars null + (cons (make-Listof tail-ty) arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*))) + => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] + ;; ... function, ... arg + [(and (car drests*) + tail-bound + (eq? tail-bound (cdr (car drests*))) + (= (length (car doms*)) + (length arg-tys)) + (infer vars null (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) + (car rngs*))) + => (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))] + ;; if nothing matches, around the loop again + [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] + [(tc-result1: (Poly: vars (Function: '()))) + (tc-error/expr #:return (ret (Un)) + "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)] + [(tail-ty tail-bound) (match (tc-expr/t tail) + [(ListDots: tail-ty tail-bound) + (values tail-ty tail-bound)] + [t (values t #f)])]) + (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) + (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)))])] + ;; the actual work, when we have a * function and a list final argument + [(and (car rests*) + (not tail-bound) + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg fixed-vars (list dotted-var) + (cons tail-ty arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*))) + => finish] + ;; actual work, when we have a * function and ... final arg + [(and (car rests*) + tail-bound + (<= (length (car doms*)) + (length arg-tys)) + (infer/vararg fixed-vars (list dotted-var) + (cons (make-Listof tail-ty) arg-tys) + (cons (make-Listof (car rests*)) + (car doms*)) + (car rests*) + (car rngs*))) + => finish] + ;; ... function, ... arg, same bound on ... + [(and (car drests*) + tail-bound + (eq? tail-bound (cdr (car drests*))) + (= (length (car doms*)) + (length arg-tys)) + (infer fixed-vars (list dotted-var) + (cons (make-ListDots tail-ty tail-bound) arg-tys) + (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*)) + (car rngs*))) + => finish] + ;; ... function, ... arg, different bound on ... + [(and (car drests*) + tail-bound + (not (eq? tail-bound (cdr (car drests*)))) + (= (length (car doms*)) + (length arg-tys)) + (extend-tvars (list tail-bound (cdr (car drests*))) + (extend-indexes (cdr (car drests*)) + ;; don't need to add tail-bound - it must already be an index + (infer fixed-vars (list dotted-var) + (cons (make-ListDots tail-ty tail-bound) arg-tys) + (cons (make-ListDots (car (car drests*)) (cdr (car drests*))) (car doms*)) + (car rngs*))))) + => finish] + ;; ... function, (List A B C etc) arg + [(and (car drests*) + (not tail-bound) + (eq? (cdr (car drests*)) dotted-var) + (= (length (car doms*)) + (length arg-tys)) + (untuple tail-ty) + (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) + (car (car drests*)) (car rngs*) (fv (car rngs*)))) + => finish] + ;; if nothing matches, around the loop again + [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] + [(tc-result1: (PolyDots: vars (Function: '()))) + (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)])) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 4e3f12e7..0889fdea 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -1,10 +1,11 @@ #lang scheme/unit -(require (rename-in "../utils/utils.rkt" [private private-in])) -(require syntax/kerncase mzlib/trace +(require (rename-in "../utils/utils.rkt" [private private-in]) + syntax/kerncase mzlib/trace scheme/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) (private-in parse-type type-annotation) (rep type-rep) @@ -165,93 +166,6 @@ (match (tc-expr/check e t) [(tc-result1: t) t])) -(define (print-object o) - (match o - [(Empty:) "no object"] - [_ (format "object ~a" o)])) - -;; check-below : (/\ (Results Type -> Result) -;; (Results Results -> Result) -;; (Type Results -> Type) -;; (Type Type -> Type)) -(define (check-below tr1 expected) - (define (filter-better? f1 f2) - (match* (f1 f2) - [(f f) #t] - [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-)) - (and (implied-atomic? f2+ f1+) - (implied-atomic? f2- f1-))] - [(_ _) #f])) - (define (object-better? o1 o2) - (match* (o1 o2) - [(o o) #t] - [(o (or (NoObject:) (Empty:))) #t] - [(_ _) #f])) - (match* (tr1 expected) - ;; these two have to be first so that errors can be allowed in cases where multiple values are expected - [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) (tc-results: ts2 (NoFilter:) (NoObject:))) - (ret ts2)] - [((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _) - expected] - - [((tc-results: ts fs os) (tc-results: ts2 (NoFilter:) (NoObject:))) - (unless (= (length ts) (length ts2)) - (tc-error/expr "Expected ~a values, but got ~a" (length ts2) (length ts))) - (unless (for/and ([t ts] [s ts2]) (subtype t s)) - (tc-error/expr "Expected ~a, but got ~a" (stringify ts2) (stringify ts))) - (if (= (length ts) (length ts2)) - (ret ts2 fs os) - (ret ts2))] - [((tc-result1: t1 f1 o1) (tc-result1: t2 (FilterSet: (Top:) (Top:)) (Empty:))) - (cond - [(not (subtype t1 t2)) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)]) - expected] - [((tc-result1: t1 f1 o1) (tc-result1: t2 f2 o2)) - (cond - [(not (subtype t1 t2)) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)] - [(and (not (filter-better? f1 f2)) - (object-better? o1 o2)) - (tc-error/expr "Expected result with filter ~a, got filter ~a" f2 f1)] - [(and (filter-better? f1 f2) - (not (object-better? o1 o2))) - (tc-error/expr "Expected result with object ~a, got object ~a" o2 o1)] - [(and (not (filter-better? f1 f2)) - (not (object-better? o1 o2))) - (tc-error/expr "Expected result with filter ~a and ~a, got filter ~a and ~a" f2 (print-object o2) f1 (print-object o1))]) - expected] - [((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound)) - (unless (andmap subtype t1 t2) - (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1))) - expected] - [((tc-results: t1 fs os) (tc-results: t2 fs os)) - (unless (= (length t1) (length t2)) - (tc-error/expr "Expected ~a values, but got ~a" (length t2) (length t1))) - (unless (for/and ([t t1] [s t2]) (subtype t s)) - (tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1))) - expected] - [((tc-result1: t1 f o) (? Type? t2)) - (unless (subtype t1 t2) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)) - (ret t2 f o)] - [((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:))) - (unless (subtype t1 t2) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)) - t1] - [((? Type? t1) (tc-result1: t2 f o)) - (if (subtype t1 t2) - (tc-error/expr "Expected result with filter ~a and ~a, got ~a" f (print-object o) t1) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)) - t1] - [((? Type? t1) (? Type? t2)) - (unless (subtype t1 t2) - (tc-error/expr "Expected ~a, but got ~a" t2 t1)) - expected] - [((tc-results: ts fs os dty dbound) (tc-results: ts* fs* os* dty* dbound*)) - (int-err "dotted types in check-below nyi: ~a ~a" dty dty*)] - [(a b) (int-err "unexpected input for check-below: ~a ~a" a b)])) - (define (tc-expr/check/type form expected) #;(syntax? Type/c . -> . tc-results?) (tc-expr/check form (ret expected))) diff --git a/collects/typed-scheme/typecheck/tc-funapp.rkt b/collects/typed-scheme/typecheck/tc-funapp.rkt new file mode 100644 index 00000000..56365a4a --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-funapp.rkt @@ -0,0 +1,171 @@ +#lang racket/base + +(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: scheme/contract) + syntax/parse scheme/match mzlib/trace scheme/list + unstable/sequence unstable/debug + ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy + scheme/bool + racket/unsafe/ops + (only-in racket/private/class-internal make-object do-make-object) + (only-in '#%kernel [apply k:apply]) + ;; end fixme + (for-syntax syntax/parse scheme/base (utils tc-utils)) + (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) + (r:infer infer) + '#%paramz + (for-template + racket/unsafe/ops + (only-in '#%kernel [apply k:apply]) + "internal-forms.rkt" scheme/base scheme/bool '#%paramz + (only-in racket/private/class-internal make-object do-make-object))) + +(provide tc/funapp) + +(define-syntax (handle-clauses stx) + (syntax-parse stx + [(_ (lsts ... arrs) f-stx args-stx pred infer t argtys expected) + (with-syntax ([(vars ... a) (generate-temporaries #'(lsts ... arrs))]) + (syntax/loc stx + (or (for/or ([vars lsts] ... [a arrs] + #:when (pred vars ... a)) + (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))))])) + +(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?) + (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) + (tc/funapp1 f-stx args-stx a argtys expected)] + [((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests (and drests #f) kws) ...))))) + (and argtys (list (tc-result1: argtys-t) ...))) + (or + ;; find the first function where the argument types match + (for/first ([dom doms] [rng rngs] [rest rests] [a arrs] + #:when (subtypes/varargs argtys-t dom rest)) + ;; then typecheck here + ;; 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))))] + ;; any kind of dotted polymorphic function without mandatory keyword args + [((tc-result1: (and t (PolyDots: + (and vars (list fixed-vars ... dotted-var)) + (Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...))))) + (list (tc-result1: argtys-t) ...)) + (handle-clauses (doms rngs rests drests arrs) f-stx args-stx + ;; only try inference if the argument lengths are appropriate + (lambda (dom _ rest drest a) + (cond [rest (<= (length dom) (length argtys))] + [drest (and (<= (length dom) (length argtys)) + (eq? dotted-var (cdr drest)))] + [else (= (length dom) (length argtys))])) + ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) + ;; note that we have to use argtys-t here, since argtys is a list of tc-results + (lambda (dom rng rest drest a) + (cond + [drest + (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) + #:expected (and expected (tc-results->values expected)))] + [rest + (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng + (and expected (tc-results->values expected)))] + ;; no rest or drest + [else (infer fixed-vars (list dotted-var) argtys-t dom rng + (and expected (tc-results->values expected)))])) + t argtys expected)] + ;; regular polymorphic functions without dotted rest, and without mandatory keyword args + [((tc-result1: + (and t + (Poly: + vars + (Function: (list (and arrs (arr: doms rngs rests (and drests #f) (list (Keyword: _ _ #f) ...))) ...))))) + (list (tc-result1: argtys-t) ...)) + (handle-clauses (doms rngs rests arrs) f-stx args-stx + ;; only try inference if the argument lengths are appropriate + (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) + ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) + ;; note that we have to use argtys-t here, since argtys is a list of tc-results + (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) + t argtys expected)] + ;; procedural structs + [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _) + (tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)] + ;; parameters are functions too + [((tc-result1: (Param: in out)) (list)) (ret out)] + [((tc-result1: (Param: in out)) (list (tc-result1: t))) + (if (subtype t in) + (ret -Void true-filter) + (tc-error/expr #:return (ret -Void true-filter) + "Wrong argument to parameter - expected ~a and got ~a" in t))] + [((tc-result1: (Param: _ _)) _) + (tc-error/expr #:return (ret (Un)) + "Wrong number of arguments to parameter - expected 0 or 1, got ~a" + (length argtys))] + ;; resolve names, polymorphic apps, mu, etc + [((tc-result1: (? needs-resolving? t) f o) _) + (tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)] + ;; a union of functions can be applied if we can apply all of the elements + [((tc-result1: (Union: (and ts (list (Function: _) ...)))) _) + (ret (for/fold ([result (Un)]) ([fty ts]) + (match (tc/funapp f-stx args-stx (ret fty) argtys expected) + [(tc-result1: t) (Un result t)])))] + ;; error type is a perfectly good fcn type + [((tc-result1: (Error:)) _) (ret (make-Error))] + ;; otherwise fail + [((tc-result1: f-ty) _) + ;(printf "ft: ~a argt: ~a~n" ftype0 argtys) + (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 288d9de5..c415ef8b 100644 --- a/collects/typed-scheme/typecheck/tc-if.rkt +++ b/collects/typed-scheme/typecheck/tc-if.rkt @@ -1,8 +1,6 @@ -#lang scheme/unit - - -(require (rename-in "../utils/utils.rkt" [infer r:infer])) -(require "signatures.rkt" +#lang racket/unit +(require (rename-in "../utils/utils.rkt" [infer r:infer]) + "signatures.rkt" "check-below.rkt" (rep type-rep filter-rep object-rep) (rename-in (types convenience subtype union utils comparison remove-intersect abbrev filter-ops) [remove *remove]) @@ -11,8 +9,8 @@ (utils tc-utils) (typecheck tc-envops tc-metafunctions) syntax/kerncase - mzlib/trace unstable/debug - scheme/match) + racket/trace unstable/debug + racket/match) ;; if typechecking (import tc-expr^) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt index 66494e60..b213cce5 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.rkt @@ -3,7 +3,7 @@ (require (rename-in "../utils/utils.rkt" [infer r:infer]) "signatures.rkt" "tc-metafunctions.rkt" - "tc-subst.rkt" + "tc-subst.rkt" "check-below.rkt" mzlib/trace scheme/list syntax/private/util syntax/stx diff --git a/collects/typed-scheme/typecheck/tc-let-unit.rkt b/collects/typed-scheme/typecheck/tc-let-unit.rkt index 012ef3ee..cbd401cc 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-let-unit.rkt @@ -2,6 +2,7 @@ (require (rename-in "../utils/utils.rkt" [infer r:infer])) (require "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) diff --git a/collects/typed-scheme/typecheck/typechecker.rkt b/collects/typed-scheme/typecheck/typechecker.rkt index 90c46d4e..9a2d2962 100644 --- a/collects/typed-scheme/typecheck/typechecker.rkt +++ b/collects/typed-scheme/typecheck/typechecker.rkt @@ -8,10 +8,10 @@ define-values/invoke-unit/infer link) "signatures.rkt" "tc-if.rkt" "tc-lambda-unit.rkt" "tc-app.rkt" - "tc-let-unit.rkt" + "tc-let-unit.rkt" "tc-apply.rkt" "tc-expr-unit.rkt" "check-subforms-unit.rkt") (provide-signature-elements tc-expr^ check-subforms^) (define-values/invoke-unit/infer - (link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@)) + (link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@ tc-apply@)) From b4e86dc50281fd9119c65c0935fbfe05f8e179bc Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 2 Jul 2010 15:04:43 -0400 Subject: [PATCH 173/198] Use `define-type' to make docs clearer. original commit: da3b4ed543ec9ca9aa3b114f4da44d12af4a60e7 --- collects/typed-scheme/scribblings/types.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/scribblings/types.scrbl b/collects/typed-scheme/scribblings/types.scrbl index fdbf1dca..1d020b11 100644 --- a/collects/typed-scheme/scribblings/types.scrbl +++ b/collects/typed-scheme/scribblings/types.scrbl @@ -94,7 +94,7 @@ to describe an infinite family of data. For example, this is the type of binary trees of numbers. @racketblock[ -(Rec BT (U Number (Pair BT BT)))] +(define-type BinaryTree (Rec BT (U Number (Pair BT BT))))] The @racket[Rec] type constructor specifies that the type @racket[BT] refers to the whole binary tree type within the body of the From b415e84cd6a53fd618b3493df3cef41e72ecca0b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 2 Jul 2010 17:24:38 -0400 Subject: [PATCH 174/198] Fix inference for heterogenous vectors. original commit: 0e400291e78c46cf1f4ded2c668e2b989814fc5e --- .../typed-scheme/succeed/rec-het-vec-infer.rkt | 9 +++++++++ collects/typed-scheme/infer/infer-unit.rkt | 2 ++ collects/typed-scheme/typecheck/tc-funapp.rkt | 15 +++++++-------- 3 files changed, 18 insertions(+), 8 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt diff --git a/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt b/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt new file mode 100644 index 00000000..72c33824 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/rec-het-vec-infer.rkt @@ -0,0 +1,9 @@ +#lang typed/racket + +(define-type (Set X) (Rec Set (U Null (Vector X Set)))) + +(: get-set-root (All (X) ((Set X) -> X))) +(define (get-set-root s) (error 'fail)) + +(: set-size (All (X) ((Set X) -> X))) +(define (set-size x) (get-set-root x)) \ No newline at end of file diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index c4a0064a..33e2f23c 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -361,6 +361,8 @@ [((List: ts) (Sequence: (list t*))) (cset-meet* (for/list ([t (in-list ts)]) (cg t t*)))] + [((HeterogenousVector: ts) (HeterogenousVector: ts*)) + (cset-meet (cgen/list V X Y ts ts*) (cgen/list V X Y ts* ts))] [((HeterogenousVector: ts) (Sequence: (list t*))) (cset-meet* (for/list ([t (in-list ts)]) (cg t t*)))] diff --git a/collects/typed-scheme/typecheck/tc-funapp.rkt b/collects/typed-scheme/typecheck/tc-funapp.rkt index 56365a4a..63f12298 100644 --- a/collects/typed-scheme/typecheck/tc-funapp.rkt +++ b/collects/typed-scheme/typecheck/tc-funapp.rkt @@ -4,16 +4,16 @@ "signatures.rkt" "tc-metafunctions.rkt" "tc-app-helper.rkt" "find-annotation.rkt" "tc-subst.rkt" "check-below.rkt" - (prefix-in c: scheme/contract) - syntax/parse scheme/match mzlib/trace scheme/list + (prefix-in c: racket/contract) + syntax/parse racket/match racket/list unstable/sequence unstable/debug ;; fixme - don't need to be bound in this phase - only to make syntax/parse happy - scheme/bool + racket/bool racket/unsafe/ops (only-in racket/private/class-internal make-object do-make-object) (only-in '#%kernel [apply k:apply]) ;; end fixme - (for-syntax syntax/parse scheme/base (utils tc-utils)) + (for-syntax syntax/parse racket/base (utils tc-utils)) (private type-annotation) (types utils abbrev union subtype resolve convenience type-table substitute) (utils tc-utils) @@ -25,7 +25,7 @@ (for-template racket/unsafe/ops (only-in '#%kernel [apply k:apply]) - "internal-forms.rkt" scheme/base scheme/bool '#%paramz + "internal-forms.rkt" racket/base racket/bool '#%paramz (only-in racket/private/class-internal make-object do-make-object))) (provide tc/funapp) @@ -97,10 +97,10 @@ (list (tc-result1: argtys-t) ...)) (handle-clauses (doms rngs rests arrs) f-stx args-stx ;; only try inference if the argument lengths are appropriate - (lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) + (λ (dom _ rest a) ((if rest <= =) (length dom) (length argtys))) ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) ;; note that we have to use argtys-t here, since argtys is a list of tc-results - (lambda (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) + (λ (dom rng rest a) (infer/vararg vars null argtys-t dom rest rng (and expected (tc-results->values expected)))) t argtys expected)] ;; procedural structs [((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _ _))) _) @@ -128,7 +128,6 @@ [((tc-result1: (Error:)) _) (ret (make-Error))] ;; otherwise fail [((tc-result1: f-ty) _) - ;(printf "ft: ~a argt: ~a~n" ftype0 argtys) (tc-error/expr #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" f-ty)])) From 474741601bc15fc268af82d8eacdb4a68e63b7ed Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 2 Jul 2010 18:53:25 -0400 Subject: [PATCH 175/198] Add flags for running the optimizer tests and compiling the benchmarks original commit: e989631d56a70b90077cbdca7993a25dc70c2011 --- collects/tests/typed-scheme/main.rkt | 28 +++++++++++++++++-- collects/tests/typed-scheme/optimizer/run.rkt | 2 +- collects/tests/typed-scheme/run.rkt | 23 +++++++++++---- 3 files changed, 43 insertions(+), 10 deletions(-) diff --git a/collects/tests/typed-scheme/main.rkt b/collects/tests/typed-scheme/main.rkt index 418df654..9fb96757 100644 --- a/collects/tests/typed-scheme/main.rkt +++ b/collects/tests/typed-scheme/main.rkt @@ -5,12 +5,12 @@ (require rackunit rackunit/text-ui mzlib/etc scheme/port compiler/compiler - scheme/match + scheme/match mzlib/compile "unit-tests/all-tests.ss" "unit-tests/test-utils.ss") (define (scheme-file? s) - (regexp-match ".*[.](rkt|ss|scm)" (path->string s))) + (regexp-match ".*[.](rkt|ss|scm)$" (path->string s))) (define-namespace-anchor a) @@ -27,6 +27,9 @@ (regexp-match e (exn-message val))] [else (error 'exn-pred "bad argument" e)])))) args)) + +(define (cfile file) + ((compile-zos #f) (list file) 'auto)) (define (exn-pred p) (let ([sexp (with-handlers @@ -114,7 +117,26 @@ [current-output-port (open-output-nowhere)]) (dr p)))))) -(provide go go/text just-one) +(define (compile-benchmarks) + (define (find dir) + (for/list ([d (directory-list dir)] + #:when (scheme-file? d)) + d)) + (define shootout (collection-path "tests" "racket" "benchmarks" "shootout" "typed")) + (define common (collection-path "tests" "racket" "benchmarks" "common" "typed")) + (define (mk path) + (make-test-suite (path->string path) + (for/list ([p (find path)]) + (parameterize ([current-load-relative-directory + (path->complete-path path)] + [current-directory path]) + (test-suite (path->string p) + (check-not-exn (λ () (cfile (build-path path p))))))))) + (test-suite "compiling" + (mk shootout) + (mk common))) + +(provide go go/text just-one compile-benchmarks) diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt index 8bee3094..97f575c1 100644 --- a/collects/tests/typed-scheme/optimizer/run.rkt +++ b/collects/tests/typed-scheme/optimizer/run.rkt @@ -33,7 +33,7 @@ (vector-ref (current-command-line-arguments) 0))) 0 1) (for/fold ((n-failures 0)) - ((gen (in-directory (build-path here "generic")))) + ((gen (in-directory (build-path here "generic")))) (+ 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/run.rkt b/collects/tests/typed-scheme/run.rkt index b2776667..0266f180 100644 --- a/collects/tests/typed-scheme/run.rkt +++ b/collects/tests/typed-scheme/run.rkt @@ -6,21 +6,32 @@ (define exec (make-parameter go/text)) (define the-tests (make-parameter tests)) (define skip-all? #f) +(define nightly? (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" (when (eq? 'cgc (system-type 'gc)) - (set! skip-all? #t))] + ["--nightly" "for the nightly builds" (nightly? #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)] ["--gui" "run using the gui" (if (gui-available?) (begin (exec go)) (error "GUI not available"))] ) -(if skip-all? - (printf "Skipping Typed Racket tests.\n") - (unless (= 0 ((exec) (the-tests))) - (error "Typed Racket Tests did not pass."))) +(cond [(and (nightly?) (eq? 'cgc (system-type 'gc))) + (printf "Skipping Typed Racket tests.\n")] + [(unless (= 0 ((exec) (the-tests))) + (error "Typed Racket Tests did not pass.")) + (when (opt?) + (parameterize ([current-command-line-arguments #()]) + (dynamic-require '(file "optimizer/run.rkt") #f)) + (printf "Typed Racket Optimizer tests passed")) + (when (bench?) + (unless (= 0 ((exec) (compile-benchmarks))) + (error "Typed Racket Tests did not pass.")))]) From fe84eaf72274216d67a091ddc9e20dc935ea025f Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Jul 2010 18:29:14 -0400 Subject: [PATCH 176/198] Added struct optimizations. original commit: a6d11a1df08336183e1af36b787c134e1bf4f469 --- .../tests/typed-scheme/optimizer/generic/structs.rkt | 6 ++++++ collects/typed-scheme/private/optimize.rkt | 12 ++++++++++++ collects/typed-scheme/types/type-table.rkt | 8 +++++++- 3 files changed, 25 insertions(+), 1 deletion(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/structs.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/structs.rkt b/collects/tests/typed-scheme/optimizer/generic/structs.rkt new file mode 100644 index 00000000..4fb39c9d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/structs.rkt @@ -0,0 +1,6 @@ +(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/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index fecbaaba..1feeb4b7 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -249,6 +249,18 @@ (lambda (x) #t) (lambda (x y) #t))))) + ;; we can always optimize struct accessors and mutators + ;; if they typecheck, they're safe + (pattern (#%plain-app op:id s:opt-expr v:opt-expr ...) + #:when (or (struct-accessor? #'op) (struct-mutator? #'op)) + #:with opt + (let ([idx (struct-fn-idx #'op)]) + (if (struct-accessor? #'op) + (begin (log-optimization "struct ref" #'op) + #`(unsafe-struct-ref s.opt #,idx)) + (begin (log-optimization "struct set" #'op) + #`(unsafe-struct-set! s.opt #,idx v.opt ...))))) + ;; boring cases, just recur down (pattern (#%plain-lambda formals e:opt-expr ...) #:with opt #'(#%plain-lambda formals e.opt ...)) diff --git a/collects/typed-scheme/types/type-table.rkt b/collects/typed-scheme/types/type-table.rkt index 154ac941..8e742f21 100644 --- a/collects/typed-scheme/types/type-table.rkt +++ b/collects/typed-scheme/types/type-table.rkt @@ -22,10 +22,15 @@ (let () (define ((mk mut?) id) (cond [(dict-ref struct-fn-table id #f) - => (match-lambda [(list pe #f) pe] [_ #f])] + => (match-lambda [(list pe m) (and (eq? m mut?) pe)] [_ #f])] [else #f])) (values (mk #f) (mk #t)))) +(define (struct-fn-idx id) + (match (dict-ref struct-fn-table id #f) + [(list (StructPE: _ idx) _) idx] + [_ (int-err (format "no struct fn table entry for ~a" (syntax->datum id)))])) + (define (make-struct-table-code) (parameterize ([current-print-convert-hook converter] [show-sharing #f]) @@ -43,4 +48,5 @@ [add-struct-fn! (identifier? StructPE? boolean? . -> . any/c)] [struct-accessor? (identifier? . -> . (or/c #f StructPE?))] [struct-mutator? (identifier? . -> . (or/c #f StructPE?))] + [struct-fn-idx (identifier? . -> . exact-integer?)] [make-struct-table-code (-> syntax?)]) \ No newline at end of file From 38d40649d5b7b04b9e2cc8a39eef2bb3f92353db Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Jul 2010 19:35:33 -0400 Subject: [PATCH 177/198] Changed the optimizer's test harness to ignore type tables. original commit: e8a0a26c2f4b3f8da6beb0b3a6b7348d6cfeccf9 --- collects/tests/typed-scheme/optimizer/run.rkt | 27 +++++++++++-------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt index 97f575c1..b4139e25 100644 --- a/collects/tests/typed-scheme/optimizer/run.rkt +++ b/collects/tests/typed-scheme/optimizer/run.rkt @@ -5,17 +5,22 @@ ;; we compare the expansion of automatically optimized and hand optimized ;; modules (define (read-and-expand file) - ;; 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 - (cdddr - (syntax->datum - (parameterize ([current-namespace (make-base-namespace)]) - (with-handlers - ([exn:fail? (lambda (exn) - (printf "~a\n" (exn-message exn)) - #'(#f #f #f #f))]) ; for cdddr - (expand (with-input-from-file file read-syntax))))))) + ;; 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)]) + (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 (test gen) (let-values (((base name _) (split-path gen))) From a3a3bd1e2e56bab8167b073c0a2e62e52954293e Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Jul 2010 20:56:26 -0400 Subject: [PATCH 178/198] Added coercion of fixnums to floats to the optimizer. original commit: 556734a223f4193c1c23ded76f204f1e6bb25295 --- .../optimizer/generic/float-promotion.rkt | 3 +- collects/typed-scheme/private/optimize.rkt | 30 +++++++++---------- 2 files changed, 17 insertions(+), 16 deletions(-) diff --git a/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt b/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt index 3df6f684..1fc32fa9 100644 --- a/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt +++ b/collects/tests/typed-scheme/optimizer/generic/float-promotion.rkt @@ -1,3 +1,4 @@ (module float-promotion typed/scheme #:optimize (require racket/unsafe/ops racket/flonum) - (+ 1 2.0)) + (+ 1 2.0) + (+ (expt 100 100) 2.0)) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 1feeb4b7..269e42a9 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -11,34 +11,23 @@ (match (type-of s) [(tc-result1: (== t (lambda (x y) (subtype y x)))) #t] [_ #f])) + (define-syntax-class float-opt-expr (pattern e:opt-expr #:when (subtypeof #'e -Flonum) #:with opt #'e.opt)) - (define-syntax-class int-opt-expr (pattern e:opt-expr #:when (subtypeof #'e -Integer) #:with opt #'e.opt)) -(define-syntax-class fixnum-opt-expr - (pattern e:opt-expr - #:when (subtypeof #'e -Fixnum) - #:with opt #'e.opt)) -(define-syntax-class nonzero-fixnum-opt-expr - (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (== -PositiveFixnum type-equal?)) #t] - [(tc-result1: (== -NegativeFixnum type-equal?)) #t] - [_ #f]) - #:with opt #'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 + (pattern e:fixnum-opt-expr + #:with opt #'(unsafe-fx->fl e.opt)) (pattern e:int-opt-expr #:with opt #'(->fl e.opt)) (pattern e:float-opt-expr @@ -66,6 +55,18 @@ #:with unsafe (dict-ref tbl #'i))) +(define-syntax-class fixnum-opt-expr + (pattern e:opt-expr + #:when (subtypeof #'e -Fixnum) + #:with opt #'e.opt)) +(define-syntax-class nonzero-fixnum-opt-expr + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -PositiveFixnum type-equal?)) #t] + [(tc-result1: (== -NegativeFixnum type-equal?)) #t] + [_ #f]) + #:with opt #'e.opt)) + (define (mk-fixnum-tbl generic) (mk-unsafe-tbl generic "fx~a" "unsafe-fx~a")) @@ -192,7 +193,6 @@ #:with opt (begin (log-optimization "fixnum to float" #'op) #'(unsafe-fx->fl n.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-opt-expr) #:with opt From ccbf54bdf7c9a16284d9230dbf93c2c61a4cc914 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Fri, 2 Jul 2010 20:57:09 -0400 Subject: [PATCH 179/198] Added support for make-flrectangular, flreal-part, flimag-part and their unsafe counterparts to Typed Scheme and its optimizer. original commit: 389a20795a5bb6db25341b899e7ec58e6eb5a0d1 --- .../generic/invalid-inexact-complex-parts.rkt | 2 ++ .../generic/invalid-make-flrectangular.rkt | 2 ++ .../optimizer/generic/make-flrectangular.rkt | 4 +++ .../typed-scheme/private/base-env-numeric.rkt | 6 ++++ collects/typed-scheme/private/optimize.rkt | 28 +++++++++++++++++-- 5 files changed, 39 insertions(+), 3 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt create mode 100644 collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt 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 new file mode 100644 index 00000000..b0a2ab9d --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-inexact-complex-parts.rkt @@ -0,0 +1,2 @@ +(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 new file mode 100644 index 00000000..ce166151 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/invalid-make-flrectangular.rkt @@ -0,0 +1,2 @@ +(module invalid-make-flrectangular typed/scheme #:optimize + (make-rectangular 1 2)) diff --git a/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt b/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt new file mode 100644 index 00000000..b9250d0e --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/make-flrectangular.rkt @@ -0,0 +1,4 @@ +(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/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index e42c0b77..fe546c38 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -468,6 +468,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-fx+ fx+-type] [unsafe-fx- fx-intop] @@ -545,6 +548,9 @@ [flexp fl-unop] [flsqrt fl-unop] [->fl (-Integer . -> . -Flonum)] +[make-flrectangular (-Flonum -Flonum . -> . -InexactComplex)] +[flreal-part (-InexactComplex . -> . -Flonum)] +[flimag-part (-InexactComplex . -> . -Flonum)] ;; safe flvector ops diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 269e42a9..670cd8ae 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -44,7 +44,13 @@ (define binary-float-ops (mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max))) (define binary-float-comps - (mk-float-tbl (list #'= #'<= #'< #'> #'>=))) + (dict-set + (dict-set + (mk-float-tbl (list #'= #'<= #'< #'> #'>=)) + ;; not a comparison, but takes 2 floats and does not return a float, + ;; unlike binary-float-ops + #'make-rectangular #'unsafe-make-flrectangular) + #'make-flrectangular #'unsafe-make-flrectangular)) (define unary-float-ops (mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp #'sqrt #'round #'floor #'ceiling #'truncate))) @@ -54,6 +60,18 @@ #:when (dict-ref tbl #'i #f) #:with unsafe (dict-ref tbl #'i))) +(define-syntax-class inexact-complex-opt-expr + (pattern e:opt-expr + ;; can't work on inexact reals, which are a subtype of inexact + ;; complexes, so this has to be equality + #:when (match (type-of #'e) + [(tc-result1: (== -InexactComplex type-equal?)) #t] [_ #f]) + #:with opt #'e.opt)) + +(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 fixnum-opt-expr (pattern e:opt-expr @@ -171,8 +189,6 @@ (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-opt-expr f2:float-opt-expr fs:float-opt-expr ...)) - #:when (match (type-of #'res) - [(tc-result1: (== -Boolean type-equal?)) #t] [_ #f]) #:with opt (begin (log-optimization "binary float comp" #'op) (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) @@ -189,6 +205,12 @@ #:with opt (begin (log-optimization "binary nonzero fixnum" #'op) #'(op.unsafe n1.opt n2.opt))) + + (pattern (#%plain-app op:inexact-complex-unary-op n:inexact-complex-opt-expr) + #:with opt + (begin (log-optimization "unary inexact complex" #'op) + #'(op.unsafe n.opt))) + (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-opt-expr) #:with opt (begin (log-optimization "fixnum to float" #'op) From f6df8722f5ab28b0682f2487444ec29fa73c626a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 5 Jul 2010 14:25:51 -0400 Subject: [PATCH 180/198] Improve interface for `find-mutated-vars', now supports mutable *and* immutable versions. original commit: 692a1724746d1dfa9f666c8f6fed2090ed900099 --- collects/unstable/mutated-vars.rkt | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/collects/unstable/mutated-vars.rkt b/collects/unstable/mutated-vars.rkt index 6a252521..3b3162bf 100644 --- a/collects/unstable/mutated-vars.rkt +++ b/collects/unstable/mutated-vars.rkt @@ -1,17 +1,17 @@ #lang racket/base (require (for-template racket/base) racket/dict - racket/trace syntax/id-table syntax/kerncase) -;; samth : this should use sets, not dicts -;; but sets do not have extensible comparisons -;; shouldn't be promoted until this is fixed - ;; find and add to mapping all the set!'ed variables in form -;; syntax -> table -(define (find-mutated-vars form) - (let loop ([stx form] [tbl (make-immutable-free-id-table)]) +;; if the supplied mapping is mutable, mutates it +;; default is immutability +;; syntax [table] -> table +(define (find-mutated-vars form [tbl (make-immutable-free-id-table)]) + (define add (if (dict-mutable? tbl) + (lambda (t i) (dict-set! t i #t) t) + (lambda (t i) (dict-set t i #t)))) + (let loop ([stx form] [tbl tbl]) ;; syntax-list -> table (define (fmv/list lstx) (for/fold ([tbl tbl]) @@ -20,7 +20,7 @@ (kernel-syntax-case* stx #f (#%top-interaction) ;; what we care about: set! [(set! v e) - (dict-set (loop #'e tbl) #'v #t)] + (add (loop #'e tbl) #'v)] ;; forms with expression subforms [(define-values (var ...) expr) (loop #'expr tbl)] From 10d5e7851ea3b5ecf8e35568252fa577b18f3bf1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 6 Jul 2010 11:10:05 -0400 Subject: [PATCH 181/198] Add typeof mappings only to original form. original commit: e865380f6f7ebf843c4a4a7dea25261b28e759fc --- .../typed-scheme/typecheck/tc-expr-unit.rkt | 34 +++++-------------- 1 file changed, 9 insertions(+), 25 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 0889fdea..9ad38d83 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -176,23 +176,24 @@ (unless (syntax? form) (int-err "bad form input to tc-expr: ~a" form)) ;; typecheck form - (let loop ([form form] [expected expected] [checked? #f]) - (cond [(type-ascription form) + (let loop ([form* form] [expected expected] [checked? #f]) + (cond [(type-ascription form*) => (lambda (ann) - (let* ([r (tc-expr/check/internal form ann)] + (let* ([r (tc-expr/check/internal form* ann)] [r* (check-below r expected)]) + ;; add this to the *original* form, since the newer forms aren't really in the program (add-typeof-expr form expected) ;; around again in case there is an instantiation ;; remove the ascription so we don't loop infinitely - (loop (remove-ascription form) r* #t)))] - [(syntax-property form 'type-inst) + (loop (remove-ascription form*) r* #t)))] + [(syntax-property form* 'type-inst) ;; check without property first ;; to get the appropriate type to instantiate - (match (tc-expr (syntax-property form 'type-inst #f)) + (match (tc-expr (syntax-property form* 'type-inst #f)) [(tc-results: ts fs os) ;; do the instantiation on the old type - (let* ([ts* (do-inst form ts)] + (let* ([ts* (do-inst form* ts)] [ts** (ret ts* fs os)]) (add-typeof-expr form ts**) ;; make sure the new type is ok @@ -201,27 +202,10 @@ [ty (add-typeof-expr form ty) ty])] ;; nothing to see here [checked? expected] - [else (let ([t (tc-expr/check/internal form expected)]) + [else (let ([t (tc-expr/check/internal form* expected)]) (add-typeof-expr form t) t)])))) -#; -(define (tc-or e1 e2 or-part [expected #f]) - (match (single-value e1) - [(tc-result1: t1 (and f1 (FilterSet: fs+ fs-)) o1) - (let*-values ([(flag+ flag-) (values (box #t) (box #t))]) - (match-let* ([(tc-result1: t2 f2 o2) (with-lexical-env - (env+ (lexical-env) fs+ flag+) - (with-lexical-env/extend - (list or-part) (list (restrict t1 (-val #f))) (single-value e2 expected)))] - [t1* (remove t1 (-val #f))] - [f1* (-FS null (list (make-Bot)))]) - ;; if we have the same number of values in both cases - (let ([r (combine-filter f1 f1* f2 t1* t2 o1 o2)]) - (if expected - (check-below r expected) - r))))])) - ;; tc-expr/check : syntax tc-results -> tc-results (define (tc-expr/check/internal form expected) (parameterize ([current-orig-stx form]) From f578a22046deb8281c57ce19450cd13301a29562 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 6 Jul 2010 14:58:46 -0400 Subject: [PATCH 182/198] Have type ascriptions record the ascribed type in the type table. original commit: eb7fc7a9655f26f35220295c24086da3699c3187 --- collects/typed-scheme/typecheck/tc-expr-unit.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.rkt b/collects/typed-scheme/typecheck/tc-expr-unit.rkt index 9ad38d83..b5a2b2bc 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.rkt +++ b/collects/typed-scheme/typecheck/tc-expr-unit.rkt @@ -183,7 +183,7 @@ (let* ([r (tc-expr/check/internal form* ann)] [r* (check-below r expected)]) ;; add this to the *original* form, since the newer forms aren't really in the program - (add-typeof-expr form expected) + (add-typeof-expr form ann) ;; around again in case there is an instantiation ;; remove the ascription so we don't loop infinitely (loop (remove-ascription form*) r* #t)))] From 592aa2ac8ced6cb768036b08ca408928bbe10a9e Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 6 Jul 2010 14:28:40 -0400 Subject: [PATCH 183/198] Added an optimization for vector-length of known-length vectors. original commit: e52d63ee686e20401f0b0df80d178e40e9a0226f --- .../optimizer/generic/known-vector-length.rkt | 3 +++ collects/typed-scheme/private/optimize.rkt | 10 ++++++++++ 2 files changed, 13 insertions(+) create mode 100644 collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt b/collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt new file mode 100644 index 00000000..083d8730 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/known-vector-length.rkt @@ -0,0 +1,3 @@ +(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/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 670cd8ae..0cd2c8ae 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -231,6 +231,16 @@ (begin (log-optimization "unary pair" #'op) #'(op.unsafe p.opt))) + ;; 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-opt-expr) + #:with opt + (begin (log-optimization "known-length vector" #'op) + (match (type-of #'v) + [(tc-result1: (HeterogenousVector: es)) + #`(begin v.opt #,(length es))]))) ; v may have side effects ;; we can optimize vector-length on all vectors. ;; since the program typechecked, we know the arg is a vector. ;; we can optimize no matter what. From 9e3912d3906fa4213660cbf99255e7742b11c49b Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 6 Jul 2010 17:26:33 -0400 Subject: [PATCH 184/198] Generic inexact complex arithmetic operations are now replaced with the right combinations of unsafe float operations. original commit: 3fb69bc764885f2e6ef25134da747caa32b80f05 --- .../optimizer/generic/n-ary-float.rkt | 3 ++ collects/typed-scheme/private/optimize.rkt | 52 ++++++++++++++++++- 2 files changed, 53 insertions(+), 2 deletions(-) create mode 100644 collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt diff --git a/collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt b/collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt new file mode 100644 index 00000000..54b59581 --- /dev/null +++ b/collects/tests/typed-scheme/optimizer/generic/n-ary-float.rkt @@ -0,0 +1,3 @@ +(module n-ary-float typed/scheme #:optimize + (require racket/unsafe/ops) + (+ 1.0 2.0 3.0)) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 0cd2c8ae..2a80da4e 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -71,7 +71,8 @@ (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 binary-inexact-complex-ops + (mk-float-tbl (list #'+ #'- #'* #'/))) (define-syntax-class fixnum-opt-expr (pattern e:opt-expr @@ -210,7 +211,54 @@ #:with opt (begin (log-optimization "unary inexact complex" #'op) #'(op.unsafe n.opt))) - + ;; it's faster to take apart a complex number and use unsafe operations on + ;; its parts than it is to use generic operations + (pattern (#%plain-app (~and (~var op (float-op binary-inexact-complex-ops)) (~or (~literal +) (~literal -))) + c1:inexact-complex-opt-expr c2:inexact-complex-opt-expr cs:inexact-complex-opt-expr ...) + #:with opt + (begin (log-optimization "binary inexact complex" #'op) + (for/fold ([o #'c1.opt]) + ([e (syntax->list #'(c2.opt cs.opt ...))]) + #`(let ((t1 #,o) + (t2 #,e)) + (unsafe-make-flrectangular + (op.unsafe (unsafe-flreal-part t1) + (unsafe-flreal-part t2)) + (op.unsafe (unsafe-flimag-part t1) + (unsafe-flimag-part t2))))))) + (pattern (#%plain-app (~and op (~literal *)) c1:inexact-complex-opt-expr c2:inexact-complex-opt-expr cs:inexact-complex-opt-expr ...) + #:with opt + (begin (log-optimization "binary inexact complex" #'op) + (for/fold ([o #'c1.opt]) + ([e (syntax->list #'(c2.opt cs.opt ...))]) + #`(let ((t1 #,o) + (t2 #,e)) + (let ((a (unsafe-flreal-part t1)) + (b (unsafe-flimag-part t1)) + (c (unsafe-flreal-part t2)) + (d (unsafe-flimag-part t2))) + (unsafe-make-flrectangular + (unsafe-fl- (unsafe-fl* a c) + (unsafe-fl* b d)) + (unsafe-fl+ (unsafe-fl* b c) + (unsafe-fl* a d)))))))) + (pattern (#%plain-app (~and op (~literal /)) c1:inexact-complex-opt-expr c2:inexact-complex-opt-expr cs:inexact-complex-opt-expr ...) + #:with opt + (begin (log-optimization "binary inexact complex" #'op) + (for/fold ([o #'c1.opt]) + ([e (syntax->list #'(c2.opt cs.opt ...))]) + #`(let ((t1 #,o) + (t2 #,e)) + (let ((a (unsafe-flreal-part t1)) + (b (unsafe-flimag-part t1)) + (c (unsafe-flreal-part t2)) + (d (unsafe-flimag-part t2))) + (unsafe-make-flrectangular + (unsafe-fl/ (unsafe-fl+ (unsafe-fl* a c) (unsafe-fl* b d)) + (unsafe-fl+ (unsafe-fl* c c) (unsafe-fl* d d))) + (unsafe-fl/ (unsafe-fl- (unsafe-fl* b c) (unsafe-fl* a d)) + (unsafe-fl+ (unsafe-fl* c c) (unsafe-fl* d d))))))))) + (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-opt-expr) #:with opt (begin (log-optimization "fixnum to float" #'op) From d55cf6d13a137a3fca8ff25e5c1568401d1c902d Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Tue, 6 Jul 2010 18:10:44 -0400 Subject: [PATCH 185/198] Avoided duplicate computation in inexact complex division. original commit: de52d2ce9ffede21df37e74edb6cdb47bfab1828 --- collects/typed-scheme/private/optimize.rkt | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 2a80da4e..9509f935 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -253,11 +253,12 @@ (b (unsafe-flimag-part t1)) (c (unsafe-flreal-part t2)) (d (unsafe-flimag-part t2))) - (unsafe-make-flrectangular - (unsafe-fl/ (unsafe-fl+ (unsafe-fl* a c) (unsafe-fl* b d)) - (unsafe-fl+ (unsafe-fl* c c) (unsafe-fl* d d))) - (unsafe-fl/ (unsafe-fl- (unsafe-fl* b c) (unsafe-fl* a d)) - (unsafe-fl+ (unsafe-fl* c c) (unsafe-fl* d d))))))))) + (let ((den (unsafe-fl+ (unsafe-fl* c c) (unsafe-fl* d d)))) + (unsafe-make-flrectangular + (unsafe-fl/ (unsafe-fl+ (unsafe-fl* a c) (unsafe-fl* b d)) + den) + (unsafe-fl/ (unsafe-fl- (unsafe-fl* b c) (unsafe-fl* a d)) + den)))))))) (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-opt-expr) #:with opt From f7ac316db2e14d580260b3cc14925738e9f713c2 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 7 Jul 2010 14:08:33 -0400 Subject: [PATCH 186/198] Avoid boxing intermediate results when doing multiple complex operations in a row. However, because of values and let-values, we lose float unboxing. If we have a single complex operation, this is much slower than my previous implementation (though still faster than generic operations). With 2 complex operations, the new implementation becomes faster. original commit: 7921074eef1e36984479db5b8eea3c6bbbe13064 --- collects/typed-scheme/private/optimize.rkt | 105 +++++++++++---------- 1 file changed, 57 insertions(+), 48 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 9509f935..8dc2fed0 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -61,12 +61,64 @@ #:with unsafe (dict-ref tbl #'i))) (define-syntax-class inexact-complex-opt-expr + (pattern e:unboxed-inexact-complex-opt-expr + #:with opt #'(let-values (((real imag) e.opt)) + (unsafe-make-flrectangular real imag)))) +;; 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 (~var op (float-op binary-inexact-complex-ops)) (~or (~literal +) (~literal -))) + c1:unboxed-inexact-complex-opt-expr + c2:unboxed-inexact-complex-opt-expr + cs:unboxed-inexact-complex-opt-expr ...) + #:with opt + (begin (log-optimization "binary inexact complex" #'op) + (for/fold ([o #'c1.opt]) + ([e (syntax->list #'(c2.opt cs.opt ...))]) + #`(let-values (((t1-real t1-imag) #,o) + ((t2-real t2-imag) #,e)) + (values + (op.unsafe t1-real t2-real) + (op.unsafe t1-imag t2-imag)))))) + (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 opt + (begin (log-optimization "binary inexact complex" #'op) + (for/fold ([o #'c1.opt]) + ([e (syntax->list #'(c2.opt cs.opt ...))]) + #`(let-values (((a b) #,o) + ((c d) #,e)) + (values + (unsafe-fl- (unsafe-fl* a c) (unsafe-fl* b d)) + (unsafe-fl+ (unsafe-fl* b c) (unsafe-fl* a d))))))) + (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 opt + (begin (log-optimization "binary inexact complex" #'op) + (for/fold ([o #'c1.opt]) + ([e (syntax->list #'(c2.opt cs.opt ...))]) + #`(let-values (((a b) #,o) + ((c d) #,e)) + (let ((den (unsafe-fl+ (unsafe-fl* c c) (unsafe-fl* d d)))) + (values + (unsafe-fl/ (unsafe-fl+ (unsafe-fl* a c) (unsafe-fl* b d)) + den) + (unsafe-fl/ (unsafe-fl- (unsafe-fl* b c) (unsafe-fl* a d)) + den))))))) (pattern e:opt-expr ;; can't work on inexact reals, which are a subtype of inexact ;; complexes, so this has to be equality #:when (match (type-of #'e) [(tc-result1: (== -InexactComplex type-equal?)) #t] [_ #f]) - #:with opt #'e.opt)) + #:with opt #'(let ((t e.opt)) + (values (unsafe-flreal-part t) + (unsafe-flimag-part t))))) (define-syntax-class inexact-complex-unary-op (pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part) @@ -211,54 +263,11 @@ #:with opt (begin (log-optimization "unary inexact complex" #'op) #'(op.unsafe n.opt))) - ;; it's faster to take apart a complex number and use unsafe operations on - ;; its parts than it is to use generic operations - (pattern (#%plain-app (~and (~var op (float-op binary-inexact-complex-ops)) (~or (~literal +) (~literal -))) - c1:inexact-complex-opt-expr c2:inexact-complex-opt-expr cs:inexact-complex-opt-expr ...) + (pattern (~and exp (#%plain-app (~var op (float-op binary-inexact-complex-ops)) e:inexact-complex-opt-expr ...)) + #:with exp*:inexact-complex-opt-expr #'exp #:with opt - (begin (log-optimization "binary inexact complex" #'op) - (for/fold ([o #'c1.opt]) - ([e (syntax->list #'(c2.opt cs.opt ...))]) - #`(let ((t1 #,o) - (t2 #,e)) - (unsafe-make-flrectangular - (op.unsafe (unsafe-flreal-part t1) - (unsafe-flreal-part t2)) - (op.unsafe (unsafe-flimag-part t1) - (unsafe-flimag-part t2))))))) - (pattern (#%plain-app (~and op (~literal *)) c1:inexact-complex-opt-expr c2:inexact-complex-opt-expr cs:inexact-complex-opt-expr ...) - #:with opt - (begin (log-optimization "binary inexact complex" #'op) - (for/fold ([o #'c1.opt]) - ([e (syntax->list #'(c2.opt cs.opt ...))]) - #`(let ((t1 #,o) - (t2 #,e)) - (let ((a (unsafe-flreal-part t1)) - (b (unsafe-flimag-part t1)) - (c (unsafe-flreal-part t2)) - (d (unsafe-flimag-part t2))) - (unsafe-make-flrectangular - (unsafe-fl- (unsafe-fl* a c) - (unsafe-fl* b d)) - (unsafe-fl+ (unsafe-fl* b c) - (unsafe-fl* a d)))))))) - (pattern (#%plain-app (~and op (~literal /)) c1:inexact-complex-opt-expr c2:inexact-complex-opt-expr cs:inexact-complex-opt-expr ...) - #:with opt - (begin (log-optimization "binary inexact complex" #'op) - (for/fold ([o #'c1.opt]) - ([e (syntax->list #'(c2.opt cs.opt ...))]) - #`(let ((t1 #,o) - (t2 #,e)) - (let ((a (unsafe-flreal-part t1)) - (b (unsafe-flimag-part t1)) - (c (unsafe-flreal-part t2)) - (d (unsafe-flimag-part t2))) - (let ((den (unsafe-fl+ (unsafe-fl* c c) (unsafe-fl* d d)))) - (unsafe-make-flrectangular - (unsafe-fl/ (unsafe-fl+ (unsafe-fl* a c) (unsafe-fl* b d)) - den) - (unsafe-fl/ (unsafe-fl- (unsafe-fl* b c) (unsafe-fl* a d)) - den)))))))) + (begin (log-optimization "unboxed inexact complex" #'exp) + #'exp*.opt)) (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-opt-expr) #:with opt From 9320340cb9c03e992106a07d7a0f4b8347f824a7 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 7 Jul 2010 18:41:25 -0400 Subject: [PATCH 187/198] Improved unboxed complex operations. Intermediate results are kept as unboxed floats as long as we stay within complex arithmetic code. original commit: 7853d333495376f065c63a19866ac2eba6f8926a --- collects/typed-scheme/private/optimize.rkt | 135 +++++++++++++++------ 1 file changed, 99 insertions(+), 36 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index 8dc2fed0..a58227ca 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -1,7 +1,7 @@ #lang scheme/base (require syntax/parse (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for) - "../utils/utils.rkt" "../utils/tc-utils.rkt" unstable/match scheme/match unstable/syntax + "../utils/utils.rkt" "../utils/tc-utils.rkt" unstable/match scheme/match unstable/syntax unstable/values (rep type-rep) syntax/id-table racket/dict (types abbrev type-table utils subtype)) (provide optimize) @@ -60,10 +60,21 @@ #:when (dict-ref tbl #'i #f) #:with unsafe (dict-ref tbl #'i))) +;; 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) + (set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*)) + (format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*)) + (define-syntax-class inexact-complex-opt-expr (pattern e:unboxed-inexact-complex-opt-expr - #:with opt #'(let-values (((real imag) e.opt)) - (unsafe-make-flrectangular real imag)))) + #:with opt + (begin (set! *unboxed-gensym-counter* 0) + #'(let* (e.bindings ...) + (unsafe-make-flrectangular e.real-part e.imag-part))))) ;; 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 @@ -73,52 +84,104 @@ c1:unboxed-inexact-complex-opt-expr c2:unboxed-inexact-complex-opt-expr cs:unboxed-inexact-complex-opt-expr ...) - #:with opt - (begin (log-optimization "binary inexact complex" #'op) - (for/fold ([o #'c1.opt]) - ([e (syntax->list #'(c2.opt cs.opt ...))]) - #`(let-values (((t1-real t1-imag) #,o) - ((t2-real t2-imag) #,e)) - (values - (op.unsafe t1-real t2-real) - (op.unsafe t1-imag t2-imag)))))) + #: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 ...)))) + #`(op.unsafe #,o #,e))) + #`(imag-part #,(for/fold ((o #'c1.imag-part)) + ((e (syntax->list #'(c2.imag-part cs.imag-part ...)))) + #`(op.unsafe #,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 opt - (begin (log-optimization "binary inexact complex" #'op) - (for/fold ([o #'c1.opt]) - ([e (syntax->list #'(c2.opt cs.opt ...))]) - #`(let-values (((a b) #,o) - ((c d) #,e)) - (values - (unsafe-fl- (unsafe-fl* a c) (unsafe-fl* b d)) - (unsafe-fl+ (unsafe-fl* b c) (unsafe-fl* a d))))))) + #: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 loop ([o1 #'c1.real-part] + [o2 #'c1.imag-part] + [e1 (syntax->list #'(c2.real-part cs.real-part ...))] + [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))] + [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) + (list* #`(#,(car is) + (unsafe-fl+ (unsafe-fl* #,o2 #,(car e1)) + (unsafe-fl* #,o1 #,(car e2)))) + #`(#,(car rs) + (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 opt - (begin (log-optimization "binary inexact complex" #'op) - (for/fold ([o #'c1.opt]) - ([e (syntax->list #'(c2.opt cs.opt ...))]) - #`(let-values (((a b) #,o) - ((c d) #,e)) - (let ((den (unsafe-fl+ (unsafe-fl* c c) (unsafe-fl* d d)))) - (values - (unsafe-fl/ (unsafe-fl+ (unsafe-fl* a c) (unsafe-fl* b d)) - den) - (unsafe-fl/ (unsafe-fl- (unsafe-fl* b c) (unsafe-fl* a d)) - den))))))) + #:with real-part (unboxed-gensym) + #:with imag-part (unboxed-gensym) + #:with (denominators ...) + (for/list + ([e1 (syntax->list #'(c2.real-part cs.real-part ...))] + [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]) + #`(#,(unboxed-gensym) (unsafe-fl+ (unsafe-fl* #,e1 #,e1) (unsafe-fl* #,e2 #,e2)))) + #:with (bindings ...) + (begin (log-optimization "unboxed binary inexact complex" #'op) + #`(c1.bindings ... c2.bindings ... cs.bindings ... ... denominators ... + ;; we want to bind the intermediate results to reuse them + ;; the final results are bound to real-part and imag-part + #,@(let loop ([o1 #'c1.real-part] + [o2 #'c1.imag-part] + [e1 (syntax->list #'(c2.real-part cs.real-part ...))] + [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))] + [d (map (lambda (x) (car (syntax-e x))) + (syntax->list #'(denominators ...)))] + [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 d) (cdr rs) (cdr is) + ;; complex division, imag part, then real part (reverse) + (list* #`(#,(car is) + (unsafe-fl/ (unsafe-fl- (unsafe-fl* #,o2 #,(car e1)) + (unsafe-fl* #,o1 #,(car e2))) + #,(car d))) + #`(#,(car rs) + (unsafe-fl/ (unsafe-fl+ (unsafe-fl* #,o1 #,(car e1)) + (unsafe-fl* #,o2 #,(car e2))) + #,(car d))) + res))))))) (pattern e:opt-expr ;; can't work on inexact reals, which are a subtype of inexact ;; complexes, so this has to be equality #:when (match (type-of #'e) [(tc-result1: (== -InexactComplex type-equal?)) #t] [_ #f]) - #:with opt #'(let ((t e.opt)) - (values (unsafe-flreal-part t) - (unsafe-flimag-part t))))) + #:with e* (unboxed-gensym) + #:with real-part (unboxed-gensym) + #:with imag-part (unboxed-gensym) + #:with (bindings ...) + #'((e* e.opt) + (real-part (unsafe-flreal-part e*)) + (imag-part (unsafe-flimag-part e*))))) (define-syntax-class inexact-complex-unary-op (pattern (~or (~literal real-part) (~literal flreal-part)) #:with unsafe #'unsafe-flreal-part) From 8ffb3128e4b3ec1da728447a3040fc28ecba784e Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 7 Jul 2010 22:07:48 -0400 Subject: [PATCH 188/198] Fixed pessimization of some complex code. original commit: ea8523bd63665f5330d25c7babf3872298f1e570 --- collects/typed-scheme/private/optimize.rkt | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/private/optimize.rkt index a58227ca..e21a8018 100644 --- a/collects/typed-scheme/private/optimize.rkt +++ b/collects/typed-scheme/private/optimize.rkt @@ -70,11 +70,11 @@ (format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*)) (define-syntax-class inexact-complex-opt-expr - (pattern e:unboxed-inexact-complex-opt-expr - #:with opt - (begin (set! *unboxed-gensym-counter* 0) - #'(let* (e.bindings ...) - (unsafe-make-flrectangular e.real-part e.imag-part))))) + (pattern e:opt-expr + #:when (match (type-of #'e) + [(tc-result1: (== -InexactComplex type-equal?)) #t] [_ #f]) + + #:with opt #'e.opt)) ;; 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 @@ -327,10 +327,12 @@ (begin (log-optimization "unary inexact complex" #'op) #'(op.unsafe n.opt))) (pattern (~and exp (#%plain-app (~var op (float-op binary-inexact-complex-ops)) e:inexact-complex-opt-expr ...)) - #:with exp*:inexact-complex-opt-expr #'exp + #:with exp*:unboxed-inexact-complex-opt-expr #'exp #:with opt (begin (log-optimization "unboxed inexact complex" #'exp) - #'exp*.opt)) + (begin (set! *unboxed-gensym-counter* 0) + #'(let* (exp*.bindings ...) + (unsafe-make-flrectangular exp*.real-part exp*.imag-part))))) (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-opt-expr) #:with opt From e9ff5ae34d29eb3b18a3c07472ed8bbed2b2243b Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 8 Jul 2010 10:45:04 -0400 Subject: [PATCH 189/198] Moved Typed Scheme's optimizer to its own subdirectory. original commit: 24aad77da3e3c2e411642cdb08fffaaa31a0b1cb --- .../{private/optimize.rkt => optimizer/optimizer.rkt} | 0 collects/typed-scheme/typed-scheme.rkt | 3 ++- collects/typed-scheme/utils/utils.rkt | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) rename collects/typed-scheme/{private/optimize.rkt => optimizer/optimizer.rkt} (100%) diff --git a/collects/typed-scheme/private/optimize.rkt b/collects/typed-scheme/optimizer/optimizer.rkt similarity index 100% rename from collects/typed-scheme/private/optimize.rkt rename to collects/typed-scheme/optimizer/optimizer.rkt diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 15c9d817..9c246122 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -5,7 +5,8 @@ (for-syntax (except-in syntax/parse id) racket/match unstable/syntax racket/base unstable/match - (private type-contract optimize) + (private type-contract) + (optimizer optimizer) (types utils convenience) (typecheck typechecker provide-handling tc-toplevel) (env type-name-env type-alias-env) diff --git a/collects/typed-scheme/utils/utils.rkt b/collects/typed-scheme/utils/utils.rkt index ad4f5e24..afed7b55 100644 --- a/collects/typed-scheme/utils/utils.rkt +++ b/collects/typed-scheme/utils/utils.rkt @@ -83,6 +83,7 @@ at least theoretically. (define-requirer env env-out) (define-requirer private private-out) (define-requirer types types-out) +(define-requirer optimizer optimizer-out) ;; run `h' last, but drop its return value (define-syntax-rule (reverse-begin h . forms) (begin0 (begin . forms) h)) From 8deff8c920c0c91b425f09deed4e74232f2c72df Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 8 Jul 2010 14:45:42 -0400 Subject: [PATCH 190/198] Refactoring of the optimizer. original commit: c3f46cc8a6512379ead3cf99cf94fe426bec3f5a --- collects/typed-scheme/optimizer/fixnum.rkt | 58 ++++ collects/typed-scheme/optimizer/float.rkt | 59 ++++ .../optimizer/inexact-complex.rkt | 134 ++++++++ collects/typed-scheme/optimizer/optimizer.rkt | 298 +++--------------- collects/typed-scheme/optimizer/utils.rkt | 64 ++++ collects/typed-scheme/typed-scheme.rkt | 2 +- 6 files changed, 352 insertions(+), 263 deletions(-) create mode 100644 collects/typed-scheme/optimizer/fixnum.rkt create mode 100644 collects/typed-scheme/optimizer/float.rkt create mode 100644 collects/typed-scheme/optimizer/inexact-complex.rkt create mode 100644 collects/typed-scheme/optimizer/utils.rkt diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt new file mode 100644 index 00000000..378015e2 --- /dev/null +++ b/collects/typed-scheme/optimizer/fixnum.rkt @@ -0,0 +1,58 @@ +#lang scheme + +(require syntax/parse + "../utils/utils.rkt" + (for-template scheme/base scheme/fixnum scheme/unsafe/ops) + (types abbrev type-table utils subtype) + (optimizer utils)) + +(provide (all-defined-out)) + +(define-syntax-class fixnum-opt-expr + (pattern e:expr + #:when (subtypeof? #'e -Fixnum) + #:with opt ((optimize) #'e))) +(define-syntax-class nonzero-fixnum-opt-expr + (pattern e:expr + #:when (or (isoftype? #'e -PositiveFixnum) (isoftype? #'e -NegativeFixnum)) + #:with opt ((optimize) #'e))) + +(define (mk-fixnum-tbl generic) + (mk-unsafe-tbl generic "fx~a" "unsafe-fx~a")) + +;; due to undefined behavior when results are out of the fixnum range, only some +;; fixnum operations can be optimized +;; the following must be closed on fixnums +(define binary-fixnum-ops + (dict-set + (dict-set + (dict-set + (dict-set + (dict-set + (dict-set + (mk-fixnum-tbl (list #'= #'<= #'< #'> #'>= #'min #'max)) + #'bitwise-and #'unsafe-fxand) + #'fxand #'unsafe-fxand) + #'bitwise-ior #'unsafe-fxior) + #'fxior #'unsafe-fxior) + #'bitwise-xor #'unsafe-fxxor) + #'fxxor #'unsafe-fxxor)) +(define-syntax-class fixnum-unary-op + (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) + (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) + (pattern i:id + #:when (dict-ref tbl #'i #f) + #:with unsafe (dict-ref tbl #'i))) + + +(define (optimize-finum-expr stx) + (syntax-parse stx #:literal-sets (kernel-literals) + [e:fixnum-opt-expr + (syntax/loc stx e.opt)])) diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt new file mode 100644 index 00000000..7b2ef5cb --- /dev/null +++ b/collects/typed-scheme/optimizer/float.rkt @@ -0,0 +1,59 @@ +#lang scheme/base + +(require syntax/parse + syntax/id-table racket/dict + (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops) + "../utils/utils.rkt" + (types abbrev type-table utils subtype) + (optimizer utils fixnum)) + +(provide (all-defined-out)) + +(define-syntax-class float-opt-expr + (pattern e:expr + #:when (subtypeof? #'e -Flonum) + #:with opt ((optimize) #'e))) +(define-syntax-class int-opt-expr + (pattern e:expr + #:when (subtypeof? #'e -Integer) + #:with opt ((optimize) #'e))) + +;; 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 + (pattern e:fixnum-opt-expr + #:with opt #'(unsafe-fx->fl e.opt)) + (pattern e:int-opt-expr + #:with opt #'(->fl e.opt)) + (pattern e:float-opt-expr + #:with opt #'e.opt)) + +(define (mk-float-tbl generic) + (mk-unsafe-tbl generic "fl~a" "unsafe-fl~a")) + +(define binary-float-ops + (mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max))) +(define binary-float-comps + (dict-set + (dict-set + (mk-float-tbl (list #'= #'<= #'< #'> #'>=)) + ;; not a comparison, but takes 2 floats and does not return a float, + ;; unlike binary-float-ops + #'make-rectangular #'unsafe-make-flrectangular) + #'make-flrectangular #'unsafe-make-flrectangular)) +(define unary-float-ops + (mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp + #'sqrt #'round #'floor #'ceiling #'truncate))) + +(define-syntax-class (float-op tbl) + (pattern i:id + #:when (dict-ref tbl #'i #f) + #:with unsafe (dict-ref tbl #'i))) + + +(define (optimize-float-expr stx) + (syntax-parse stx #:literal-sets (kernel-literals) + [e:float-opt-expr + (syntax/loc stx e.opt)])) diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt new file mode 100644 index 00000000..629d7756 --- /dev/null +++ b/collects/typed-scheme/optimizer/inexact-complex.rkt @@ -0,0 +1,134 @@ +#lang scheme/base + +(require syntax/parse + "../utils/utils.rkt" + (for-template scheme/base scheme/flonum scheme/unsafe/ops) + (types abbrev type-table utils subtype) + (optimizer utils float)) + +(provide (all-defined-out)) + + +(define-syntax-class inexact-complex-opt-expr + (pattern e:expr + #:when (isoftype? #'e -InexactComplex) + #:with opt ((optimize) #'e))) + +;; 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 (~var op (float-op binary-inexact-complex-ops)) (~or (~literal +) (~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 ...)))) + #`(op.unsafe #,o #,e))) + #`(imag-part #,(for/fold ((o #'c1.imag-part)) + ((e (syntax->list #'(c2.imag-part cs.imag-part ...)))) + #`(op.unsafe #,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 loop ([o1 #'c1.real-part] + [o2 #'c1.imag-part] + [e1 (syntax->list #'(c2.real-part cs.real-part ...))] + [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))] + [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) + (list* #`(#,(car is) + (unsafe-fl+ (unsafe-fl* #,o2 #,(car e1)) + (unsafe-fl* #,o1 #,(car e2)))) + #`(#,(car rs) + (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 (denominators ...) + (for/list + ([e1 (syntax->list #'(c2.real-part cs.real-part ...))] + [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]) + #`(#,(unboxed-gensym) (unsafe-fl+ (unsafe-fl* #,e1 #,e1) (unsafe-fl* #,e2 #,e2)))) + #:with (bindings ...) + (begin (log-optimization "unboxed binary inexact complex" #'op) + #`(c1.bindings ... c2.bindings ... cs.bindings ... ... denominators ... + ;; we want to bind the intermediate results to reuse them + ;; the final results are bound to real-part and imag-part + #,@(let loop ([o1 #'c1.real-part] + [o2 #'c1.imag-part] + [e1 (syntax->list #'(c2.real-part cs.real-part ...))] + [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))] + [d (map (lambda (x) (car (syntax-e x))) + (syntax->list #'(denominators ...)))] + [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 d) (cdr rs) (cdr is) + ;; complex division, imag part, then real part (reverse) + (list* #`(#,(car is) + (unsafe-fl/ (unsafe-fl- (unsafe-fl* #,o2 #,(car e1)) + (unsafe-fl* #,o1 #,(car e2))) + #,(car d))) + #`(#,(car rs) + (unsafe-fl/ (unsafe-fl+ (unsafe-fl* #,o1 #,(car e1)) + (unsafe-fl* #,o2 #,(car e2))) + #,(car d))) + res))))))) + (pattern e:expr + ;; can't work on inexact reals, which are a subtype of inexact + ;; complexes, so this has to be equality + #: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*))))) + +(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 binary-inexact-complex-ops + (mk-float-tbl (list #'+ #'- #'* #'/))) + + +(define (optimize-inexact-complex-expr e) + (syntax-parse e #:literal-sets (kernel-literals) + [e:inexact-complex-opt-expr + (syntax/loc stx e.opt)])) diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt index e21a8018..05518323 100644 --- a/collects/typed-scheme/optimizer/optimizer.rkt +++ b/collects/typed-scheme/optimizer/optimizer.rkt @@ -1,239 +1,15 @@ #lang scheme/base -(require syntax/parse (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for) - "../utils/utils.rkt" "../utils/tc-utils.rkt" unstable/match scheme/match unstable/syntax unstable/values - (rep type-rep) syntax/id-table racket/dict - (types abbrev type-table utils subtype)) -(provide optimize) +(require syntax/parse + syntax/id-table racket/dict + unstable/match scheme/match + (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for) + "../utils/utils.rkt" "../utils/tc-utils.rkt" + (rep type-rep) + (types abbrev type-table utils subtype) + (optimizer utils fixnum float inexact-complex)) -;; is the syntax object s's type a subtype of t? -(define (subtypeof s t) - (match (type-of s) - [(tc-result1: (== t (lambda (x y) (subtype y x)))) #t] [_ #f])) - - -(define-syntax-class float-opt-expr - (pattern e:opt-expr - #:when (subtypeof #'e -Flonum) - #:with opt #'e.opt)) -(define-syntax-class int-opt-expr - (pattern e:opt-expr - #:when (subtypeof #'e -Integer) - #:with opt #'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 - (pattern e:fixnum-opt-expr - #:with opt #'(unsafe-fx->fl e.opt)) - (pattern e:int-opt-expr - #:with opt #'(->fl e.opt)) - (pattern e:float-opt-expr - #:with opt #'e.opt)) - -(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern) - (for/fold ([h (make-immutable-free-id-table)]) ([g generic]) - (let ([f (format-id g safe-pattern g)] [u (format-id g unsafe-pattern g)]) - (dict-set (dict-set h g u) f u)))) - -(define (mk-float-tbl generic) - (mk-unsafe-tbl generic "fl~a" "unsafe-fl~a")) - -(define binary-float-ops - (mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max))) -(define binary-float-comps - (dict-set - (dict-set - (mk-float-tbl (list #'= #'<= #'< #'> #'>=)) - ;; not a comparison, but takes 2 floats and does not return a float, - ;; unlike binary-float-ops - #'make-rectangular #'unsafe-make-flrectangular) - #'make-flrectangular #'unsafe-make-flrectangular)) -(define unary-float-ops - (mk-float-tbl (list #'abs #'sin #'cos #'tan #'asin #'acos #'atan #'log #'exp - #'sqrt #'round #'floor #'ceiling #'truncate))) - -(define-syntax-class (float-op tbl) - (pattern i:id - #:when (dict-ref tbl #'i #f) - #:with unsafe (dict-ref tbl #'i))) - -;; 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) - (set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*)) - (format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*)) - -(define-syntax-class inexact-complex-opt-expr - (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (== -InexactComplex type-equal?)) #t] [_ #f]) - - #:with opt #'e.opt)) -;; 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 (~var op (float-op binary-inexact-complex-ops)) (~or (~literal +) (~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 ...)))) - #`(op.unsafe #,o #,e))) - #`(imag-part #,(for/fold ((o #'c1.imag-part)) - ((e (syntax->list #'(c2.imag-part cs.imag-part ...)))) - #`(op.unsafe #,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 loop ([o1 #'c1.real-part] - [o2 #'c1.imag-part] - [e1 (syntax->list #'(c2.real-part cs.real-part ...))] - [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))] - [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) - (list* #`(#,(car is) - (unsafe-fl+ (unsafe-fl* #,o2 #,(car e1)) - (unsafe-fl* #,o1 #,(car e2)))) - #`(#,(car rs) - (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 (denominators ...) - (for/list - ([e1 (syntax->list #'(c2.real-part cs.real-part ...))] - [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))]) - #`(#,(unboxed-gensym) (unsafe-fl+ (unsafe-fl* #,e1 #,e1) (unsafe-fl* #,e2 #,e2)))) - #:with (bindings ...) - (begin (log-optimization "unboxed binary inexact complex" #'op) - #`(c1.bindings ... c2.bindings ... cs.bindings ... ... denominators ... - ;; we want to bind the intermediate results to reuse them - ;; the final results are bound to real-part and imag-part - #,@(let loop ([o1 #'c1.real-part] - [o2 #'c1.imag-part] - [e1 (syntax->list #'(c2.real-part cs.real-part ...))] - [e2 (syntax->list #'(c2.imag-part cs.imag-part ...))] - [d (map (lambda (x) (car (syntax-e x))) - (syntax->list #'(denominators ...)))] - [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 d) (cdr rs) (cdr is) - ;; complex division, imag part, then real part (reverse) - (list* #`(#,(car is) - (unsafe-fl/ (unsafe-fl- (unsafe-fl* #,o2 #,(car e1)) - (unsafe-fl* #,o1 #,(car e2))) - #,(car d))) - #`(#,(car rs) - (unsafe-fl/ (unsafe-fl+ (unsafe-fl* #,o1 #,(car e1)) - (unsafe-fl* #,o2 #,(car e2))) - #,(car d))) - res))))))) - (pattern e:opt-expr - ;; can't work on inexact reals, which are a subtype of inexact - ;; complexes, so this has to be equality - #:when (match (type-of #'e) - [(tc-result1: (== -InexactComplex type-equal?)) #t] [_ #f]) - #:with e* (unboxed-gensym) - #:with real-part (unboxed-gensym) - #:with imag-part (unboxed-gensym) - #:with (bindings ...) - #'((e* e.opt) - (real-part (unsafe-flreal-part e*)) - (imag-part (unsafe-flimag-part e*))))) - -(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 binary-inexact-complex-ops - (mk-float-tbl (list #'+ #'- #'* #'/))) - -(define-syntax-class fixnum-opt-expr - (pattern e:opt-expr - #:when (subtypeof #'e -Fixnum) - #:with opt #'e.opt)) -(define-syntax-class nonzero-fixnum-opt-expr - (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (== -PositiveFixnum type-equal?)) #t] - [(tc-result1: (== -NegativeFixnum type-equal?)) #t] - [_ #f]) - #:with opt #'e.opt)) - -(define (mk-fixnum-tbl generic) - (mk-unsafe-tbl generic "fx~a" "unsafe-fx~a")) - -;; due to undefined behavior when results are out of the fixnum range, only some -;; fixnum operations can be optimized -;; the following must be closed on fixnums -(define binary-fixnum-ops - (dict-set - (dict-set - (dict-set - (dict-set - (dict-set - (dict-set - (mk-fixnum-tbl (list #'= #'<= #'< #'> #'>= #'min #'max)) - #'bitwise-and #'unsafe-fxand) - #'fxand #'unsafe-fxand) - #'bitwise-ior #'unsafe-fxior) - #'fxior #'unsafe-fxior) - #'bitwise-xor #'unsafe-fxxor) - #'fxxor #'unsafe-fxxor)) -(define-syntax-class fixnum-unary-op - (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) - (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) - (pattern i:id - #:when (dict-ref tbl #'i #f) - #:with unsafe (dict-ref tbl #'i))) +(provide optimize-top) (define-syntax-class pair-opt-expr @@ -272,39 +48,29 @@ (pattern e:opt-expr* #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f))) -(define *log-optimizations?* #f) -(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->datum stx) - kind) - #t)) - -;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments -(define (n-ary->binary op arg1 arg2 rest) - (for/fold ([o arg1]) - ([e (syntax->list #`(#,arg2 #,@rest))]) - #`(#,op #,o #,e))) (define-syntax-class opt-expr* #:literal-sets (kernel-literals) ;; interesting cases, where something is optimized (pattern (~and res (#%plain-app (~var op (float-op unary-float-ops)) f:float-opt-expr)) - #:when (subtypeof #'res -Flonum) + #:when (subtypeof? #'res -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 (~and res (#%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? #'res -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-opt-expr f2:float-opt-expr fs:float-opt-expr ...)) + (pattern (~and res (#%plain-app (~var op (float-op binary-float-comps)) + f1:float-opt-expr + f2:float-opt-expr + fs:float-opt-expr ...)) #:with opt (begin (log-optimization "binary float comp" #'op) (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) @@ -313,11 +79,16 @@ #:with opt (begin (log-optimization "unary fixnum" #'op) #'(op.unsafe n.opt))) - (pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops)) n1:fixnum-opt-expr n2:fixnum-opt-expr ns:fixnum-opt-expr ...) + (pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops)) + n1:fixnum-opt-expr + n2:fixnum-opt-expr + ns:fixnum-opt-expr ...) #:with opt (begin (log-optimization "binary fixnum" #'op) (n-ary->binary #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...)))) - (pattern (#%plain-app op:nonzero-fixnum-binary-op n1:fixnum-opt-expr n2:nonzero-fixnum-opt-expr) + (pattern (#%plain-app op:nonzero-fixnum-binary-op + n1:fixnum-opt-expr + n2:nonzero-fixnum-opt-expr) #:with opt (begin (log-optimization "binary nonzero fixnum" #'op) #'(op.unsafe n1.opt n2.opt))) @@ -326,11 +97,12 @@ #:with opt (begin (log-optimization "unary inexact complex" #'op) #'(op.unsafe n.opt))) - (pattern (~and exp (#%plain-app (~var op (float-op binary-inexact-complex-ops)) e:inexact-complex-opt-expr ...)) + (pattern (~and exp (#%plain-app (~var op (float-op binary-inexact-complex-ops)) + e:inexact-complex-opt-expr ...)) #:with exp*:unboxed-inexact-complex-opt-expr #'exp #:with opt (begin (log-optimization "unboxed inexact complex" #'exp) - (begin (set! *unboxed-gensym-counter* 0) + (begin (reset-unboxed-gensym) #'(let* (exp*.bindings ...) (unsafe-make-flrectangular exp*.real-part exp*.imag-part))))) @@ -438,17 +210,19 @@ (pattern other:expr #:with opt #'other)) -(define (optimize stx) +(define (optimize-top stx) (let ((port (if (and *log-optimizations?* *log-optimizatons-to-log-file?*) (open-output-file *optimization-log-file* #:exists 'append) (current-output-port)))) (begin0 - (parameterize ([current-output-port port]) - (syntax-parse stx #:literal-sets (kernel-literals) - [e:opt-expr - (syntax/loc stx e.opt)])) + (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) diff --git a/collects/typed-scheme/optimizer/utils.rkt b/collects/typed-scheme/optimizer/utils.rkt new file mode 100644 index 00000000..912b0184 --- /dev/null +++ b/collects/typed-scheme/optimizer/utils.rkt @@ -0,0 +1,64 @@ +#lang scheme/base + +(require unstable/match scheme/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) + (rep type-rep)) + +(provide log-optimization *log-optimizations?* *log-optimizatons-to-log-file?* *optimization-log-file* + subtypeof? isoftype? + mk-unsafe-tbl + n-ary->binary + unboxed-gensym reset-unboxed-gensym + optimize) + + +(define *log-optimizations?* #f) +(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->datum stx) + kind) + #t)) + +;; is the syntax object s's type a subtype of t? +(define (subtypeof? s t) + (match (type-of s) + [(tc-result1: (== t (lambda (x y) (subtype y x)))) #t] [_ #f])) +;; similar, but with type equality +(define (isoftype? s t) + (match (type-of s) + [(tc-result1: (== t type-equal?)) #t] [_ #f])) + +;; generates a table matching safe to unsafe promitives +(define (mk-unsafe-tbl generic safe-pattern unsafe-pattern) + (for/fold ([h (make-immutable-free-id-table)]) ([g generic]) + (let ([f (format-id g safe-pattern g)] [u (format-id g unsafe-pattern g)]) + (dict-set (dict-set h g u) f u)))) + +;; unlike their safe counterparts, unsafe binary operators can only take 2 arguments +(define (n-ary->binary op arg1 arg2 rest) + (for/fold ([o arg1]) + ([e (syntax->list #`(#,arg2 #,@rest))]) + #`(#,op #,o #,e))) + +;; 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) + (set! *unboxed-gensym-counter* (add1 *unboxed-gensym-counter*)) + (format-unique-id #'here "unboxed-gensym-~a" *unboxed-gensym-counter*)) +(define (reset-unboxed-gensym) + (set! *unboxed-gensym-counter* 0)) + +;; to avoid mutually recursive syntax classes +;; will be set to the actual optimization function at the entry point +;; of the optimizer +(define optimize (make-parameter #f)) diff --git a/collects/typed-scheme/typed-scheme.rkt b/collects/typed-scheme/typed-scheme.rkt index 9c246122..6063fdfa 100644 --- a/collects/typed-scheme/typed-scheme.rkt +++ b/collects/typed-scheme/typed-scheme.rkt @@ -44,7 +44,7 @@ [(optimized-body ...) ;; do we optimize? (if (optimize?) - (begin0 (map optimize (syntax->list #'transformed-body)) + (begin0 (map optimize-top (syntax->list #'transformed-body)) (do-time "Optimized")) #'transformed-body)]) ;; reconstruct the module with the extra code From a128800e24bf98eaf2c678d55285618aaa3ab2d5 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 8 Jul 2010 15:44:13 -0400 Subject: [PATCH 191/198] Pushed optimizations to auxiliary syntax classes. original commit: dbda43ac6ba5d7e001cde75b16e39fcf3f60b5e1 --- collects/typed-scheme/optimizer/fixnum.rkt | 45 +++-- collects/typed-scheme/optimizer/float.rkt | 83 +++++--- .../optimizer/inexact-complex.rkt | 28 ++- collects/typed-scheme/optimizer/list.rkt | 35 ++++ collects/typed-scheme/optimizer/optimizer.rkt | 183 ++---------------- collects/typed-scheme/optimizer/pair.rkt | 30 +++ collects/typed-scheme/optimizer/struct.rkt | 26 +++ collects/typed-scheme/optimizer/vector.rkt | 63 ++++++ 8 files changed, 271 insertions(+), 222 deletions(-) create mode 100644 collects/typed-scheme/optimizer/list.rkt create mode 100644 collects/typed-scheme/optimizer/pair.rkt create mode 100644 collects/typed-scheme/optimizer/struct.rkt create mode 100644 collects/typed-scheme/optimizer/vector.rkt diff --git a/collects/typed-scheme/optimizer/fixnum.rkt b/collects/typed-scheme/optimizer/fixnum.rkt index 378015e2..8959261e 100644 --- a/collects/typed-scheme/optimizer/fixnum.rkt +++ b/collects/typed-scheme/optimizer/fixnum.rkt @@ -6,16 +6,8 @@ (types abbrev type-table utils subtype) (optimizer utils)) -(provide (all-defined-out)) +(provide fixnum-expr fixnum-opt-expr) -(define-syntax-class fixnum-opt-expr - (pattern e:expr - #:when (subtypeof? #'e -Fixnum) - #:with opt ((optimize) #'e))) -(define-syntax-class nonzero-fixnum-opt-expr - (pattern e:expr - #:when (or (isoftype? #'e -PositiveFixnum) (isoftype? #'e -NegativeFixnum)) - #:with opt ((optimize) #'e))) (define (mk-fixnum-tbl generic) (mk-unsafe-tbl generic "fx~a" "unsafe-fx~a")) @@ -52,7 +44,34 @@ #:with unsafe (dict-ref tbl #'i))) -(define (optimize-finum-expr stx) - (syntax-parse stx #:literal-sets (kernel-literals) - [e:fixnum-opt-expr - (syntax/loc stx e.opt)])) +(define-syntax-class fixnum-expr + (pattern e:expr + #:when (subtypeof? #'e -Fixnum) + #:with opt ((optimize) #'e))) +(define-syntax-class nonzero-fixnum-expr + (pattern e:expr + #:when (or (isoftype? #'e -PositiveFixnum) (isoftype? #'e -NegativeFixnum)) + #:with opt ((optimize) #'e))) + +(define-syntax-class fixnum-opt-expr + (pattern (#%plain-app op:fixnum-unary-op n:fixnum-expr) + #:with opt + (begin (log-optimization "unary fixnum" #'op) + #'(op.unsafe n.opt))) + (pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops)) + n1:fixnum-expr + n2:fixnum-expr + ns:fixnum-expr ...) + #:with opt + (begin (log-optimization "binary fixnum" #'op) + (n-ary->binary #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...)))) + (pattern (#%plain-app op:nonzero-fixnum-binary-op + n1:fixnum-expr + n2:nonzero-fixnum-expr) + #:with opt + (begin (log-optimization "binary nonzero fixnum" #'op) + #'(op.unsafe n1.opt n2.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)))) diff --git a/collects/typed-scheme/optimizer/float.rkt b/collects/typed-scheme/optimizer/float.rkt index 7b2ef5cb..15675b37 100644 --- a/collects/typed-scheme/optimizer/float.rkt +++ b/collects/typed-scheme/optimizer/float.rkt @@ -2,38 +2,18 @@ (require syntax/parse syntax/id-table racket/dict - (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops) + (for-template scheme/base scheme/flonum scheme/unsafe/ops) "../utils/utils.rkt" (types abbrev type-table utils subtype) (optimizer utils fixnum)) -(provide (all-defined-out)) +(provide float-opt-expr float-op mk-float-tbl) -(define-syntax-class float-opt-expr - (pattern e:expr - #:when (subtypeof? #'e -Flonum) - #:with opt ((optimize) #'e))) -(define-syntax-class int-opt-expr - (pattern e:expr - #:when (subtypeof? #'e -Integer) - #:with opt ((optimize) #'e))) - -;; 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 - (pattern e:fixnum-opt-expr - #:with opt #'(unsafe-fx->fl e.opt)) - (pattern e:int-opt-expr - #:with opt #'(->fl e.opt)) - (pattern e:float-opt-expr - #:with opt #'e.opt)) (define (mk-float-tbl generic) (mk-unsafe-tbl generic "fl~a" "unsafe-fl~a")) -(define binary-float-ops +(define binary-float-ops (mk-float-tbl (list #'+ #'- #'* #'/ #'min #'max))) (define binary-float-comps (dict-set @@ -52,8 +32,57 @@ #:when (dict-ref tbl #'i #f) #:with unsafe (dict-ref tbl #'i))) +(define-syntax-class float-expr + (pattern e:expr + #:when (subtypeof? #'e -Flonum) + #:with opt ((optimize) #'e))) +(define-syntax-class int-expr + (pattern e:expr + #:when (subtypeof? #'e -Integer) + #:with opt ((optimize) #'e))) -(define (optimize-float-expr stx) - (syntax-parse stx #:literal-sets (kernel-literals) - [e:float-opt-expr - (syntax/loc stx 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 + (pattern e:fixnum-expr + #:with opt #'(unsafe-fx->fl e.opt)) + (pattern e:int-expr + #:with opt #'(->fl e.opt)) + (pattern e:float-expr + #: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) + #: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 ...)) + ;; if the result is a float, we can coerce integers to floats and optimize + #:when (subtypeof? #'res -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 ...)) + #:with opt + (begin (log-optimization "binary float comp" #'op) + (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.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 + (pattern (#%plain-app (~and op (~literal exact->inexact)) f:float-expr) + #:with opt + (begin (log-optimization "float to float" #'op) + #'f.opt))) diff --git a/collects/typed-scheme/optimizer/inexact-complex.rkt b/collects/typed-scheme/optimizer/inexact-complex.rkt index 629d7756..bdaaadc3 100644 --- a/collects/typed-scheme/optimizer/inexact-complex.rkt +++ b/collects/typed-scheme/optimizer/inexact-complex.rkt @@ -6,14 +6,9 @@ (types abbrev type-table utils subtype) (optimizer utils float)) -(provide (all-defined-out)) +(provide inexact-complex-opt-expr) -(define-syntax-class inexact-complex-opt-expr - (pattern e:expr - #:when (isoftype? #'e -InexactComplex) - #:with opt ((optimize) #'e))) - ;; 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 @@ -127,8 +122,21 @@ (define binary-inexact-complex-ops (mk-float-tbl (list #'+ #'- #'* #'/))) +(define-syntax-class inexact-complex-expr + (pattern e:expr + #:when (isoftype? #'e -InexactComplex) + #:with opt ((optimize) #'e))) -(define (optimize-inexact-complex-expr e) - (syntax-parse e #:literal-sets (kernel-literals) - [e:inexact-complex-opt-expr - (syntax/loc stx e.opt)])) +(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 (~var op (float-op binary-inexact-complex-ops)) + e:inexact-complex-expr ...)) + #:with exp*:unboxed-inexact-complex-opt-expr #'exp + #:with opt + (begin (log-optimization "unboxed inexact complex" #'exp) + (begin (reset-unboxed-gensym) + #'(let* (exp*.bindings ...) + (unsafe-make-flrectangular exp*.real-part exp*.imag-part)))))) diff --git a/collects/typed-scheme/optimizer/list.rkt b/collects/typed-scheme/optimizer/list.rkt new file mode 100644 index 00000000..272a21ed --- /dev/null +++ b/collects/typed-scheme/optimizer/list.rkt @@ -0,0 +1,35 @@ +#lang scheme/base + +(require syntax/parse + syntax/id-table racket/dict + unstable/match scheme/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)) + +(provide list-opt-expr) + + +(define-syntax-class list-expr + (pattern e:expr + #:when (match (type-of #'e) + [(tc-result1: (Listof: _)) #t] + [(tc-result1: (List: _)) #t] + [_ #f]) + #:with opt ((optimize) #'e))) + +(define-syntax-class list-opt-expr + ;; if we're iterating (with the for macros) over something we know is a list, + ;; we can generate code that would be similar to if in-list had been used + (pattern (#%plain-app op:id _ l) + #:when (id-from? #'op 'make-sequence 'racket/private/for) + #:with l*:list-expr #'l + #:with opt + (begin (log-optimization "in-list" #'op) + #'(let ((i l*.opt)) + (values unsafe-car unsafe-cdr i + (lambda (x) (not (null? x))) + (lambda (x) #t) + (lambda (x y) #t)))))) diff --git a/collects/typed-scheme/optimizer/optimizer.rkt b/collects/typed-scheme/optimizer/optimizer.rkt index 05518323..7e799542 100644 --- a/collects/typed-scheme/optimizer/optimizer.rkt +++ b/collects/typed-scheme/optimizer/optimizer.rkt @@ -2,192 +2,30 @@ (require syntax/parse syntax/id-table racket/dict - unstable/match scheme/match (for-template scheme/base scheme/flonum scheme/fixnum scheme/unsafe/ops racket/private/for) - "../utils/utils.rkt" "../utils/tc-utils.rkt" - (rep type-rep) + "../utils/utils.rkt" (types abbrev type-table utils subtype) - (optimizer utils fixnum float inexact-complex)) + (optimizer utils fixnum float inexact-complex vector pair list struct)) (provide optimize-top) -(define-syntax-class pair-opt-expr - (pattern e:opt-expr - #:when (match (type-of #'e) ; type of the operand - [(tc-result1: (Pair: _ _)) #t] - [_ #f]) - #:with opt #'e.opt)) - -(define-syntax-class pair-unary-op - (pattern (~literal car) #:with unsafe #'unsafe-car) - (pattern (~literal cdr) #:with unsafe #'unsafe-cdr)) - -(define-syntax-class vector-opt-expr - (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (HeterogenousVector: _)) #t] - [_ #f]) - #:with opt #'e.opt)) - -(define-syntax-class vector-op - ;; 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!)) - -(define-syntax-class list-opt-expr - (pattern e:opt-expr - #:when (match (type-of #'e) - [(tc-result1: (Listof: _)) #t] - [(tc-result1: (List: _)) #t] - [_ #f]) - #:with opt #'e.opt)) - - (define-syntax-class opt-expr (pattern e:opt-expr* #:with opt (syntax-recertify #'e.opt this-syntax (current-code-inspector) #f))) - (define-syntax-class opt-expr* #:literal-sets (kernel-literals) ;; interesting cases, where something is optimized - (pattern (~and res (#%plain-app (~var op (float-op unary-float-ops)) f:float-opt-expr)) - #:when (subtypeof? #'res -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 ...)) - ;; if the result is a float, we can coerce integers to floats and optimize - #:when (subtypeof? #'res -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-opt-expr - f2:float-opt-expr - fs:float-opt-expr ...)) - #:with opt - (begin (log-optimization "binary float comp" #'op) - (n-ary->binary #'op.unsafe #'f1.opt #'f2.opt #'(fs.opt ...)))) - - (pattern (#%plain-app op:fixnum-unary-op n:fixnum-opt-expr) - #:with opt - (begin (log-optimization "unary fixnum" #'op) - #'(op.unsafe n.opt))) - (pattern (#%plain-app (~var op (fixnum-op binary-fixnum-ops)) - n1:fixnum-opt-expr - n2:fixnum-opt-expr - ns:fixnum-opt-expr ...) - #:with opt - (begin (log-optimization "binary fixnum" #'op) - (n-ary->binary #'op.unsafe #'n1.opt #'n2.opt #'(ns.opt ...)))) - (pattern (#%plain-app op:nonzero-fixnum-binary-op - n1:fixnum-opt-expr - n2:nonzero-fixnum-opt-expr) - #:with opt - (begin (log-optimization "binary nonzero fixnum" #'op) - #'(op.unsafe n1.opt n2.opt))) - - (pattern (#%plain-app op:inexact-complex-unary-op n:inexact-complex-opt-expr) - #:with opt - (begin (log-optimization "unary inexact complex" #'op) - #'(op.unsafe n.opt))) - (pattern (~and exp (#%plain-app (~var op (float-op binary-inexact-complex-ops)) - e:inexact-complex-opt-expr ...)) - #:with exp*:unboxed-inexact-complex-opt-expr #'exp - #:with opt - (begin (log-optimization "unboxed inexact complex" #'exp) - (begin (reset-unboxed-gensym) - #'(let* (exp*.bindings ...) - (unsafe-make-flrectangular exp*.real-part exp*.imag-part))))) + (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:vector-opt-expr #:with opt #'e.opt) + (pattern e:pair-opt-expr #:with opt #'e.opt) + (pattern e:list-opt-expr #:with opt #'e.opt) + (pattern e:struct-opt-expr #:with opt #'e.opt) - (pattern (#%plain-app (~and op (~literal exact->inexact)) n:fixnum-opt-expr) - #:with opt - (begin (log-optimization "fixnum to float" #'op) - #'(unsafe-fx->fl n.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-opt-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 - (pattern (#%plain-app (~and op (~literal exact->inexact)) f:float-opt-expr) - #:with opt - (begin (log-optimization "float to float" #'op) - #'f.opt)) - - (pattern (#%plain-app op:pair-unary-op p:pair-opt-expr) - #:with opt - (begin (log-optimization "unary pair" #'op) - #'(op.unsafe p.opt))) - - ;; 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-opt-expr) - #:with opt - (begin (log-optimization "known-length vector" #'op) - (match (type-of #'v) - [(tc-result1: (HeterogenousVector: es)) - #`(begin v.opt #,(length es))]))) ; v may have side effects - ;; we can optimize vector-length on all vectors. - ;; since the program typechecked, we know the arg is a vector. - ;; we can optimize no matter what. - (pattern (#%plain-app (~and op (~literal vector-length)) v:opt-expr) - #:with opt - (begin (log-optimization "vector" #'op) - #'(unsafe-vector*-length v.opt))) - ;; same for flvector-length - (pattern (#%plain-app (~and op (~literal flvector-length)) v:opt-expr) - #:with opt - (begin (log-optimization "flvector" #'op) - #'(unsafe-flvector-length v.opt))) - ;; 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) - (pattern (#%plain-app op:vector-op v:vector-opt-expr i:opt-expr new:opt-expr ...) - #:when (let ((len (match (type-of #'v) - [(tc-result1: (HeterogenousVector: es)) (length es)] - [_ 0])) - (ival (or (syntax-parse #'i [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) - (match (type-of #'i) - [(tc-result1: (Value: (? number? i))) i] - [_ #f])))) - (and (integer? ival) (exact? ival) (<= 0 ival (sub1 len)))) - #:with opt - (begin (log-optimization "vector" #'op) - #'(op.unsafe v.opt i.opt new.opt ...))) - - ;; 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) - #:when (id-from? #'op 'make-sequence 'racket/private/for) - #:with l*:list-opt-expr #'l - #:with opt - (begin (log-optimization "in-list" #'op) - #'(let ((i l*.opt)) - (values unsafe-car unsafe-cdr i - (lambda (x) (not (null? x))) - (lambda (x) #t) - (lambda (x y) #t))))) - - ;; we can always optimize struct accessors and mutators - ;; if they typecheck, they're safe - (pattern (#%plain-app op:id s:opt-expr v:opt-expr ...) - #:when (or (struct-accessor? #'op) (struct-mutator? #'op)) - #:with opt - (let ([idx (struct-fn-idx #'op)]) - (if (struct-accessor? #'op) - (begin (log-optimization "struct ref" #'op) - #`(unsafe-struct-ref s.opt #,idx)) - (begin (log-optimization "struct set" #'op) - #`(unsafe-struct-set! s.opt #,idx v.opt ...))))) - ;; boring cases, just recur down (pattern (#%plain-lambda formals e:opt-expr ...) #:with opt #'(#%plain-lambda formals e.opt ...)) @@ -205,7 +43,8 @@ #:when (ormap (lambda (k) (free-identifier=? k #'kw)) (list #'if #'begin #'begin0 #'set! #'#%plain-app #'#%app #'#%expression #'#%variable-reference #'with-continuation-mark)) - #:with (expr*:opt-expr ...) #'(expr ...) ; we don't want to optimize in the cases that don't match the #:when clause + ;; 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 ...)) (pattern other:expr #:with opt #'other)) diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt new file mode 100644 index 00000000..0ac9a77a --- /dev/null +++ b/collects/typed-scheme/optimizer/pair.rkt @@ -0,0 +1,30 @@ +#lang scheme/base + +(require syntax/parse + syntax/id-table racket/dict + unstable/match scheme/match + (for-template scheme/base scheme/unsafe/ops) + "../utils/utils.rkt" + (rep type-rep) + (types abbrev type-table utils subtype) + (optimizer utils)) + +(provide pair-opt-expr) + + +(define-syntax-class pair-unary-op + (pattern (~literal car) #:with unsafe #'unsafe-car) + (pattern (~literal cdr) #:with unsafe #'unsafe-cdr)) + +(define-syntax-class pair-expr + (pattern e:expr + #:when (match (type-of #'e) ; type of the operand + [(tc-result1: (Pair: _ _)) #t] + [_ #f]) + #:with opt ((optimize) #'e))) + +(define-syntax-class pair-opt-expr + (pattern (#%plain-app op:pair-unary-op p:pair-expr) + #:with opt + (begin (log-optimization "unary pair" #'op) + #'(op.unsafe p.opt)))) diff --git a/collects/typed-scheme/optimizer/struct.rkt b/collects/typed-scheme/optimizer/struct.rkt new file mode 100644 index 00000000..575b985e --- /dev/null +++ b/collects/typed-scheme/optimizer/struct.rkt @@ -0,0 +1,26 @@ +#lang scheme/base + +(require syntax/parse + syntax/id-table racket/dict + unstable/match scheme/match + (for-template scheme/base scheme/unsafe/ops) + "../utils/utils.rkt" + (rep type-rep) + (types abbrev type-table utils subtype) + (optimizer utils)) + +(provide struct-opt-expr) + +(define-syntax-class struct-opt-expr + ;; we can always optimize struct accessors and mutators + ;; if they typecheck, they're safe + (pattern (#%plain-app op:id s:expr v:expr ...) + #:when (or (struct-accessor? #'op) (struct-mutator? #'op)) + #:with opt + (let ([idx (struct-fn-idx #'op)]) + (if (struct-accessor? #'op) + (begin (log-optimization "struct ref" #'op) + #`(unsafe-struct-ref #,((optimize) #'s) #,idx)) + (begin (log-optimization "struct set" #'op) + #`(unsafe-struct-set! #,((optimize) #'s) #,idx + #,@(map (optimize) (syntax->list #'(v ...))))))))) diff --git a/collects/typed-scheme/optimizer/vector.rkt b/collects/typed-scheme/optimizer/vector.rkt new file mode 100644 index 00000000..10144147 --- /dev/null +++ b/collects/typed-scheme/optimizer/vector.rkt @@ -0,0 +1,63 @@ +#lang scheme/base + +(require syntax/parse + unstable/match scheme/match + (for-template scheme/base scheme/flonum scheme/unsafe/ops) + "../utils/utils.rkt" + (rep type-rep) + (types abbrev type-table utils subtype) + (optimizer utils)) + +(provide vector-opt-expr) + + +(define-syntax-class vector-op + ;; 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!)) + +(define-syntax-class vector-expr + (pattern e:expr + #:when (match (type-of #'e) + [(tc-result1: (HeterogenousVector: _)) #t] + [_ #f]) + #:with opt ((optimize) #'e))) + +(define-syntax-class vector-opt-expr + ;; 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) + (match (type-of #'v) + [(tc-result1: (HeterogenousVector: es)) + #`(begin v.opt #,(length es))]))) ; v may have side effects + ;; we can optimize vector-length on all vectors. + ;; since the program typechecked, we know the arg is a vector. + ;; 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)))) + ;; same for flvector-length + (pattern (#%plain-app (~and op (~literal flvector-length)) v:expr) + #:with opt + (begin (log-optimization "flvector" #'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) + (pattern (#%plain-app op:vector-op v:vector-expr i:expr new:expr ...) + #:when (let ((len (match (type-of #'v) + [(tc-result1: (HeterogenousVector: es)) (length es)] + [_ 0])) + (ival (or (syntax-parse #'i [((~literal quote) i:number) (syntax-e #'i)] [_ #f]) + (match (type-of #'i) + [(tc-result1: (Value: (? number? i))) i] + [_ #f])))) + (and (integer? ival) (exact? ival) (<= 0 ival (sub1 len)))) + #:with opt + (begin (log-optimization "vector" #'op) + #`(op.unsafe v.opt #,((optimize) #'i) + #,@(map (optimize) (syntax->list #'(new ...))))))) From 06afbef56f00a854211a2a5d7379154a00af4831 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 8 Jul 2010 14:46:12 -0400 Subject: [PATCH 192/198] Removed a stray TODO comment. original commit: 8505bd8bca25f9352eca5ad8d8a009bd6fe65a68 --- collects/typed-scheme/typecheck/tc-app.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index 5215073c..f00a8e29 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -377,7 +377,7 @@ [(tc-result1: (? needs-resolving? e) f o) (loop (ret (resolve-once e) f o))] [v-ty - (let ([arg-tys (list v-ty e-t)]) ;; TODO problem is that 2 rec types are not equal, but why? + (let ([arg-tys (list v-ty e-t)]) (tc/funapp #'op #'(v e) (single-value #'op) arg-tys expected))])))] [(#%plain-app (~and op (~or (~literal vector-set!) (~literal unsafe-vector-set!) (~literal unsafe-vector*-set!))) v e:expr val:expr) (let ([e-t (single-value #'e)]) From 87bf9dc23d8152c352163c0cccdabf03b2f30c2a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 8 Jul 2010 14:33:41 -0400 Subject: [PATCH 193/198] generalize inferred types for invariant positions original commit: 898c92eb1e6b476a8511d4d4be2e9b962e147d5e --- collects/typed-scheme/infer/infer-unit.rkt | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 33e2f23c..0877f8cf 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -520,14 +520,19 @@ ;; variable: Symbol - variable to use instead, if v was a temp var for idx extension (define (constraint->type v h #:variable [variable #f]) (match v - [(struct c (S X T)) + [(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) (evcase var [Constant S] [Covariant S] [Contravariant T] - [Invariant S]))])) + [Invariant + (let ([gS (generalize S)]) + (printf "Inv var: ~a ~a ~a ~a\n" v S gS T) + (if (subtype gS T) + gS + S))]))])) ;; Since we don't add entries to the empty cset for index variables (since there is no ;; widest constraint, due to dcon-exacts), we must add substitutions here if no constraint ;; was found. If we're at this point and had no other constraints, then adding the From ac2e4153b0b2c82a1d47f0b03f4a4eb6ff73c50a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 8 Jul 2010 16:11:46 -0400 Subject: [PATCH 194/198] add `make-constant' original commit: c6fb95d44d2869baa2f53f3f8dba04b19620da81 --- collects/typed-scheme/rep/free-variance.rkt | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/rep/free-variance.rkt b/collects/typed-scheme/rep/free-variance.rkt index 3e9471d9..db8f0e63 100644 --- a/collects/typed-scheme/rep/free-variance.rkt +++ b/collects/typed-scheme/rep/free-variance.rkt @@ -6,7 +6,7 @@ (provide Covariant Contravariant Invariant Constant Dotted combine-frees flip-variances without-below unless-in-table - fix-bound make-invariant variance?) + fix-bound make-invariant make-constant variance?) ;; this file contains support for calculating the free variables/indexes of types ;; actual computation is done in rep-utils.rkt and type-rep.rkt @@ -61,6 +61,10 @@ (for/hasheq ([(k v) (in-hash vs)]) (values k Invariant))) +(define (make-constant vs) + (for/hasheq ([(k v) (in-hash vs)]) + (values k Constant))) + (define (without-below n frees) (for/hasheq ([(k v) (in-hash frees)] #:when (>= k n)) From d3be8100a0c4506693101de50b177cd0e50325ee Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 8 Jul 2010 16:13:13 -0400 Subject: [PATCH 195/198] add variance helper functions original commit: a84796d8d7c7696ee635308ebf173c375466ebb3 --- collects/typed-scheme/rep/type-rep.rkt | 28 +++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 203fb4bd..f942dc8b 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/trace scheme/match mzlib/etc scheme/contract unstable/debug (for-syntax scheme/base syntax/parse)) @@ -63,6 +63,32 @@ (map type-rec-id rands) stx)]) +(define (get-variances t num-rands) + (match t + [(Name: v) (error 'fail)] + [(Poly: n scope) + (let ([t (free-idxs* scope)]) + (for/list ([i (in-range n)]) + (hash-ref t i)))] + [(PolyDots: n scope) + (let ([t (free-idxs* scope)] + [base-count (sub1 n)] + [extras (max 0 (- n num-rands))]) + (append + ;; variances of the fixed arguments + (for/list ([i (in-range base-count)]) + (hash-ref t i)) + ;; variance of the dotted arguments + (for/list ([i (in-range extras)]) + (hash-ref t n))))])) + +(define (apply-variance v tbl) + (evcase v + [(Constant) (make-constant tbl)] + [(Covariant) tbl] + [(Invariant) (make-invariant tbl)] + [(Contravariant) (flip-variances tbl)])) + ;; left and right are Types (dt Pair ([left Type/c] [right Type/c]) [#:key 'pair]) From e103e44bc185671c17e25f13e23e11e2bc7391ec Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 9 Jul 2010 13:50:47 -0400 Subject: [PATCH 196/198] Fix missing unquote original commit: d030d0631d8cb77888ba8a53843b0fb8e4b4c0dc --- collects/typed-scheme/env/init-envs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt index caed2eb2..d9a3729c 100644 --- a/collects/typed-scheme/env/init-envs.rkt +++ b/collects/typed-scheme/env/init-envs.rkt @@ -25,7 +25,7 @@ [(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))] [(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))] [(Name: stx) `(make-Name (quote-syntax ,stx))] - [(fld: t acc mut) `(make-fld ,(sub t) (quote-syntax acc) ,mut)] + [(fld: t acc mut) `(make-fld ,(sub t) (quote-syntax ,acc) ,mut)] [(Struct: name parent flds proc poly? pred-id cert maker-id) `(make-Struct ,(sub name) ,(sub parent) ,(sub flds) ,(sub proc) ,(sub poly?) From 91d6ac64d10e0002c282767fc5a97dee7e7214f6 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 9 Jul 2010 14:06:46 -0400 Subject: [PATCH 197/198] remove debugging printf original commit: e28b60e44fde524c520c62f3fe54b9f6dac04b9d --- collects/typed-scheme/infer/infer-unit.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 0877f8cf..e5fff323 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -529,7 +529,7 @@ [Contravariant T] [Invariant (let ([gS (generalize S)]) - (printf "Inv var: ~a ~a ~a ~a\n" v S gS T) + ;(printf "Inv var: ~a ~a ~a ~a\n" v S gS T) (if (subtype gS T) gS S))]))])) From 7477ced0dc1de6f7c728866664df489295155723 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 10 Jul 2010 09:52:47 -0500 Subject: [PATCH 198/198] rewrote an ->d contract so that it would work with a let*-style scoping original commit: 41cfcbe862d48722d0efef76d08b14b0ec428498 --- collects/typed-scheme/rep/filter-rep.rkt | 27 +++++++++++------------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/collects/typed-scheme/rep/filter-rep.rkt b/collects/typed-scheme/rep/filter-rep.rkt index 0040f414..1fbd6952 100644 --- a/collects/typed-scheme/rep/filter-rep.rkt +++ b/collects/typed-scheme/rep/filter-rep.rkt @@ -3,11 +3,9 @@ (require scheme/match scheme/contract) (require "rep-utils.rkt" "free-variance.rkt") -(define Filter/c - (flat-named-contract - 'Filter - (λ (e) - (and (Filter? e) (not (NoFilter? e)) (not (FilterSet? e)))))) +(define (Filter/c-predicate? e) + (and (Filter? e) (not (NoFilter? e)) (not (FilterSet? e)))) +(define Filter/c (flat-named-contract 'Filter Filter/c-predicate?)) (define FilterSet/c (flat-named-contract @@ -48,17 +46,16 @@ (combine-frees (map free-idxs* fs))]) (df FilterSet (thn els) - [#:contract (->d ([t (cond [(Bot? t) - Bot?] - [(Bot? e) - Top?] - [else Filter/c])] - [e (cond [(Bot? e) - Bot?] - [(Bot? t) - Top?] - [else Filter/c])]) + [#:contract (->d ([t any/c] + [e any/c]) (#:syntax [stx #f]) + #:pre-cond + (and (cond [(Bot? t) #t] + [(Bot? e) (Top? t)] + [else (Filter/c-predicate? t)]) + (cond [(Bot? e) #t] + [(Bot? t) (Top? e)] + [else (Filter/c-predicate? e)])) [result FilterSet?])] [#:fold-rhs (*FilterSet (filter-rec-id thn) (filter-rec-id els))])