New interface for unstable/mutated-vars

- functional hash tables
 - fix clients

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)
+           (parameterize ([mutated-vars (find-mutated-vars ex)])
-           (values (lambda () (tc-expr ex)) 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)
+           (parameterize ([mutated-vars (find-mutated-vars ex)])
-           (tc-expr 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)
+(require (for-template racket/base) racket/dict
-         syntax/boundmap syntax/kerncase)
+         racket/trace
+         syntax/id-table syntax/kerncase)
 
-;; mapping telling whether an identifer is mutated
+;; samth : this should use sets, not dicts
-;; maps id -> boolean
+;; but sets do not have extensible comparisons
-(define table (make-module-identifier-mapping))
+;; 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
+  (let loop ([stx form] [tbl (make-immutable-free-id-table)])
+    ;; syntax-list -> table
     (define (fmv/list lstx)
-    (for-each find-mutated-vars (syntax->list lstx)))
+      (for/fold ([tbl tbl])
-  (kernel-syntax-case* form #f ()
+          ([stx (in-list (syntax->list lstx))])
+        (loop stx tbl)))
+    (kernel-syntax-case* stx #f (#%top-interaction)
       ;; what we care about: set!
       [(set! v e)
-     (begin
+       (dict-set (loop #'e tbl) #'v #t)]
-       (module-identifier-mapping-put! table #'v #t))]
+      ;; forms with expression subforms
       [(define-values (var ...) expr)
-     (find-mutated-vars #'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) ...) (for-each fmv/list (syntax->list #'(rest ...)))]
+      [(case-lambda (_  rest ...) ...)
+       (fmv/list #'(rest ... ...))]
       [(if . es) (fmv/list #'es)]
       [(with-continuation-mark . es) (fmv/list #'es)]
-    [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...))
+      [(let-values ([_ e] ...) b ...) (fmv/list #'(b ... e ...))]
-                                         (fmv/list #'b))]
+      [(letrec-values ([_ e] ...) b ...) (fmv/list #'(b ... e ...))]
-    [(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...))
+      [(letrec-syntaxes+values _ ([_ e] ...) b ...) (fmv/list #'(b ... e ...))]
-                                            (fmv/list #'b))]
+      [(#%plain-module-begin . forms) (fmv/list #'forms)]
-    [(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)]))
+      [_ tbl])))
 
-;; checks to see if a particular variable is ever set!'d
+(provide find-mutated-vars)
-;; 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?)

collects/unstable/scribblings/mutated-vars.scrbl

@@ -3,33 +3,29 @@
           "utils.rkt"
           (for-label unstable/mutated-vars
                      racket/contract
+                     racket/dict
                      racket/base))
 
 @title[#:tag "mutated-vars"]{Finding Mutated Variables}
 
 @(define the-eval (make-base-eval))
-@(the-eval '(require unstable/mutated-vars))
+@(the-eval '(require unstable/mutated-vars racket/dict))
 
 @defmodule[unstable/mutated-vars]
 
 @unstable[@author+email["Sam Tobin-Hochstadt" "samth@ccs.neu.edu"]]
 
 
-@defproc[(find-mutated-vars [stx syntax?]) void?]{ Traverses
+@defproc[(find-mutated-vars [stx syntax?]) dict?]{Traverses
 @racket[stx], which should be @racket[module-level-form] in the sense
 of the grammar for 
 @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{fully-expanded} forms,
-and records all of the variables that are mutated.}
+and records all of the variables that are mutated.  The result is a
-
+dictionary that maps each mutated identifier to @racket[#t].} 
-@defproc[(is-var-mutated? [id identifier?]) boolean?]{
-Produces @racket[#t] if @racket[id] is mutated by an expression
-	 previously passed to @racket[find-mutated-vars], otherwise
-	 produces @racket[#f].
-
 
 @examples[#:eval the-eval
-(find-mutated-vars #'(begin (set! var 'foo) 'bar))
+(define t (find-mutated-vars #'(begin (set! var 'foo) 'bar)))
-(is-var-mutated? #'var)
+(dict-ref t #'var #f)
-(is-var-mutated? #'other-var)
+(dict-ref t #'other-var #f)
 ]
 }