From e9e54d41a81db8d3eae8ba4857c53443a8ce38c8 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sat, 26 Jan 2013 15:45:06 -0800 Subject: [PATCH 1/2] Do not update subtype and resolve caches when subtyping. Closes PR13412. original commit: 13ff5883fe097f8b37e6a7663e3e0d8baf8c466b --- collects/tests/typed-racket/succeed/pr13412.rkt | 12 ++++++++++++ collects/typed-racket/types/current-seen.rkt | 13 +++++++++++++ collects/typed-racket/types/resolve.rkt | 4 ++-- collects/typed-racket/types/subtype.rkt | 15 ++++----------- 4 files changed, 31 insertions(+), 13 deletions(-) create mode 100644 collects/tests/typed-racket/succeed/pr13412.rkt create mode 100644 collects/typed-racket/types/current-seen.rkt diff --git a/collects/tests/typed-racket/succeed/pr13412.rkt b/collects/tests/typed-racket/succeed/pr13412.rkt new file mode 100644 index 00000000..387e3283 --- /dev/null +++ b/collects/tests/typed-racket/succeed/pr13412.rkt @@ -0,0 +1,12 @@ +#lang typed/racket + +(define-type (Tree A) (U (Listof A) (node A))) +(struct: (A) node ([val : A] + [left : (Tree A)] + [right : (Tree A)])) + +(: tree-set (All (A) (A (Tree A) -> (Tree A)))) +(define (tree-set y t) + (cond [(node? t) (node y (node-left t) (node-right t))] + [else (list y)])) + diff --git a/collects/typed-racket/types/current-seen.rkt b/collects/typed-racket/types/current-seen.rkt new file mode 100644 index 00000000..2268ab75 --- /dev/null +++ b/collects/typed-racket/types/current-seen.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require "../utils/utils.rkt") +(require (rep type-rep)) + +(provide (all-defined-out)) + +(define current-seen (make-parameter null)) +(define (currently-subtyping?) (not (null? (current-seen)))) + +(define (seen-before s t) (cons (Type-seq s) (Type-seq t))) +(define (remember s t A) (cons (seen-before s t) A)) +(define (seen? s t) (member (seen-before s t) (current-seen))) + diff --git a/collects/typed-racket/types/resolve.rkt b/collects/typed-racket/types/resolve.rkt index e1be521e..11d0a95b 100644 --- a/collects/typed-racket/types/resolve.rkt +++ b/collects/typed-racket/types/resolve.rkt @@ -4,7 +4,7 @@ (require (rep type-rep rep-utils free-variance) (env type-name-env) (utils tc-utils) - (types utils) + (types utils current-seen) racket/match racket/contract racket/format) @@ -82,7 +82,7 @@ [(App: r r* s) (resolve-app r r* s)] [(Name: _) (resolve-name t)])]) - (when r* + (when (and r* (not (currently-subtyping?))) (hash-set! resolver-cache seq r*)) r*))) diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index 8770fe09..80b88c4b 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -2,7 +2,7 @@ (require (except-in "../utils/utils.rkt" infer) (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) - (types utils resolve base-abbrev numeric-tower substitute) + (types utils resolve base-abbrev numeric-tower substitute current-seen) (env type-name-env) racket/match unstable/match racket/function @@ -24,14 +24,6 @@ (syntax-rules () [(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))])) -;; data structures for remembering things on recursive calls -(define (empty-set) '()) - -(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)) -(define (seen? s t) (member (seen-before s t) (current-seen))) (define subtype-cache (make-hash)) (define (cache-types s t) @@ -54,7 +46,8 @@ (define result (handle-failure (and (subtype* (current-seen) s t) #t))) ;(printf "subtype cache miss ~a ~a\n" s t) result) - (hash-ref! subtype-cache k new-val)) + ((if (currently-subtyping?) hash-ref hash-ref!) + subtype-cache k new-val)) ;; are all the s's subtypes of all the t's? ;; [type] [type] -> boolean @@ -162,7 +155,7 @@ (define (subtypes/varargs args dom rst) (with-handlers ([exn:subtype? (lambda _ #f)]) - (subtypes*/varargs (empty-set) args dom rst))) + (subtypes*/varargs null args dom rst))) (define (subtypes*/varargs A0 argtys dom rst) (let loop-varargs ([dom dom] [argtys argtys] [A A0]) From dc40fa31e8de48a47f844ffd075a57419f9e2b64 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sun, 27 Jan 2013 11:17:45 -0800 Subject: [PATCH 2/2] Type check with expected type when checking recursive loops. Closes PR12678. original commit: 3c02bb1abbe0d8965c2cd70649ebb1357499a3ee --- collects/tests/typed-racket/succeed/pr12678.rkt | 9 +++++++++ collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt | 4 ++-- 2 files changed, 11 insertions(+), 2 deletions(-) create mode 100644 collects/tests/typed-racket/succeed/pr12678.rkt diff --git a/collects/tests/typed-racket/succeed/pr12678.rkt b/collects/tests/typed-racket/succeed/pr12678.rkt new file mode 100644 index 00000000..d83186f3 --- /dev/null +++ b/collects/tests/typed-racket/succeed/pr12678.rkt @@ -0,0 +1,9 @@ +#lang typed/racket + +(define: memo : (HashTable Natural String) (make-immutable-hash empty)) +(define strs '("Hello" "Goodbye")) + +(for/fold: : (HashTable Natural String) + ([memo : (HashTable Natural String) (make-immutable-hash empty)]) + ([i : Natural (in-naturals)] [str : String (in-list strs)]) + (hash-set memo i str)) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt index ba802a11..47852f84 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt @@ -6,7 +6,7 @@ syntax/parse racket/match racket/list syntax/parse/experimental/reflect unstable/sequence - (typecheck signatures tc-funapp check-below find-annotation ) + (typecheck signatures tc-funapp find-annotation) (types abbrev utils generalize type-table) (private type-annotation) (rep type-rep) @@ -98,7 +98,7 @@ (let* ([infer-t (or (type-annotation f #:infer #t) (find-annotation #'(begin . body*) f))]) (if infer-t - (check-below (tc-expr/t ac) infer-t) + (tc-expr/check/t ac (ret infer-t)) (generalize (tc-expr/t ac)))))]) (add-typeof-expr lam (tc/rec-lambda/check form args body lp ts expected)) expected)]))