suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Revise type environment propagation to use submodules.

Browse Source 
Each typed module now defines a submodule named `type-decl`.
This module performs the type environment initialization (along
with other environment updates) when invoked.  Additionall,
every typed module, when invoked, performs a for-syntax addition
to a list specifying the submodules that need invocation.
This invocation is then performed by the `#%module-begin` from
Typed Racket.

The `type-decl` module always goes at the beginning of the
expanded module, so that it's available at syntax-time for all
the other submodules.  This involved adding pre- and post-
syntaxes for the results of typechecking.

This allows significant runtime dependency reduction from the
main `typed/racket` and `typed/racket/base` languages (not yet
complete).
This commit is contained in:
Sam Tobin-Hochstadt 2012-07-06 12:13:09 -04:00
parent 88f5f4c836
commit 6bf141513f
13 changed files with 150 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-racket/succeed/submodules.rkt
View File

@ -5,7 +5,7 @@
(provide g)
(module+ main
(module* main #f
(g (assert (string->number
(vector-ref (current-command-line-arguments) 0)))))

11
collects/typed-racket/core.rkt
View File

@ -9,6 +9,7 @@
(types utils convenience generalize)
(typecheck provide-handling tc-toplevel tc-app-helper)
(rep type-rep)
(env env-req)
(for-template (only-in (base-env prims) :type :print-type :query-result-type))
(utils utils tc-utils arm)
"tc-setup.rkt" "utils/debug.rkt")
@ -24,7 +25,7 @@
(parameterize ([optimize? (or (and (not (attribute opt?)) (optimize?))
(and (attribute opt?) (syntax-e (attribute opt?))))])
(tc-setup
stx pmb-form 'module-begin new-mod init tc-module after-code
stx pmb-form 'module-begin new-mod init tc-module before-code after-code
(with-syntax*
(;; pmb = #%plain-module-begin
[(pmb . body2) new-mod]
@ -42,7 +43,7 @@
'disappeared-use (disappeared-use-todo))])
;; reconstruct the module with the extra code
;; use the regular %#module-begin from `racket/base' for top-level printing
(arm #`(#%module-begin optimized-body ... #,after-code check-syntax-help))))))]))
(arm #`(#%module-begin #,before-code optimized-body ... #,after-code check-syntax-help))))))]))
(define did-I-suggest-:print-type-already? #f)
(define :print-type-message " ... [Use (:print-type <expr>) to see more.]")
@ -55,14 +56,14 @@
;; Prints the _entire_ type. May be quite large.
[(_ . ((~literal :print-type) e:expr))
#`(display #,(format "~a\n"
(tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form type
(tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form before type
(match type
[(tc-result1: t f o) t]
[(tc-results: t) (cons 'Values t)]))))]
;; given a function and a desired return type, fill in the blanks
[(_ . ((~literal :query-result-type) op:expr desired-type:expr))
(let ([expected (parse-type #'desired-type)])
(tc-setup #'stx #'op 'top-level expanded init tc-toplevel-form type
(tc-setup #'stx #'op 'top-level expanded init tc-toplevel-form before type
(match type
[(tc-result1: (and t (Function: _)) f o)
(let ([cleaned (cleanup-type t expected)])
@ -75,7 +76,7 @@
[_ (error (format "~a: not a function" (syntax->datum #'op) ))])))]
[(_ . form)
(tc-setup
stx #'form 'top-level body2 init tc-toplevel-form type
stx #'form 'top-level body2 init tc-toplevel-form before type
(with-syntax*
([optimized-body (car (maybe-optimize #`(#,body2)))])
(syntax-parse body2

23
collects/typed-racket/env/env-req.rkt vendored Normal file
View File

@ -0,0 +1,23 @@
#lang racket/base
(require racket/match)
(define module-name (make-parameter #f))
(define to-require null)
(define (add-mod! m)
;(printf ">> adding module ~v\n" m)
(set! to-require (cons m to-require)))
(define (fix m)
(match m
[`(file ,(? bytes? b))
`(file ,(bytes->string/utf-8 b))]
[_ m]))
(define (do-requires [ns (current-namespace)])
(parameterize ([current-namespace ns])
(for ([m (in-list to-require)]
#:when m)
;(printf ">> loading ~a\n" m)
(dynamic-require `(submod ,(fix m) type-decl) #f))))
(provide add-mod! do-requires module-name)

37
collects/typed-racket/env/init-envs.rkt vendored
View File

@ -7,7 +7,7 @@
"type-alias-env.rkt"
(rep type-rep object-rep filter-rep rep-utils)
(for-template (rep type-rep object-rep filter-rep)
(types union)
(types union numeric-tower)
racket/shared racket/base)
(types union convenience)
racket/syntax
@ -72,56 +72,35 @@
(not mp))
#f)))
(define (when-typed stx)
(syntax-case stx ()
[(def) #'(begin)]
[(def body0 body ...)
;; FIXME workaround for submodule issue
#'(when #true #;(unbox typed-context?) def body0 body ...)]))
(define (tname-env-init-code)
(define/with-syntax register (generate-temporary 'register))
(define (f id ty)
(if (bound-in-this-module id)
#`(register #'#,id #,(datum->syntax #'here (print-convert ty)))
#`(register-type-name #'#,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 values (type-name-env-map f))])
(when-typed
#'((define register (dynamic-require 'typed-racket/env/type-name-env 'register-type-name))
. registers)))))
#`(begin #,@(filter values (type-name-env-map f)))))
(define (talias-env-init-code)
(define/with-syntax register (generate-temporary 'register))
(define (f id ty)
(if (bound-in-this-module id)
#`(register #'#,id #,(datum->syntax #'here (print-convert ty)))
#`(register-resolved-type-alias #'#,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 values (type-alias-env-map f))])
(when-typed
#'((define register (dynamic-require 'typed-racket/env/type-alias-env 'register-resolved-type-alias))
. registers)))))
#`(begin #,@(filter values (type-alias-env-map f)))))
(define (env-init-code syntax-provide? provide-tbl def-tbl)
(define/with-syntax register (generate-temporary 'register))
(define (f id ty)
(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 #'#,id #,(datum->syntax #'here (print-convert ty)))
(if (bound-in-this-module id)
#`(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 values (type-env-map f))])
(when-typed
#'((define register (dynamic-require 'typed-racket/env/global-env 'register-type))
. registers)))))
#`(begin #,@(filter values (type-env-map f)))))

28
collects/typed-racket/env/type-alias-env.rkt vendored
View File

@ -1,7 +1,7 @@
#lang racket/base
(require "../utils/utils.rkt"
syntax/boundmap
syntax/id-table racket/dict
(utils tc-utils)
racket/match)
@ -17,9 +17,9 @@
;; a mapping from id -> alias-def (where id is the name of the type)
(define the-mapping
(make-module-identifier-mapping))
(make-free-id-table))
(define (mapping-put! id v) (module-identifier-mapping-put! the-mapping id v))
(define (mapping-put! id v) (dict-set! the-mapping id v))
;(trace mapping-put!)
@ -34,7 +34,7 @@
(define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))])
(let/ec return
(match (module-identifier-mapping-get the-mapping id (lambda () (return (k))))
(match (dict-ref the-mapping id (lambda () (return (k))))
[(struct unresolved (stx #f))
(resolve-type-alias id parse-type)]
[(struct unresolved (stx #t))
@ -42,7 +42,7 @@
[(struct resolved (t)) t])))
(define (resolve-type-alias id parse-type)
(define v (module-identifier-mapping-get the-mapping id))
(define v (dict-ref the-mapping id))
(match v
[(struct unresolved (stx _))
(set-unresolved-in-process! v #t)
@ -53,13 +53,17 @@
t]))
(define (resolve-type-aliases parse-type)
(module-identifier-mapping-for-each the-mapping (lambda (id _) (resolve-type-alias id parse-type))))
(free-id-table-for-each
the-mapping
(lambda (id k)
(resolve-type-alias id parse-type)))
#; ;; fixme – bug in free-id-mapping dict handling
(for ([(id _) (in-dict the-mapping)])
(resolve-type-alias id parse-type)))
;; map over the-mapping, producing a list
;; (id type -> T) -> listof[T]
(define (type-alias-env-map f)
(define sym (gensym))
(filter (lambda (e) (not (eq? sym e)))
(module-identifier-mapping-map the-mapping (lambda (id t) (if (resolved? t)
(f id (resolved-ty t))
sym)))))
(define (type-alias-env-map f)
(for/list ([(id t) (in-dict the-mapping)]
#:when (resolved? t))
(f id (resolved-ty t))))

6
collects/typed-racket/env/type-name-env.rkt vendored
View File

@ -1,7 +1,8 @@
#lang racket/base
(require "../utils/utils.rkt")
(require syntax/boundmap
(require syntax/boundmap
racket/dict
(env type-alias-env)
(utils tc-utils)
(rep type-rep)
@ -23,7 +24,6 @@
;; add a name to the mapping
;; identifier Type -> void
(define (register-type-name id [type #t])
;(printf "registering type ~a\n~a\n" (syntax-e id) id)
(mapping-put! id type))
;; add a bunch of names to the mapping
@ -46,5 +46,5 @@
(module-identifier-mapping-map the-mapping f))
(define (add-alias from to)
(when (lookup-type-name to (lambda () #f))
(when (lookup-type-name to (lambda () #f))
(register-resolved-type-alias from (make-Name to))))

4
collects/typed-racket/private/parse-type.rkt
View File

@ -5,7 +5,7 @@
(rename-in (types convenience union utils printer filter-ops) [make-arr* make-arr])
(utils tc-utils stxclass-util)
syntax/stx (prefix-in c: racket/contract)
syntax/parse
syntax/parse racket/dict
(env type-env-structs tvar-env type-name-env type-alias-env lexical-env index-env)
racket/match
"parse-classes.rkt"
@ -328,7 +328,7 @@
[(free-identifier=? #'id #'t:->)
(tc-error/delayed "Incorrect use of -> type constructor")
Err]
[else
[else
(tc-error/delayed
"Unbound type name ~a"
(syntax-e #'id))

8
collects/typed-racket/tc-setup.rkt
View File

@ -6,7 +6,7 @@
(private type-contract)
(types utils convenience)
(typecheck typechecker provide-handling tc-toplevel)
(env tvar-env type-name-env type-alias-env)
(env tvar-env type-name-env type-alias-env env-req)
(r:infer infer)
(utils tc-utils disarm mutated-vars debug)
(rep type-rep)
@ -32,7 +32,7 @@
(do-time "Optimized")))
body))
(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx init checker result . body)
(define-syntax-rule (tc-setup orig-stx stx expand-ctxt fully-expanded-stx init checker pre-result post-result . body)
(let ()
(set-box! typed-context? #t)
;(start-timing (syntax-property stx 'enclosing-module-name))
@ -47,6 +47,8 @@
[delay-errors? #t]
;; do we print the fully-expanded syntax?
[print-syntax? #f]
;; the name of this module:
[module-name (syntax-property orig-stx 'enclosing-module-name)]
;; this parameter is just for printing types
;; this is a parameter to avoid dependency issues
[current-type-names
@ -70,6 +72,6 @@
[expanded-module-stx fully-expanded-stx]
[debugging? #f])
(do-time "Starting `checker'")
(define result (checker fully-expanded-stx))
(define-values (pre-result post-result) (checker fully-expanded-stx))
(do-time "Typechecking Done")
(let () . body))))))

7
collects/typed-racket/typecheck/def-export.rkt
View File

@ -11,11 +11,4 @@
#'(define-syntax export-id
(if (unbox typed-context?)
(renamer #'id #'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 #'cnt-id))
(renamer #'cnt-id)))]))

72
collects/typed-racket/typecheck/provide-handling.rkt
View File

@ -45,38 +45,42 @@
;; 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)
;; mk : id [id] -> (values syntax id aliases)
(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))
(define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same)
(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
(let ((info (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*)))
#,(if type-is-constructor?
#'(make-struct-info-self-ctor constr* info)
#'info)))))))]
(match-define (list type-desc constr pred (list accs ...) muts super) (extract-struct-info si))
(define-values (defns new-ids aliases)
(map/values 3
(lambda (e) (if (identifier? e)
(mk e)
(values #'(begin) e null)))
(list* type-desc constr pred super accs)))
(define/with-syntax (type-desc* constr* pred* super* accs* ...)
(for/list ([i new-ids]) (if (identifier? i) #`(syntax #,i) i)))
(values
#`(begin
#,@defns
(define-syntax #,defn-id
(let ((info (list type-desc* constr* pred* (list accs* ...) (list #,@(map (lambda x #'#f) accs)) super*)))
#,(if type-is-constructor?
#'(make-struct-info-self-ctor constr* info)
#'info))))
(apply append aliases))]
[_
#`(define-syntax #,defn-id
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))]))
(values
#`(define-syntax #,defn-id
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'#,internal-id))))
null)]))
(cond
;; if it's already done, do nothing
[(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))]
=> (λ (mapped-id) (values #'(begin) mapped-id null))]
[(dict-ref defs internal-id #f)
=>
(match-lambda
@ -96,7 +100,8 @@
(quote-syntax export-id)
(quote-syntax module-source)))
(def-export export-id id cnt-id)))
new-id)]
new-id
null)]
[(def-binding id ty)
(values
(with-syntax* ([id internal-id]
@ -106,21 +111,26 @@
(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)]
new-id
null)]
[(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)])
[untyped-id (generate-temporary #'id)])
(define-values (d aliases)
(mk-untyped-syntax b #'untyped-id internal-id))
(define/with-syntax def d)
(values
#`(begin def (def-export export-id id untyped-id #:alias))
new-id))])]
#`(begin def (def-export export-id id untyped-id))
new-id
(cons (list #'export-id #'id) aliases)))])]
;; otherwise, not defined in this module, not our problem
[else (values #'(begin) internal-id)]))
[else (values #'(begin) internal-id null)]))
;; Build the final provide with auxilliary definitions
(for/list ([(internal-id external-ids) (in-dict provs)])
(define-values (defs id) (mk internal-id))
(for/lists (l l*) ([(internal-id external-ids) (in-dict provs)])
(define-values (defs id alias) (mk internal-id))
(define provide-forms
(for/list ([external-id (in-list external-ids)])
#`(rename-out [#,id #,external-id])))
#`(begin #,defs (provide #,@provide-forms))))
(values #`(begin #,defs (provide #,@provide-forms))
alias)))

53
collects/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -3,7 +3,7 @@
(require (rename-in "../utils/utils.rkt" [infer r:infer])
syntax/kerncase
unstable/list racket/syntax syntax/parse
mzlib/etc
mzlib/etc racket/list
racket/match
"signatures.rkt"
"tc-structs.rkt"
@ -13,13 +13,14 @@
(rep type-rep)
(types utils convenience type-table)
(private parse-type type-annotation type-contract)
(env global-env init-envs type-name-env type-alias-env lexical-env)
(env global-env init-envs type-name-env type-alias-env lexical-env env-req)
syntax/id-table
(utils tc-utils mutated-vars)
"provide-handling.rkt"
"def-binding.rkt"
(prefix-in c: racket/contract)
racket/dict
syntax/location
(for-template
"internal-forms.rkt"
syntax/location
@ -27,9 +28,9 @@
racket/base))
(c:provide/contract
[type-check (syntax? . c:-> . syntax?)]
[tc-module (syntax? . c:-> . syntax?)]
[tc-toplevel-form (syntax? . c:-> . c:any/c)])
[type-check (syntax? . c:-> . (values syntax? syntax?))]
[tc-module (syntax? . c:-> . (values syntax? syntax?))]
[tc-toplevel-form (syntax? . c:-> . (values #f c:any/c))])
(define unann-defs (make-free-id-table))
@ -264,6 +265,9 @@
(values #'nm #'ty)]
[_ (int-err "not define-type-alias")]))
;; actually do the work on a module
;; produces prelude and post-lude syntax objects
;; syntax-list -> (values syntax syntax)
(define (type-check forms0)
(define forms (syntax->list forms0))
(define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs)
@ -328,25 +332,38 @@
[_ (int-err "unknown provide form")])))]
[_ (int-err "non-provide form! ~a" (syntax->datum p))])))
;; compute the new provides
(define new-stx
(define-values (new-stx/pre new-stx/post)
(with-syntax*
([the-variable-reference (generate-temporary #'blame)]
[(new-provs ...)
(generate-prov def-tbl provide-tbl #'the-variable-reference)])
([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
(require typed-racket/types/numeric-tower typed-racket/env/type-name-env
typed-racket/env/global-env typed-racket/env/type-alias-env)
#,(env-init-code syntax-provide? provide-tbl def-tbl)
#,(talias-env-init-code)
#,(tname-env-init-code)
#,(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! (quote-module-path))))
#`(begin
#,(if (null? (syntax-e #'(new-provs ...)))
#'(begin)
#'(define the-variable-reference (quote-module-name)))
(begin-for-syntax #,(env-init-code syntax-provide? provide-tbl def-tbl)
#,(tname-env-init-code)
#,(talias-env-init-code)
#,(make-struct-table-code))
(begin new-provs ...))))
#'(define the-variable-reference (quote-module-name)))
new-provs ...))))
(do-time "finished provide generation")
new-stx)
(values new-stx/pre new-stx/post))
;; typecheck a whole module
;; syntax -> syntax
;; syntax -> (values syntax syntax)
(define (tc-module stx)
(syntax-parse stx
[(pmb . forms) (type-check #'forms)]))
@ -356,6 +373,6 @@
;; syntax -> void
(define (tc-toplevel-form form)
(tc-toplevel/pass1 form)
(begin0 (tc-toplevel/pass2 form)
(begin0 (values #f (tc-toplevel/pass2 form))
(report-all-errors)))

5
collects/typed-racket/typed-racket.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require
(for-syntax racket/base "utils/timing.rkt") ;; only for timing/debugging
(for-syntax racket/base "utils/timing.rkt" "env/env-req.rkt") ;; only for timing/debugging
;; the below requires are needed since they provide identifiers
;; that may appear in the residual program
(for-syntax "typecheck/renamer.rkt")
@ -26,7 +26,8 @@
(do-time "Finshed base-env-numeric")
((dynamic-require 'typed-racket/base-env/base-special-env 'initialize-special))
(do-time "Finished base-special-env")
(set! initialized #t)))
(set! initialized #t))
(do-requires))
(define-syntax-rule (drivers [name sym] ...)
(begin

8
collects/typed-racket/types/type-table.rkt
View File

@ -7,7 +7,13 @@
(rep type-rep object-rep)
(types utils union)
(utils tc-utils)
(env init-envs))
(env init-envs)
(for-template
racket/base
(rep type-rep object-rep)
(types utils union)
(utils tc-utils)
(env init-envs)))
(define table (make-hasheq))