From 6d73aa7b4d99c932b00e8f83d1ce6162e4c78139 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 31 Aug 2012 17:29:33 -0400 Subject: [PATCH] Track mutable variables across modules. original commit: eed93825abcedc07570b4a185b88ad30f424cf0f --- .../fail/other-module-mutation.rkt | 25 +++++++++++++++++++ .../special-env-typecheck-tests.rkt | 6 ++--- .../unit-tests/typecheck-tests.rkt | 10 ++++---- collects/typed-racket/env/init-envs.rkt | 9 ++++++- collects/typed-racket/env/lexical-env.rkt | 3 ++- collects/typed-racket/env/mvar-env.rkt | 13 ++++++++++ .../typed-racket/optimizer/unboxed-let.rkt | 2 +- .../typed-racket/private/type-annotation.rkt | 2 +- collects/typed-racket/tc-setup.rkt | 6 ++--- .../typed-racket/typecheck/tc-toplevel.rkt | 3 ++- collects/typed-racket/types/abbrev.rkt | 1 + collects/typed-racket/utils/tc-utils.rkt | 6 ----- 12 files changed, 64 insertions(+), 22 deletions(-) create mode 100644 collects/tests/typed-racket/fail/other-module-mutation.rkt create mode 100644 collects/typed-racket/env/mvar-env.rkt diff --git a/collects/tests/typed-racket/fail/other-module-mutation.rkt b/collects/tests/typed-racket/fail/other-module-mutation.rkt new file mode 100644 index 00000000..22cd7204 --- /dev/null +++ b/collects/tests/typed-racket/fail/other-module-mutation.rkt @@ -0,0 +1,25 @@ +#lang racket/load + +(module mutator typed/racket + (define: y : Integer 0) + + (: set-y! (Integer -> Void)) + (define (set-y! v) + (set! y v)) + + (provide y set-y!)) + +(module user typed/racket + (require 'mutator) + + (: foo (Zero -> Zero)) + (define (foo y) + (printf "(foo ~v)~n" y) + y) + + (cond [(zero? y) (set-y! 10) + (foo y)] + [else y])) + +(require 'user) + diff --git a/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt index 6c7e0e57..37904f64 100644 --- a/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt @@ -17,7 +17,7 @@ racket/file racket/port (for-syntax syntax/kerncase syntax/parse racket/syntax (types abbrev numeric-tower utils) - (utils mutated-vars) + (utils mutated-vars) (env mvar-env) (utils tc-utils) (typecheck typechecker)) typed-racket/base-env/prims typed-racket/base-env/base-types @@ -34,8 +34,8 @@ (quasisyntax/loc stx (check-tc-result-equal? (format "~a ~a" #,(syntax-line stx) 'a) #,(let ([ex (local-expand #'a 'expression null)]) - (parameterize ([mutated-vars (find-mutated-vars ex)]) - (tc-expr ex))) + (find-mutated-vars ex mvar-env) + (tc-expr ex)) #,(syntax-local-eval #'b)))])) (define (typecheck-special-tests) diff --git a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt index 4b136656..cb5650ef 100644 --- a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -21,7 +21,7 @@ [-> t:->]) (utils tc-utils utils) (utils mutated-vars) - (env type-name-env type-env-structs init-envs) + (env type-name-env type-env-structs init-envs mvar-env) rackunit rackunit/text-ui syntax/parse (for-syntax (utils tc-utils) racket/file racket/port @@ -75,8 +75,8 @@ [current-namespace (namespace-anchor->namespace anch)] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) - (parameterize ([mutated-vars (find-mutated-vars ex)]) - (values (lambda () (tc-expr ex)) ex))))])) + (find-mutated-vars ex mvar-env) + (values (lambda () (tc-expr ex)) ex)))])) (define-syntax (tc-expr/expand stx) (syntax-case stx () @@ -85,8 +85,8 @@ [current-namespace (namespace-anchor->namespace anch)] [orig-module-stx (quote-syntax e)]) (let ([ex (expand 'e)]) - (parameterize ([mutated-vars (find-mutated-vars ex)]) - (tc-expr ex))))])) + (find-mutated-vars ex mvar-env) + (tc-expr ex)))])) ;; check that an expression typechecks correctly (define-syntax (tc-e stx) diff --git a/collects/typed-racket/env/init-envs.rkt b/collects/typed-racket/env/init-envs.rkt index bc628182..5849288d 100644 --- a/collects/typed-racket/env/init-envs.rkt +++ b/collects/typed-racket/env/init-envs.rkt @@ -5,12 +5,13 @@ "global-env.rkt" "type-name-env.rkt" "type-alias-env.rkt" + "mvar-env.rkt" (rep type-rep object-rep filter-rep rep-utils) (for-template (rep type-rep object-rep filter-rep) (types union abbrev) racket/shared racket/base) (types abbrev) - racket/syntax + racket/syntax racket/dict mzlib/pconvert racket/match) (define (initialize-type-name-env initial-type-names) @@ -102,5 +103,11 @@ (booleans-as-true/false #f)) #`(begin #,@(filter values (type-env-map f))))) +(define (mvar-env-init-code mvar-env) + (define (f id v) + (and v (bound-in-this-module id) + #`(register-mutated-var #'#,id))) + #`(begin #,@(filter values (dict-map mvar-env f)))) + diff --git a/collects/typed-racket/env/lexical-env.rkt b/collects/typed-racket/env/lexical-env.rkt index d977186e..b34e0532 100644 --- a/collects/typed-racket/env/lexical-env.rkt +++ b/collects/typed-racket/env/lexical-env.rkt @@ -10,11 +10,12 @@ "type-env-structs.rkt" "global-env.rkt" "../types/kw-types.rkt" + "mvar-env.rkt" syntax/id-table racket/keyword-transform racket/list (for-syntax syntax/parse syntax/parse/experimental/contract racket/base) (only-in racket/contract ->* -> or/c any/c listof cons/c) - (utils tc-utils mutated-vars) + (utils tc-utils) (only-in (rep type-rep) Type/c) (typecheck tc-metafunctions) (except-in (types utils abbrev) -> ->*)) diff --git a/collects/typed-racket/env/mvar-env.rkt b/collects/typed-racket/env/mvar-env.rkt new file mode 100644 index 00000000..7a4ca5ed --- /dev/null +++ b/collects/typed-racket/env/mvar-env.rkt @@ -0,0 +1,13 @@ +#lang racket/base + +(require syntax/id-table racket/dict) + +(provide mvar-env register-mutated-var is-var-mutated?) + +(define mvar-env (make-free-id-table)) + +(define (register-mutated-var id) + (dict-set! mvar-env id #t)) + +(define (is-var-mutated? id) + (dict-ref mvar-env id #f)) \ No newline at end of file diff --git a/collects/typed-racket/optimizer/unboxed-let.rkt b/collects/typed-racket/optimizer/unboxed-let.rkt index a8047563..86d0e657 100644 --- a/collects/typed-racket/optimizer/unboxed-let.rkt +++ b/collects/typed-racket/optimizer/unboxed-let.rkt @@ -6,7 +6,7 @@ "../utils/tc-utils.rkt" (for-template racket/base) (types numeric-tower utils type-table) - (rep type-rep) + (rep type-rep) (env mvar-env) (optimizer utils logging float-complex)) (provide unboxed-let-opt-expr) diff --git a/collects/typed-racket/private/type-annotation.rkt b/collects/typed-racket/private/type-annotation.rkt index b703aa7f..a8484b68 100644 --- a/collects/typed-racket/private/type-annotation.rkt +++ b/collects/typed-racket/private/type-annotation.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" (rep type-rep) (utils tc-utils) - (env global-env) + (env global-env mvar-env) (except-in (types subtype union resolve utils generalize)) (private parse-type) (contract-req) diff --git a/collects/typed-racket/tc-setup.rkt b/collects/typed-racket/tc-setup.rkt index d9c4800c..2b4520a7 100644 --- a/collects/typed-racket/tc-setup.rkt +++ b/collects/typed-racket/tc-setup.rkt @@ -6,7 +6,7 @@ (private type-contract) (types utils) (typecheck typechecker provide-handling tc-toplevel) - (env tvar-env type-name-env type-alias-env env-req) + (env tvar-env type-name-env type-alias-env env-req mvar-env) (utils tc-utils disarm mutated-vars debug) (rep type-rep) (for-syntax racket/base) @@ -58,8 +58,8 @@ (do-time "Local Expand Done") (init) (do-time "Initialized Envs") - (parameterize ([mutated-vars (find-mutated-vars fully-expanded-stx)] - [orig-module-stx (or (orig-module-stx) orig-stx)] + (find-mutated-vars fully-expanded-stx mvar-env) + (parameterize ([orig-module-stx (or (orig-module-stx) orig-stx)] [expanded-module-stx fully-expanded-stx] [debugging? #f]) (do-time "Starting `checker'") diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index d596410c..67f5b7ab 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -13,7 +13,7 @@ (rep type-rep) (types utils abbrev type-table) (private parse-type type-annotation type-contract) - (env global-env init-envs type-name-env type-alias-env lexical-env env-req) + (env global-env init-envs type-name-env type-alias-env lexical-env env-req mvar-env) syntax/id-table (utils tc-utils mutated-vars) "provide-handling.rkt" @@ -350,6 +350,7 @@ #,(env-init-code syntax-provide? provide-tbl def-tbl) #,(talias-env-init-code) #,(tname-env-init-code) + #,(mvar-env-init-code mvar-env) #,(make-struct-table-code) #,@(for/list ([a (in-list aliases)]) (match a diff --git a/collects/typed-racket/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt index 92a5c60a..6fb818d9 100644 --- a/collects/typed-racket/types/abbrev.rkt +++ b/collects/typed-racket/types/abbrev.rkt @@ -6,6 +6,7 @@ (utils tc-utils) "base-abbrev.rkt" (types union numeric-tower) + (env mvar-env) racket/list racket/match racket/function diff --git a/collects/typed-racket/utils/tc-utils.rkt b/collects/typed-racket/utils/tc-utils.rkt index 6d5e18e6..c74c999d 100644 --- a/collects/typed-racket/utils/tc-utils.rkt +++ b/collects/typed-racket/utils/tc-utils.rkt @@ -15,12 +15,6 @@ 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]