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)