From 647c4eef5940fde0395f9a19496244acab5f62b2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 21 May 2010 17:29:26 -0400 Subject: [PATCH] Refactor environments. - mapping stored as dict - use id tables for identifiers - use env-filter instead of filter - eliminate spurious use of conses --- collects/typed-scheme/env/lexical-env.rkt | 3 +- collects/typed-scheme/env/type-env.rkt | 3 + .../typed-scheme/env/type-environments.rkt | 58 +++++++++---------- collects/typed-scheme/private/parse-type.rkt | 5 +- collects/typed-scheme/typecheck/tc-envops.rkt | 2 +- 5 files changed, 37 insertions(+), 34 deletions(-) diff --git a/collects/typed-scheme/env/lexical-env.rkt b/collects/typed-scheme/env/lexical-env.rkt index deef63f337..7dc17e4ab2 100644 --- a/collects/typed-scheme/env/lexical-env.rkt +++ b/collects/typed-scheme/env/lexical-env.rkt @@ -3,6 +3,7 @@ (require "../utils/utils.rkt" "type-environments.rkt" "type-env.rkt" + unstable/mutated-vars syntax/id-table (only-in scheme/contract ->* -> or/c any/c listof cons/c) (utils tc-utils) (only-in (rep type-rep) Type/c) @@ -16,7 +17,7 @@ [update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (env?) . ->* . env?)]) ;; the current lexical environment -(define lexical-env (make-parameter (make-empty-env free-identifier=?))) +(define lexical-env (make-parameter (make-empty-env (make-immutable-free-id-table)))) ;; run code in a new env (define-syntax-rule (with-lexical-env e . b) diff --git a/collects/typed-scheme/env/type-env.rkt b/collects/typed-scheme/env/type-env.rkt index 0cb028b854..369f6cfda2 100644 --- a/collects/typed-scheme/env/type-env.rkt +++ b/collects/typed-scheme/env/type-env.rkt @@ -1,5 +1,8 @@ #lang scheme/base +;; Top-level type environment +;; maps identifiers to their types, updated by mutation + (require "../utils/utils.rkt" syntax/id-table (utils tc-utils) diff --git a/collects/typed-scheme/env/type-environments.rkt b/collects/typed-scheme/env/type-environments.rkt index 2254d9482b..f71dae5c6a 100644 --- a/collects/typed-scheme/env/type-environments.rkt +++ b/collects/typed-scheme/env/type-environments.rkt @@ -1,6 +1,6 @@ #lang scheme/base -(require scheme/contract +(require scheme/contract unstable/sequence racket/dict syntax/id-table (prefix-in r: "../utils/utils.rkt") scheme/match (r:rep filter-rep rep-utils type-rep) unstable/struct (except-in (r:utils tc-utils) make-env) @@ -15,8 +15,8 @@ dotted-env initial-tvar-env env-map + make-empty-env env-filter - env-vals env-keys+vals env-props replace-props @@ -24,58 +24,60 @@ ;; eq? has the type of equal?, and l is an alist (with conses!) ;; props is a list of known propositions -(r:d-s/c env ([eq? (any/c any/c . -> . boolean?)] [l (listof pair?)] [props (listof Filter/c)]) #:transparent) - -(define (env-vals e) - (map cdr (env-l e))) - -(define (env-keys+vals e) - (env-l e)) +(r:d-s/c env ([l (and/c (not/c dict-mutable?) dict?)] [props (listof Filter/c)]) #:transparent) (define (env-filter f e) (match e - [(struct env (eq? l props)) - (make-env eq? (filter f l) props)])) + [(struct env (l props)) + (make-env (for/fold ([h l]) + ([(k v) (in-dict l)] + #:when (not (f (cons k v)))) + (dict-remove h k)) + props)])) -(define (make-empty-env p?) (make-env p? null null)) +(r:d/c (make-empty-env dict) + (dict? . -> . env?) + (make-env dict null)) + +(define (env-keys+vals e) + (match e + [(env l _) (for/list ([(k v) (in-dict l)]) (cons k v))])) ;; the initial type variable environment - empty ;; this is used in the parsing of types -(define initial-tvar-env (make-empty-env eq?)) +(define initial-tvar-env (make-empty-env #hasheq())) ;; a parameter for the current type variables (define current-tvars (make-parameter initial-tvar-env)) ;; the environment for types of ... variables -(define dotted-env (make-parameter (make-empty-env free-identifier=?))) +(define dotted-env (make-parameter (make-empty-env (make-immutable-free-id-table)))) (r:d/c (env-map f e) - ((pair? . -> . pair?) env? . -> . env?) - (make-env (env-eq? e) (map f (env-l e)) (env-props e))) + ((any/c any/c . -> . any/c) env? . -> . env?) + (make-env (dict-map f (env-l e)) (env-props e))) ;; extend that works on single arguments (define (extend e k v) (match e - [(struct env (f l p)) (make-env f (cons (cons k v) l) p)] + [(env l p) (make-env (dict-set l k v) p)] [_ (int-err "extend: expected environment, got ~a" e)])) (define (extend-env ks vs e) (match e - [(struct env (f l p)) (make-env f (append (map cons ks vs) l) p)] + [(env l p) (make-env (for/fold ([h l]) + ([k (in-list ks)] [v (in-list vs)]) (dict-set h k v)) + p)] [_ (int-err "extend-env: expected environment, got ~a" e)])) (define (replace-props e props) (match e - [(struct env (f l p)) - (make-env f l props)])) + [(env l p) + (make-env l props)])) (define (lookup e key fail) (match e - [(struct env (f? l p)) - (let loop ([l l]) - (cond [(null? l) (fail key)] - [(f? (caar l) key) (cdar l)] - [else (loop (cdr l))]))] + [(env l p) (dict-ref l key (λ () (fail key)))] [_ (int-err "lookup: expected environment, got ~a" e)])) @@ -87,12 +89,10 @@ (extend-env ks vs env)] [(or (list? ks) (list? vs)) (int-err "not both lists in extend/values: ~a ~a" ks vs)] - [else (extend-env (list ks) (list vs) env)])) + [else (extend env ks vs)])) env kss vss)) ;; run code in an extended dotted env (define-syntax with-dotted-env/extend (syntax-rules () - [(_ i t v . b) (parameterize ([dotted-env (extend/values (list i) (list (cons t v)) (dotted-env))]) . b)])) - -(r:p/c [make-empty-env ((-> any/c any/c any/c) . -> . env?)]) + [(_ i t v . b) (parameterize ([dotted-env (extend (dotted-env) i (cons t v))]) . b)])) diff --git a/collects/typed-scheme/private/parse-type.rkt b/collects/typed-scheme/private/parse-type.rkt index 1232d7eee4..799a26c221 100644 --- a/collects/typed-scheme/private/parse-type.rkt +++ b/collects/typed-scheme/private/parse-type.rkt @@ -239,8 +239,7 @@ (syntax-e #'bound))))))] [(dom:expr ... rest:expr _:ddd (~and kw t:->) rng) (add-type-name-reference #'kw) - (let ([bounds (filter (compose Dotted? cdr) - (env-keys+vals (current-tvars)))]) + (let ([bounds (env-keys+vals (env-filter (compose Dotted? cdr) (current-tvars)))]) (when (null? bounds) (tc-error/stx stx "No type variable bound with ... in scope for ... type")) (unless (null? (cdr bounds)) @@ -363,7 +362,7 @@ (syntax-e #'bound))))] [((~and kw values) tys ... dty _:ddd) (add-type-name-reference #'kw) - (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) + (let ([bounds (env-keys+vals (env-filter (compose Dotted? cdr) (current-tvars)))]) (when (null? bounds) (tc-error/stx stx "No type variable bound with ... in scope for ... type")) (unless (null? (cdr bounds)) diff --git a/collects/typed-scheme/typecheck/tc-envops.rkt b/collects/typed-scheme/typecheck/tc-envops.rkt index 274a52bb6f..ce4b5f3118 100644 --- a/collects/typed-scheme/typecheck/tc-envops.rkt +++ b/collects/typed-scheme/typecheck/tc-envops.rkt @@ -70,7 +70,7 @@ (define-values (props atoms) (combine-props fs (env-props env) flag)) (for/fold ([Γ (replace-props env (append atoms props))]) ([f atoms]) (match f - [(Bot:) (set-box! flag #f) (env-map (lambda (x) (cons (car x) (Un))) Γ)] + [(Bot:) (set-box! flag #f) (env-map (lambda (k v) (Un)) Γ)] [(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x)) (update-type/lexical (lambda (x t) (let ([new-t (update t f)]) (when (type-equal? new-t (Un))