From 3f49f996dee80e38b12e7287136d052cbbc290e7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 21 Jun 2010 15:39:40 -0400 Subject: [PATCH] Refactor provide handling. - use id-tables instead of lists - smarter iteration - prepare for eliminating declarations when not needed, but don't do it yet original commit: 4925e7e51f487e3e9dcc3646a28cd30bf334cd02 --- collects/typed-scheme/env/init-envs.rkt | 16 +- .../typed-scheme/typecheck/def-export.rkt | 27 +++ .../typecheck/provide-handling.rkt | 188 +++++++----------- .../typed-scheme/typecheck/tc-toplevel.rkt | 34 +++- 4 files changed, 141 insertions(+), 124 deletions(-) create mode 100644 collects/typed-scheme/typecheck/def-export.rkt diff --git a/collects/typed-scheme/env/init-envs.rkt b/collects/typed-scheme/env/init-envs.rkt index 9fbf1a51..72c7d8be 100644 --- a/collects/typed-scheme/env/init-envs.rkt +++ b/collects/typed-scheme/env/init-envs.rkt @@ -4,7 +4,7 @@ "type-env.rkt" "type-name-env.rkt" "type-alias-env.rkt" - unstable/struct + unstable/struct racket/dict (rep type-rep object-rep filter-rep rep-utils) (for-template (rep type-rep object-rep filter-rep) (types union) @@ -80,7 +80,7 @@ (show-sharing #f) (booleans-as-true/false #f)) (with-syntax ([registers (filter (lambda (x) x) (type-name-env-map f))]) - #'(begin (begin-for-syntax . registers))))) + #'(begin-for-syntax . registers)))) (define (talias-env-init-code) (define (f id ty) @@ -91,18 +91,20 @@ (show-sharing #f) (booleans-as-true/false #f)) (with-syntax ([registers (filter (lambda (x) x) (type-alias-env-map f))]) - #'(begin (begin-for-syntax . registers))))) + #'(begin-for-syntax . registers)))) -(define (env-init-code) +(define (env-init-code syntax-provide? provide-tbl def-tbl) (define (f id ty) - (if (bound-in-this-module id) + (if (and (bound-in-this-module id) + ;; if there are no syntax provides, then we only need this identifier if it's provided + #;(or syntax-provide? (dict-ref provide-tbl id #f))) #`(register-type #'#,id #,(datum->syntax #'here (print-convert ty))) #f)) (parameterize ((current-print-convert-hook converter) (show-sharing #f) (booleans-as-true/false #f)) - (with-syntax ([registers (filter (lambda (x) x) (type-env-map f))]) - #'(begin (begin-for-syntax . registers))))) + (with-syntax ([registers (filter values (type-env-map f))]) + #'(begin-for-syntax . registers)))) diff --git a/collects/typed-scheme/typecheck/def-export.rkt b/collects/typed-scheme/typecheck/def-export.rkt new file mode 100644 index 00000000..acf624d6 --- /dev/null +++ b/collects/typed-scheme/typecheck/def-export.rkt @@ -0,0 +1,27 @@ +#lang racket/base + +(require racket/require + (for-syntax syntax/parse racket/base + (path-up "utils/tc-utils.rkt" "private/typed-renaming.rkt" "env/type-name-env.rkt"))) +(provide def-export) + + +(define-for-syntax (renamer id #:alt [alt #f]) + (if alt + (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) + (make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) + +(define-syntax (def-export stx) + (syntax-parse stx + [(def-export export-id:identifier id:identifier cnt-id:identifier) + #'(define-syntax export-id + (if (unbox typed-context?) + (renamer #'id #:alt #'cnt-id) + (renamer #'cnt-id)))] + [(def-export export-id:identifier id:identifier cnt-id:identifier #:alias) + #'(define-syntax export-id + (if (unbox typed-context?) + (begin + (add-alias #'export-id #'id) + (renamer #'id #:alt #'cnt-id)) + (renamer #'cnt-id)))])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/provide-handling.rkt b/collects/typed-scheme/typecheck/provide-handling.rkt index 504cfb1c..48734be0 100644 --- a/collects/typed-scheme/typecheck/provide-handling.rkt +++ b/collects/typed-scheme/typecheck/provide-handling.rkt @@ -9,16 +9,14 @@ (private typed-renaming) (rep type-rep) (utils tc-utils) + (for-syntax syntax/parse racket/base) racket/contract/private/provide unstable/list - unstable/debug + unstable/debug syntax/id-table racket/dict unstable/syntax scheme/struct-info scheme/match - "def-binding.rkt" syntax/parse) + "def-binding.rkt" syntax/parse + (for-template scheme/base "def-export.rkt" scheme/contract)) -(require (for-template scheme/base - scheme/contract)) - -(provide remove-provides provide? generate-prov - get-alternate) +(provide remove-provides provide? generate-prov get-alternate) (define (provide? form) (syntax-parse form @@ -29,21 +27,13 @@ (define (remove-provides forms) (filter (lambda (e) (not (provide? e))) (syntax->list forms))) -(define (renamer id #:alt [alt #f]) - (if alt - (make-typed-renaming (syntax-property id 'not-free-identifier=? #t) alt) - (make-rename-transformer (syntax-property id 'not-free-identifier=? #t)))) - -;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key -(define mapping (make-free-identifier-mapping)) - (define (mem? i vd) (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] [else #f])) -;; generate-contract-defs : listof[def-binding] listof[def-binding] id -> syntax -> syntax -;; val-defs: define-values in this module -;; stx-defs: define-syntaxes in this module +;; generate-contract-defs : dict[id -> def-binding] dict[id -> id] id -> syntax +;; defs: defines in this module +;; provs: provides in this module ;; pos-blame-id: a #%variable-reference for the module ;; internal-id : the id being provided @@ -52,105 +42,79 @@ ;; anything already recorded in the mapping is given an empty (begin) and the already-recorded id ;; otherwise, we will map internal-id to the fresh id in `mapping' -(define ((generate-prov stx-defs val-defs pos-blame-id) form) +(define (generate-prov defs provs pos-blame-id) + ;; maps ids defined in this module to an identifier which is the possibly-contracted version of the key + (define mapping (make-free-id-table)) + ;; mk : id [id] -> (values syntax id) (define (mk internal-id [new-id (generate-temporary internal-id)]) + (define (mk-untyped-syntax b defn-id internal-id) + (match b + [(def-struct-stx-binding _ (? struct-info? si)) + (match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)]) + (let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e) + (mk e) + (values #'(begin) e))) + (list* type-desc constr pred super accs))]) + (with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids]) + (if (identifier? i) + #`(syntax #,i) + i))]) + #`(begin + #,@defns + (define-syntax #,defn-id + (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))] + [_ + #`(define-syntax #,defn-id + (lambda (stx) + (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))])) (cond ;; if it's already done, do nothing - [(free-identifier-mapping-get mapping internal-id - ;; if it wasn't there, put it in, and skip this case - (lambda () - (free-identifier-mapping-put! mapping internal-id new-id) - #f)) - => (lambda (mapped-id) - (values #'(begin) mapped-id))] - [(mem? internal-id val-defs) + [(dict-ref mapping internal-id + ;; if it wasn't there, put it in, and skip this case + (λ () (dict-set! mapping internal-id new-id) #f)) + => (λ (mapped-id) (values #'(begin) mapped-id))] + [(dict-ref defs internal-id #f) => - (lambda (b) - (values - (with-syntax ([id internal-id]) - (cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t) - => - (lambda (cnt) - (with-syntax ([(cnt-id) (generate-temporaries #'(id))] - [export-id new-id] - [module-source pos-blame-id] - [the-contract (generate-temporary 'generated-contract)]) - #`(begin - (define the-contract #,cnt) - (define-syntax cnt-id - (make-provide/contract-transformer - (quote-syntax the-contract) - (quote-syntax id) - (quote-syntax out-id) - (quote-syntax module-source))) - (define-syntax export-id - (if (unbox typed-context?) - (renamer #'id #:alt #'cnt-id) - (renamer #'cnt-id))))))] - [else - (with-syntax ([(error-id) (generate-temporaries #'(id))] - [export-id new-id]) - #`(begin - (define-syntax error-id - (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))) - (define-syntax export-id - (if (unbox typed-context?) - (renamer #'id #:alt #'error-id) - (renamer #'error-id)))))])) - new-id))] - [(mem? internal-id stx-defs) - => - (lambda (b) - (define (mk-untyped-syntax defn-id internal-id) - (match b - [(struct def-struct-stx-binding (_ (? struct-info? si))) - (match-let ([(list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)]) - (let-values ([(defns new-ids) (map/values 2 (lambda (e) (if (identifier? e) - (mk e) - (values #'(begin) e))) - (list* type-desc constr pred super accs))]) - (with-syntax ([(type-desc* constr* pred* super* accs* ...) (for/list ([i new-ids]) - (if (identifier? i) - #`(syntax #,i) - i))]) - #`(begin - #,@defns - (define-syntax #,defn-id - (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*))))))] - [_ - #`(define-syntax #,defn-id - (lambda (stx) - (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))])) - (with-syntax* ([id internal-id] - [export-id new-id] - [(untyped-id) (generate-temporaries #'(id))]) - (values - #`(begin - #,(mk-untyped-syntax #'untyped-id internal-id) - (define-syntax export-id - (if (unbox typed-context?) - (begin - (add-alias #'export-id #'id) - (renamer #'id #:alt #'untyped-id)) - (renamer #'untyped-id)))) - new-id)))] + (match-lambda + [(def-binding _ (app (λ (ty) (type->contract ty (λ () #f) #:out #t)) (? values cnt))) + (values + (with-syntax* ([id internal-id] + [cnt-id (generate-temporary #'id)] + [export-id new-id] + [module-source pos-blame-id] + [the-contract (generate-temporary 'generated-contract)]) + #`(begin + (define the-contract #,cnt) + (define-syntax cnt-id + (make-provide/contract-transformer + (quote-syntax the-contract) + (quote-syntax id) + (quote-syntax out-id) + (quote-syntax module-source))) + (def-export export-id id cnt-id))) + new-id)] + [(def-binding id ty) + (values + (with-syntax* ([id internal-id] + [error-id (generate-temporary #'id)] + [export-id new-id]) + #'(begin + (define-syntax (error-id stx) + (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))) + (def-export export-id id error-id))) + new-id)] + [(and b (def-stx-binding _)) + (with-syntax* ([id internal-id] + [export-id new-id] + [untyped-id (generate-temporary #'id)] + [def (mk-untyped-syntax b #'untyped-id internal-id)]) + (values + #`(begin def (def-export export-id id untyped-id #:alias)) + new-id))])] ;; otherwise, not defined in this module, not our problem [else (values #'(begin) internal-id)])) - ;; do-one : id [id] -> syntax - (define (do-one internal-id [external-id internal-id]) + ;; do-one : id id -> syntax + (for/list ([(internal-id external-id) (in-dict provs)]) (define-values (defs id) (mk internal-id)) - #`(begin #,defs (provide (rename-out [#,id #,external-id])))) - (syntax-parse form #:literals (#%provide) - [(#%provide form ...) - (for/list ([f (syntax->list #'(form ...))]) - (parameterize ([current-orig-stx f]) - (syntax-parse f - [i:id - (do-one #'i)] - [((~datum rename) in out) - (do-one #'in #'out)] - [((~datum protect) . _) - (tc-error "provide: protect not supported by Typed Scheme")] - [_ (int-err "unknown provide form")])))] - [_ (int-err "non-provide form! ~a" (syntax->datum form))])) + #`(begin #,defs (provide (rename-out [#,id #,external-id]))))) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.rkt b/collects/typed-scheme/typecheck/tc-toplevel.rkt index da080236..fde65f83 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.rkt +++ b/collects/typed-scheme/typecheck/tc-toplevel.rkt @@ -19,6 +19,7 @@ "provide-handling.rkt" "def-binding.rkt" (prefix-in c: racket/contract) + racket/dict (for-template "internal-forms.rkt" unstable/location @@ -259,24 +260,47 @@ ;; do pass 1, and collect the defintions (define defs (apply append (filter list? (map tc-toplevel/pass1 forms)))) ;; separate the definitions into structures we'll handle for provides - (define stx-defs (filter def-stx-binding? defs)) - (define val-defs (filter def-binding? defs)) + (define def-tbl + (for/fold ([h (make-immutable-free-id-table)]) + ([def (in-list defs)]) + (dict-set h (binding-name def) def))) ;; typecheck the expressions and the rhss of defintions (for-each tc-toplevel/pass2 forms) ;; check that declarations correspond to definitions (check-all-registered-types) ;; report delayed errors (report-all-errors) + (define syntax-provide? #f) + (define provide-tbl + (for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)]) + (syntax-parse p #:literals (#%provide) + [(#%provide form ...) + (for/fold ([h h]) ([f (syntax->list #'(form ...))]) + (parameterize ([current-orig-stx f]) + (syntax-parse f + [i:id + (when (def-stx-binding? (dict-ref def-tbl #'i #f)) + (set! syntax-provide? #t)) + (dict-set h #'i #'i)] + [((~datum rename) in out) + (when (def-stx-binding? (dict-ref def-tbl #'in #f)) + (set! syntax-provide? #t)) + (dict-set h #'in #'out)] + [((~datum protect) . _) + (tc-error "provide: protect not supported by Typed Scheme")] + [_ (int-err "unknown provide form")])))] + [_ (int-err "non-provide form! ~a" (syntax->datum p))]))) ;; compute the new provides (with-syntax* ([the-variable-reference (generate-temporary #'blame)] - [((new-provs ...) ...) (map (generate-prov stx-defs val-defs #'the-variable-reference) provs)]) + [(new-provs ...) + (generate-prov def-tbl provide-tbl #'the-variable-reference)]) #`(begin (define the-variable-reference (quote-module-path)) - #,(env-init-code) + #,(env-init-code syntax-provide? provide-tbl def-tbl) #,(tname-env-init-code) #,(talias-env-init-code) - (begin new-provs ... ...))))) + (begin new-provs ...))))) ;; typecheck a whole module ;; syntax -> syntax