From ae0717d9703a2c43d8e85dc2763955439be74105 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 26 Jan 2015 16:23:52 -0500 Subject: [PATCH] Move generated contracted provides to a submodule. This allows the main TR module not to explicitly depend on the contract library. Each exported name can be redirected to either the original name (for a typed client) or to another macro (for an untyped client) which expands to a `local-require` for the relevant submodule (named `#%contract-defs`). Thanks to Matthew for the initial idea and an implementation in plai-typed that this is based on. --- .../typed-racket/private/type-contract.rkt | 41 ++-- .../typecheck/provide-handling.rkt | 124 +++++++----- .../typed-racket/typecheck/tc-toplevel.rkt | 187 +++++++++++++----- .../typed-racket/utils/redirect-contract.rkt | 45 +++++ 4 files changed, 286 insertions(+), 111 deletions(-) create mode 100644 typed-racket-lib/typed-racket/utils/redirect-contract.rkt diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt index 3000193d..5fe800d2 100644 --- a/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -16,6 +16,7 @@ racket/format racket/dict unstable/list + syntax/flatten-begin (only-in (types abbrev) -Bottom) (static-contracts instantiate optimize structures combinators) ;; TODO make this from contract-req @@ -133,10 +134,13 @@ #,(syntax-position orig-id) #,(syntax-span orig-id))))])])) +;; The below requires are needed since they provide identifiers that +;; may appear in the residual program. + +;; TODO: It would be better to have individual contracts specify which +;; modules should be required, but for now this is just all of them. (define extra-requires #'(require - ;; the below requires are needed since they provide identifiers - ;; that may appear in the residual program (submod typed-racket/private/type-contract predicates) typed-racket/utils/utils (for-syntax typed-racket/utils/utils) @@ -144,7 +148,10 @@ typed-racket/utils/evt-contract unstable/contract racket/contract/parametric)) -;; should the above requires be included in the output? +;; Should the above requires be included in the output? +;; This box is only used for contracts generated for `require/typed` +;; and `cast`, contracts for `provides go into the `#%contract-defs` +;; submodule, which always has the above `require`s. (define include-extra-requires? (box #f)) (define (change-contract-fixups forms) @@ -157,15 +164,26 @@ (begin (set-box! include-extra-requires? #t) (generate-contract-def e ctc-cache sc-cache)))))) -(define (change-provide-fixups forms) - (define ctc-cache (make-hash)) - (define sc-cache (make-hash)) +;; TODO: These are probably all in a specific place, which could avoid +;; the big traversal +(define (change-provide-fixups forms [ctc-cache (make-hash)] [sc-cache (make-hash)]) (with-new-name-tables (for/list ([form (in-list forms)]) - (cond [(contract-def/provide-property form) - (set-box! include-extra-requires? #t) - (generate-contract-def/provide form ctc-cache sc-cache)] - [else form])))) + (syntax-parse form #:literal-sets (kernel-literals) + [_ + #:when (contract-def/provide-property form) + (generate-contract-def/provide form ctc-cache sc-cache)] + [(module* name #f forms ...) + (quasisyntax/loc form + (module* name #f + #,@(change-provide-fixups (syntax->list #'(forms ...)) + ctc-cache sc-cache)))] + [((~literal #%plain-module-begin) forms ...) + (quasisyntax/loc form + (#%plain-module-begin + #,@(change-provide-fixups (flatten-all-begins #'(begin forms ...)) + ctc-cache sc-cache)))] + [_ form])))) ;; To avoid misspellings (define impersonator-sym 'impersonator) @@ -234,9 +252,6 @@ kind #:cache cache))) - - - (define any-wrap/sc (chaperone/sc #'any-wrap/c)) (define (no-duplicates l) diff --git a/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt b/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt index 592157af..58701704 100644 --- a/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt +++ b/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt @@ -26,35 +26,44 @@ (define (freshen-id id) ((make-syntax-introducer) id)) -;; generate-prov : dict[id -> def-binding] dict[id -> list[id]] id +;; generate-prov : dict[id -> def-binding] dict[id -> list[id]] id id ;; -> (values listof[syntax] listof[listof[list[id id]]]) ;; defs: defines in this module ;; provs: provides in this module ;; pos-blame-id: a #%variable-reference for the module +;; mk-redirect-id: the name of a definition created by `make-make-redirect-to-contract` ;; The first returned value is a syntax object of definitions that defines the ;; contracted versions of the provided identifiers, and the corresponding ;; provides. ;; ;; The second value is a list of two element lists, which are type name aliases. -(define (generate-prov defs provs pos-blame-id) +(define (generate-prov defs provs pos-blame-id mk-redirect-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)) - ;; triple/c in the signatures corresponds to three values: - ;; (values syntax? identfier? (listof (list/c identifier? identifier?)) - ;; First return value is a syntax object of definitions - ;; Second is the id to export - ;; Third is a list of two element lists representing type aliases + ;; quad/c in the signatures corresponds to four values: + ;; (values syntax? syntax? identfier? (listof (list/c identifier? identifier?)) + ;; First return value is a syntax object of definitions, which will go in + ;; the #%contract-defs submodule + ;; Second is a syntax object of definitions to go in the main module, including + ;; the defintion to be exported + ;; Third is the id to export + ;; Fourth is a list of two element lists representing type aliases - ;; mk : id -> triple/c + + ;; mk-ignored-quad : identifier -> quad/c + (define (mk-ignored-quad i) (values #'(begin) #'(begin) i null)) + + ;; mk : id -> quad/c ;; - ;; internal-id : the id being provided - ;; if `internal-id' is defined in this module, we will produce a (begin def ... provide) block + ;; internal-id : the id being provided. If `internal-id' is defined + ;; in this module, we will produce a (begin def ... provide) block ;; and a name to provide instead of internal-id. ;; - ;; 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' + ;; 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 (mk internal-id) (define new-id (freshen-id internal-id)) (cond @@ -62,35 +71,38 @@ [(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 null))] + => mk-ignored-quad] [(dict-ref defs internal-id #f) => (match-lambda [(def-binding _ ty) - (mk-value-triple internal-id new-id ty)] + (mk-value-quad internal-id new-id ty)] [(def-struct-stx-binding _ (? struct-info? si) constr-type) - (mk-struct-syntax-triple internal-id new-id si constr-type)] + (mk-struct-syntax-quad internal-id new-id si constr-type)] [(def-stx-binding _) - (mk-syntax-triple internal-id new-id)])] + (mk-syntax-quad internal-id new-id)])] ;; otherwise, not defined in this module, not our problem - [else (values #'(begin) internal-id null)])) + [else (mk-ignored-quad internal-id)])) - ;; mk-struct-syntax-triple : identifier? identifier? struct-info? Type/c -> triple/c - (define (mk-struct-syntax-triple internal-id new-id si constr-type) + ;; mk-struct-syntax-quad : identifier? identifier? struct-info? Type/c -> quad/c + ;; This handles `(provide s)` where `s` was defined with `(struct s ...)`. + (define (mk-struct-syntax-quad internal-id new-id si constr-type) (define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same) (match-define (list type-desc constr pred (list accs ...) muts super) (extract-struct-info si)) - (define-values (defns new-ids aliases) - (map/values 3 + (define-values (defns export-defns new-ids aliases) + (map/values 4 (lambda (e) (if (identifier? e) (mk e) - (values #'(begin) e null))) + (mk-ignored-quad e))) (list* type-desc pred super accs))) - (define-values (constr-defn constr-new-id constr-aliases) + ;; Here, we recursively handle all of the identifiers referenced + ;; in this static struct info. + (define-values (constr-defn constr-export-defn constr-new-id constr-aliases) (cond [(not (identifier? constr)) - (values #'(begin) #f null)] + (values #'(begin) #'(begin) #f null)] [(free-identifier=? constr internal-id) - (mk-value-triple constr (generate-temporary constr) constr-type)] + (mk-value-quad constr (generate-temporary constr) constr-type)] [else (mk constr)])) @@ -104,7 +116,20 @@ (values #`(begin #,constr-defn - #,@defns + #,@defns) + #`(begin + #,constr-export-defn + #,@export-defns + ;; Here, we construct a new static struct identifier whose + ;; contents point to newly-defined identifiers that are + ;; themselves redirections. Unlike for value exports, we + ;; don't provide two distinct identifiers, one for typed + ;; code and one for untyped code, because they both have + ;; to accessible by `syntax-local-value` and thus have to + ;; be protected from re-export regardless of whether the + ;; identifiers are copied out. Additionally, we can't put + ;; a protected version in the submodule, since that + ;; wouldn't be accessible by `syntax-local-value`. (define-syntax protected-id (let ((info (list type-desc* (syntax export-id) pred* (list accs* ...) (list #,@(map (lambda (x) #'#f) accs)) super*))) @@ -112,47 +137,58 @@ #'(make-struct-info-self-ctor constr* info) #'info))) (def-export export-id protected-id protected-id)) - new-id + #'export-id (cons (list #'export-id internal-id) (apply append constr-aliases aliases))))) - ;; mk-syntax-triple : identifier? identifier? -> triple/c - (define (mk-syntax-triple internal-id new-id) + ;; mk-syntax-quad : identifier? identifier? -> quad/c + (define (mk-syntax-quad internal-id new-id) (with-syntax* ([id internal-id] [export-id new-id] [untyped-id (freshen-id #'id)]) - (define/with-syntax def - #`(define-syntax untyped-id - (lambda (stx) - (tc-error/stx stx "Macro ~a from typed module used in untyped code" 'untyped-id)))) (values - #`(begin def (def-export export-id id untyped-id)) + #`(begin) + ;; There's no need to put this macro in the submodule since it + ;; has no dependencies. + #`(begin + (define-syntax (untyped-id stx) + (tc-error/stx stx "Macro ~a from typed module used in untyped code" 'untyped-id)) + (def-export export-id id untyped-id)) new-id (list (list #'export-id #'id))))) - ;; mk-value-triple : identifier? identifier? (or/c Type #f) -> triple/c - (define (mk-value-triple internal-id new-id ty) + ;; mk-value-quad : identifier? identifier? (or/c Type #f) -> quad/c + (define (mk-value-quad internal-id new-id ty) (with-syntax* ([id internal-id] [untyped-id (freshen-id #'id)] + [local-untyped-id (freshen-id #'id)] [export-id new-id]) (define/with-syntax ctc (generate-temporary 'generated-contract)) + ;; Create the definitions of the contract and the contracted export. (define/with-syntax definitions (contract-def/provide-property #'(define-values (ctc) #f) (list ty #'untyped-id #'id pos-blame-id))) (values - #'(begin definitions (def-export export-id id untyped-id)) - new-id - null))) + ;; For the submodule + #`(begin definitions (provide untyped-id)) + ;; For the main module + #`(begin (define-syntax local-untyped-id (#,mk-redirect-id (quote-syntax untyped-id))) + (def-export export-id id local-untyped-id)) + new-id + null))) ;; Build the final provide with auxilliary definitions - (for/lists (l l*) ([(internal-id external-ids) (in-dict provs)]) - (define-values (defs id alias) (mk internal-id)) + (for/lists (defs export-defs provides aliases) ([(internal-id external-ids) (in-dict provs)]) + (define-values (defs export-def id alias) (mk internal-id)) (define provide-forms (for/list ([external-id (in-list external-ids)]) - #`(rename-out [#,id #,external-id]))) - (when (pair? external-ids) (set-box! include-extra-requires? #t)) - (values #`(begin #,defs (provide #,@provide-forms)) + (if (free-identifier=? id external-id) + id + #`(rename-out [#,id #,external-id])))) + (values #`(begin #,defs) + export-def + #`(provide #,@provide-forms) alias))) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index b54179b4..f6eaa461 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -6,13 +6,13 @@ (prefix-in c: (contract-req)) (rep type-rep) (types utils abbrev type-table struct-table) - (private parse-type type-annotation syntax-properties) + (private parse-type type-annotation syntax-properties type-contract) (env global-env init-envs type-name-env type-alias-env lexical-env env-req mvar-env scoped-tvar-env type-alias-helper) - (utils tc-utils) - (typecheck provide-handling def-binding tc-structs - typechecker internal-forms) + (utils tc-utils redirect-contract) + "provide-handling.rkt" "def-binding.rkt" "tc-structs.rkt" + "typechecker.rkt" "internal-forms.rkt" syntax/location racket/format (for-template @@ -269,6 +269,15 @@ [(define-syntaxes (nm ...) . rest) (syntax->list #'(nm ...))] [_ #f])) +(define-syntax-class unknown-provide-form + (pattern + (~and name + (~or (~datum protect) (~datum for-syntax) (~datum for-label) (~datum for-meta) + (~datum struct) (~datum all-from) (~datum all-from-except) + (~datum all-defined) (~datum all-defined-except) + (~datum prefix-all-defined) (~datum prefix-all-defined-except) + (~datum expand))))) + ;; actually do the work on a module ;; produces prelude and post-lude syntax objects ;; syntax-list -> (values syntax syntax) @@ -322,6 +331,10 @@ (define defs (append *defs (apply append (map tc-toplevel/pass1.5 forms)))) (do-time "Finished pass1") ;; separate the definitions into structures we'll handle for provides + ;; def-tbl : hash[id, binding] + ;; the id is the name defined by the binding + ;; XXX: why is it ever possible that we get duplicates here? + ;; iow, why isn't `merge-def-binding` always `error`? (define def-tbl (for/fold ([h (make-immutable-free-id-table)]) ([def (in-list defs)]) @@ -333,8 +346,7 @@ [(not other-def) def] [(plain-stx-binding? def) other-def] [(plain-stx-binding? other-def) def] - [else - (int-err "Two conflicting definitions: ~a ~a" def other-def)])) + [else (int-err "Two conflicting definitions: ~a ~a" def other-def)])) (dict-update h (binding-name def) merge-def-bindings #f))) (do-time "computed def-tbl") ;; typecheck the expressions and the rhss of defintions @@ -350,63 +362,130 @@ (list (syntax-property #'(void) 'mouse-over-tooltips (type-table->tooltips)))) ;; report delayed errors (report-all-errors) + ;; provide-tbl : hash[id, listof[id]] + ;; maps internal names to all the names they're provided as + ;; XXX: should the external names be symbols instead of identifiers? (define provide-tbl (for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)]) - (define-syntax-class unknown-provide-form - (pattern - (~and name - (~or (~datum protect) (~datum for-syntax) (~datum for-label) (~datum for-meta) - (~datum struct) (~datum all-from) (~datum all-from-except) - (~datum all-defined) (~datum all-defined-except) - (~datum prefix-all-defined) (~datum prefix-all-defined-except) - (~datum expand))))) (syntax-parse p #:literal-sets (kernel-literals) [(#%provide form ...) (for/fold ([h h]) ([f (in-syntax #'(form ...))]) - (parameterize ([current-orig-stx f]) - (syntax-parse f - [i:id - (dict-update h #'i (lambda (tail) (cons #'i tail)) '())] - [((~datum rename) in out) - (dict-update h #'in (lambda (tail) (cons #'out tail)) '())] - [(name:unknown-provide-form . _) - (tc-error "provide: ~a not supported by Typed Racket" (syntax-e #'name.name))] - [_ (int-err "unknown provide form")])))] + (syntax-parse f + [i:id + (dict-update h #'i (lambda (tail) (cons #'i tail)) '())] + [((~datum rename) in out) + (dict-update h #'in (lambda (tail) (cons #'out tail)) '())] + [(name:unknown-provide-form . _) + (parameterize ([current-orig-stx f]) + (tc-error "provide: ~a not supported by Typed Racket" (syntax-e #'name.name)))] + [_ (parameterize ([current-orig-stx f]) + (int-err "unknown provide form"))]))] [_ (int-err "non-provide form! ~a" (syntax->datum p))]))) ;; compute the new provides (define-values (new-stx/pre new-stx/post) (with-syntax* - ([the-variable-reference (generate-temporary #'blame)]) - (define-values (code aliasess) - (generate-prov def-tbl provide-tbl #'the-variable-reference)) - (define aliases (apply append aliasess)) - (define/with-syntax (new-provs ...) code) - (values - #`(begin - (begin-for-syntax - (module* #%type-decl #f - (#%plain-module-begin ;; avoid top-level printing and config - (require typed-racket/types/numeric-tower typed-racket/env/type-name-env - typed-racket/env/global-env typed-racket/env/type-alias-env - typed-racket/types/struct-table typed-racket/types/abbrev - (rename-in racket/private/sort [sort raw-sort])) - #,(env-init-code) - #,(talias-env-init-code) - #,(tname-env-init-code) - #,(tvariance-env-init-code) - #,(mvar-env-init-code mvar-env) - #,(make-struct-table-code) - #,@(for/list ([a (in-list aliases)]) - (match a - [(list from to) - #`(add-alias (quote-syntax #,from) (quote-syntax #,to))]))))) - (begin-for-syntax (add-mod! (variable-reference->module-path-index - (#%variable-reference))))) - #`(begin - #,(if (null? (syntax-e #'(new-provs ...))) - #'(begin) - #'(define the-variable-reference (quote-module-name))) - new-provs ...)))) + ([the-variable-reference (generate-temporary #'blame)] + [mk-redirect (generate-temporary #'make-redirect)]) + (define-values (defs export-defs provs aliasess) + (generate-prov def-tbl provide-tbl #'the-variable-reference #'mk-redirect)) + (define aliases (apply append aliasess)) + (define/with-syntax (new-defs ...) defs) + (define/with-syntax (new-export-defs ...) export-defs) + (define/with-syntax (new-provs ...) provs) + (values + #`(begin + ;; This syntax-time submodule records all the types for all + ;; definitions in this module, as well as type alias + ;; definitions, structure defintions, variance information, + ;; etc. It is `dynamic-require`d by the typechecker for any + ;; typed module that (transitively) depends on this + ;; module. We keep this in a submodule and use + ;; `dynamic-require` so that we don't load any of this code + ;; (and in particular all of its dependencies on the type + ;; checker) when just running a typed module. + (begin-for-syntax + (module* #%type-decl #f + (#%plain-module-begin ;; avoid top-level printing and config + (require typed-racket/types/numeric-tower typed-racket/env/type-name-env + typed-racket/env/global-env typed-racket/env/type-alias-env + typed-racket/types/struct-table typed-racket/types/abbrev + (rename-in racket/private/sort [sort raw-sort])) + #,(env-init-code) + #,(talias-env-init-code) + #,(tname-env-init-code) + #,(tvariance-env-init-code) + #,(mvar-env-init-code mvar-env) + #,(make-struct-table-code) + #,@(for/list ([a (in-list aliases)]) + (match-define (list from to) a) + #`(add-alias (quote-syntax #,from) (quote-syntax #,to)))))) + (begin-for-syntax (add-mod! (variable-reference->module-path-index + (#%variable-reference))))) + #`(begin + ;; FIXME: share this variable reference with the one below + (define the-variable-reference (quote-module-name)) + ;; Here we construct the redirector for the #%contract-defs + ;; submodule. The `mk-redirect` identifier is also used in + ;; the `new-export-defs`. + (begin-for-syntax + ;; We explicitly insert a `require` here since this module + ;; is `lazy-require`d and thus just doing a `require` + ;; outside wouldn't actually make the module + ;; available. The alternative would be to add an + ;; appropriate-phase `require` statically in a module + ;; that's non-dynamically depended on by + ;; `typed/racket`. That makes for confusing non-local + ;; dependencies, though, so we do it here. + (require typed-racket/utils/redirect-contract) + (define mk-redirect + (make-make-redirect-to-contract (#%variable-reference)))) + + ;; This submodule contains all the definitions of + ;; contracted identifiers. For an exported definition like + ;; (define f : T e) + ;; we generate the following defintions that go in the + ;; submodule: + ;; (define con ,(type->contract T)) + ;; (define f* (contract con 'pos 'neg f)) + ;; (provide (rename-out [f* f])) + ;; This is the `new-defs ...`. + ;; The `extra-requires` which go in the submodule are used + ;; (potentially) in the implementation of the contracts. + ;; + ;; The reason to construct this submodule is to avoid + ;; loading the contracts (or the `racket/contract` library + ;; itself) at the runtime of typed modules that don't need + ;; them. This is similar to the reason for the + ;; `#%type-decl` submodule. + (module* #%contract-defs #f + (#%plain-module-begin + #,extra-requires + new-defs ...)) + + ;; Now we create definitions that are actually provided + ;; from the module itself. There are two levels of + ;; indirection here (see the implementation in + ;; provide-handling.rkt). + ;; + ;; First, we generate a macro that expands to a + ;; `local-require` of the contracted identifier in the + ;; #%contract-defs submodule: + ;; (define-syntax con-f (mk-redirect f)) + ;; + ;; Then, we define a macro that is a rename-transformer for + ;; either the original `f` or `con-f`. + ;; (define-syntax export-f (renamer f con-f)) + ;; + ;; Note that we can't combine any of these indirections, + ;; because it's important for `export-f` to be a + ;; rename-transformer (making things like + ;; `syntax-local-value` work right), but `con-f` can't be, + ;; since it expands to a `local-require`. + new-export-defs ... + + ;; Finally, we do the export: + ;; (provide (rename-out [export-f f])) + new-provs ...)))) (do-time "finished provide generation") (values new-stx/pre new-stx/post)) diff --git a/typed-racket-lib/typed-racket/utils/redirect-contract.rkt b/typed-racket-lib/typed-racket/utils/redirect-contract.rkt new file mode 100644 index 00000000..ae599b7a --- /dev/null +++ b/typed-racket-lib/typed-racket/utils/redirect-contract.rkt @@ -0,0 +1,45 @@ +#lang racket/base + +(require syntax/modcollapse (for-template racket/base)) +(provide make-make-redirect-to-contract) + +;; This is used to define identifiers that expand to a local-require +;; of something else. It's used to implement identifiers that are +;; protected on export from TR with contracts, but where the +;; contracted defintion is in the #%contract-defs submodule. + +;; varref: a variable reference to the typed module that has the +;; appropriate submodule in it + +;; id: the name of the export from the submodule which will be +;; redirected-to by the local-require + +;; stx: the syntax object that's the argument to the macro (that is, +;; the stx object that's the reference to the typed identifier in +;; a untyped module). The funny eta-expansion with `redirect` is +;; so that we can recursively invoke it when the redirected id is +;; used in operator position. + +;; This code was originally written by mflatt for the plai-typed +;; language, and then slightly adapted for TR by samth. + +(define ((make-make-redirect-to-contract varref) id) + (define (redirect stx) + (cond + [(identifier? stx) + (with-syntax ([mp (collapse-module-path-index + (module-path-index-join + '(submod "." #%contract-defs) + (variable-reference->module-path-index + varref)))] + [i (datum->syntax id (syntax-e id) stx stx)]) + #`(let () + (local-require (only-in mp [#,(datum->syntax #'mp (syntax-e #'i)) i])) + i))] + [else + (datum->syntax stx + (cons (redirect (car (syntax-e stx))) + (cdr (syntax-e stx))) + stx + stx)])) + redirect)