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

Refactor provide handling.

Browse Source 
- use id-tables instead of lists
 - smarter iteration
 - prepare for eliminating declarations when not needed, but don't do it yet

original commit: 4925e7e51f487e3e9dcc3646a28cd30bf334cd02
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-21 15:39:40 -04:00
parent c903ffe15c
commit 3f49f996de
4 changed files with 141 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/typed-scheme/env/init-envs.rkt vendored
View File

@ -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))))

27
collects/typed-scheme/typecheck/def-export.rkt Normal file
View File

@ -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)))]))

188
collects/typed-scheme/typecheck/provide-handling.rkt
View File

@ -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])))))

34
collects/typed-scheme/typecheck/tc-toplevel.rkt
View File

@ -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