New interface for unstable/mutated-vars

- functional hash tables
 - fix clients

original commit: 0379e534e3f0024473d6af9379d0cac0d2bd1a37

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)

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)

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 

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

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))

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]

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)