suzanne.soy/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
This commit is contained in:
Sam Tobin-Hochstadt 2010-06-21 15:39:40 -04:00
parent 3eb9a6d6d0
commit 4925e7e51f
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-env.rkt"
"type-name-env.rkt" "type-name-env.rkt"
"type-alias-env.rkt" "type-alias-env.rkt"
unstable/struct unstable/struct racket/dict
(rep type-rep object-rep filter-rep rep-utils) (rep type-rep object-rep filter-rep rep-utils)
(for-template (rep type-rep object-rep filter-rep) (for-template (rep type-rep object-rep filter-rep)
(types union) (types union)
@ -80,7 +80,7 @@
(show-sharing #f) (show-sharing #f)
(booleans-as-true/false #f)) (booleans-as-true/false #f))
(with-syntax ([registers (filter (lambda (x) x) (type-name-env-map 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 (talias-env-init-code)
(define (f id ty) (define (f id ty)
@ -91,18 +91,20 @@
(show-sharing #f) (show-sharing #f)
(booleans-as-true/false #f)) (booleans-as-true/false #f))
(with-syntax ([registers (filter (lambda (x) x) (type-alias-env-map 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) (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))) #`(register-type #'#,id #,(datum->syntax #'here (print-convert ty)))
#f)) #f))
(parameterize ((current-print-convert-hook converter) (parameterize ((current-print-convert-hook converter)
(show-sharing #f) (show-sharing #f)
(booleans-as-true/false #f)) (booleans-as-true/false #f))
(with-syntax ([registers (filter (lambda (x) x) (type-env-map f))]) (with-syntax ([registers (filter values (type-env-map f))])
#'(begin (begin-for-syntax . registers))))) #'(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) (private typed-renaming)
(rep type-rep) (rep type-rep)
(utils tc-utils) (utils tc-utils)
(for-syntax syntax/parse racket/base)
racket/contract/private/provide unstable/list racket/contract/private/provide unstable/list
unstable/debug unstable/debug syntax/id-table racket/dict
unstable/syntax scheme/struct-info scheme/match 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 (provide remove-provides provide? generate-prov get-alternate)
scheme/contract))
(provide remove-provides provide? generate-prov
get-alternate)
(define (provide? form) (define (provide? form)
(syntax-parse form (syntax-parse form
@ -29,21 +27,13 @@
(define (remove-provides forms) (define (remove-provides forms)
(filter (lambda (e) (not (provide? e))) (syntax->list 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) (define (mem? i vd)
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
[else #f])) [else #f]))
;; generate-contract-defs : listof[def-binding] listof[def-binding] id -> syntax -> syntax ;; generate-contract-defs : dict[id -> def-binding] dict[id -> id] id -> syntax
;; val-defs: define-values in this module ;; defs: defines in this module
;; stx-defs: define-syntaxes in this module ;; provs: provides in this module
;; pos-blame-id: a #%variable-reference for the module ;; pos-blame-id: a #%variable-reference for the module
;; internal-id : the id being provided ;; 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 ;; 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' ;; 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) ;; mk : id [id] -> (values syntax id)
(define (mk internal-id [new-id (generate-temporary internal-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 (cond
;; if it's already done, do nothing ;; if it's already done, do nothing
[(free-identifier-mapping-get mapping internal-id [(dict-ref mapping internal-id
;; if it wasn't there, put it in, and skip this case ;; if it wasn't there, put it in, and skip this case
(lambda () (λ () (dict-set! mapping internal-id new-id) #f))
(free-identifier-mapping-put! mapping internal-id new-id) => (λ (mapped-id) (values #'(begin) mapped-id))]
#f)) [(dict-ref defs internal-id #f)
=> (lambda (mapped-id)
(values #'(begin) mapped-id))]
[(mem? internal-id val-defs)
=> =>
(lambda (b) (match-lambda
(values [(def-binding _ (app (λ (ty) (type->contract ty (λ () #f) #:out #t)) (? values cnt)))
(with-syntax ([id internal-id]) (values
(cond [(type->contract (def-binding-ty b) (lambda () #f) #:out #t) (with-syntax* ([id internal-id]
=> [cnt-id (generate-temporary #'id)]
(lambda (cnt) [export-id new-id]
(with-syntax ([(cnt-id) (generate-temporaries #'(id))] [module-source pos-blame-id]
[export-id new-id] [the-contract (generate-temporary 'generated-contract)])
[module-source pos-blame-id] #`(begin
[the-contract (generate-temporary 'generated-contract)]) (define the-contract #,cnt)
#`(begin (define-syntax cnt-id
(define the-contract #,cnt) (make-provide/contract-transformer
(define-syntax cnt-id (quote-syntax the-contract)
(make-provide/contract-transformer (quote-syntax id)
(quote-syntax the-contract) (quote-syntax out-id)
(quote-syntax id) (quote-syntax module-source)))
(quote-syntax out-id) (def-export export-id id cnt-id)))
(quote-syntax module-source))) new-id)]
(define-syntax export-id [(def-binding id ty)
(if (unbox typed-context?) (values
(renamer #'id #:alt #'cnt-id) (with-syntax* ([id internal-id]
(renamer #'cnt-id))))))] [error-id (generate-temporary #'id)]
[else [export-id new-id])
(with-syntax ([(error-id) (generate-temporaries #'(id))] #'(begin
[export-id new-id]) (define-syntax (error-id stx)
#`(begin (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))
(define-syntax error-id (def-export export-id id error-id)))
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))) new-id)]
(define-syntax export-id [(and b (def-stx-binding _))
(if (unbox typed-context?) (with-syntax* ([id internal-id]
(renamer #'id #:alt #'error-id) [export-id new-id]
(renamer #'error-id)))))])) [untyped-id (generate-temporary #'id)]
new-id))] [def (mk-untyped-syntax b #'untyped-id internal-id)])
[(mem? internal-id stx-defs) (values
=> #`(begin def (def-export export-id id untyped-id #:alias))
(lambda (b) new-id))])]
(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)))]
;; otherwise, not defined in this module, not our problem ;; otherwise, not defined in this module, not our problem
[else (values #'(begin) internal-id)])) [else (values #'(begin) internal-id)]))
;; do-one : id [id] -> syntax ;; do-one : id id -> syntax
(define (do-one internal-id [external-id internal-id]) (for/list ([(internal-id external-id) (in-dict provs)])
(define-values (defs id) (mk internal-id)) (define-values (defs id) (mk internal-id))
#`(begin #,defs (provide (rename-out [#,id #,external-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))]))

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

@ -19,6 +19,7 @@
"provide-handling.rkt" "provide-handling.rkt"
"def-binding.rkt" "def-binding.rkt"
(prefix-in c: racket/contract) (prefix-in c: racket/contract)
racket/dict
(for-template (for-template
"internal-forms.rkt" "internal-forms.rkt"
unstable/location unstable/location
@ -259,24 +260,47 @@
;; do pass 1, and collect the defintions ;; do pass 1, and collect the defintions
(define defs (apply append (filter list? (map tc-toplevel/pass1 forms)))) (define defs (apply append (filter list? (map tc-toplevel/pass1 forms))))
;; separate the definitions into structures we'll handle for provides ;; separate the definitions into structures we'll handle for provides
(define stx-defs (filter def-stx-binding? defs)) (define def-tbl
(define val-defs (filter def-binding? defs)) (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 ;; typecheck the expressions and the rhss of defintions
(for-each tc-toplevel/pass2 forms) (for-each tc-toplevel/pass2 forms)
;; check that declarations correspond to definitions ;; check that declarations correspond to definitions
(check-all-registered-types) (check-all-registered-types)
;; report delayed errors ;; report delayed errors
(report-all-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 ;; compute the new provides
(with-syntax* (with-syntax*
([the-variable-reference (generate-temporary #'blame)] ([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 #`(begin
(define the-variable-reference (quote-module-path)) (define the-variable-reference (quote-module-path))
#,(env-init-code) #,(env-init-code syntax-provide? provide-tbl def-tbl)
#,(tname-env-init-code) #,(tname-env-init-code)
#,(talias-env-init-code) #,(talias-env-init-code)
(begin new-provs ... ...))))) (begin new-provs ...)))))
;; typecheck a whole module ;; typecheck a whole module
;; syntax -> syntax ;; syntax -> syntax