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

expander: shortcut for parsing already expanded

Browse Source 
When a `module` or `let-syntax` form is `expand`ed (i.e., when a
syntax object must be generated), then code is expanded to a syntax
object and then parsed again for compilation. In that second parse,
take advantage of the fact that the expression is already expanded,
which means that no new scopes or bindings need to be created.

Related to #3165
This commit is contained in:
Matthew Flatt 2020-05-21 18:11:04 -06:00
parent bdb0256220
commit a17e662597
5 changed files with 992 additions and 774 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
racket/src/expander/expand/context.rkt
View File

@ -71,7 +71,7 @@
for-serializable? ; accumulate submodules as serializable? for-serializable? ; accumulate submodules as serializable?
to-correlated-linklet? ; compile to machine-independent linklets? to-correlated-linklet? ; compile to machine-independent linklets?
normalize-locals? ; forget original local-variable names normalize-locals? ; forget original local-variable names
should-not-encounter-macros? ; #t when "expanding" to parse parsing-expanded? ; #t when "expanding" to parse
skip-visit-available?)) ; avoid instantiation cycles skip-visit-available?)) ; avoid instantiation cycles
(define (make-expand-context ns (define (make-expand-context ns
@ -218,7 +218,7 @@
(struct*-copy expand-context ctx (struct*-copy expand-context ctx
[to-parsed? #t] [to-parsed? #t]
[observer #f] [observer #f]
[should-not-encounter-macros? #t])) [parsing-expanded? #t]))
;; ---------------------------------------- ;; ----------------------------------------

12
racket/src/expander/expand/env.rkt
View File

@ -33,7 +33,9 @@
add-bulk-binding! add-bulk-binding!
add-local-binding! add-local-binding!
binding-lookup) binding-lookup
existing-binding-key)
;; ---------------------------------------- ;; ----------------------------------------
@ -175,3 +177,11 @@
(raise-syntax-error #f (raise-syntax-error #f
"cannot use identifier tainted by macro transformation" "cannot use identifier tainted by macro transformation"
id))) id)))
;; ----------------------------------------
(define (existing-binding-key id phase)
(define b (resolve+shift id phase #:immediate? #t))
(unless (local-binding? b)
(raise-syntax-error #f "expected an existing local binding for an already-expanded identifier" id))
(local-binding-key b))

114
racket/src/expander/expand/expr.rkt
View File

@ -32,7 +32,8 @@
;; Common expansion for `lambda` and `case-lambda` ;; Common expansion for `lambda` and `case-lambda`
(define (lambda-clause-expander s disarmed-s formals bodys ctx) (define (lambda-clause-expander s disarmed-s formals bodys ctx)
(define sc (new-scope 'local)) (define sc (and (not (expand-context-parsing-expanded? ctx))
(new-scope 'local)))
(define phase (expand-context-phase ctx)) (define phase (expand-context-phase ctx))
;; Parse and check formal arguments: ;; Parse and check formal arguments:
(define ids (parse-and-flatten-formals formals sc disarmed-s)) (define ids (parse-and-flatten-formals formals sc disarmed-s))
@ -42,20 +43,31 @@
(define counter (root-expand-context-counter ctx)) (define counter (root-expand-context-counter ctx))
(define local-sym (and (expand-context-normalize-locals? ctx) 'arg)) (define local-sym (and (expand-context-normalize-locals? ctx) 'arg))
(define keys (for/list ([id (in-list ids)]) (define keys (for/list ([id (in-list ids)])
(add-local-binding! id phase counter #:in s #:local-sym local-sym))) (if sc
(add-local-binding! id phase counter #:in s #:local-sym local-sym)
(existing-binding-key id (expand-context-phase ctx)))))
(define body-env (for/fold ([env (expand-context-env ctx)]) ([key (in-list keys)] (define body-env (for/fold ([env (expand-context-env ctx)]) ([key (in-list keys)]
[id (in-list ids)]) [id (in-list ids)])
(env-extend env key (local-variable id)))) (env-extend env key (local-variable id))))
(define sc-formals (add-scope formals sc)) (define sc-formals (if sc (add-scope formals sc) formals))
(define sc-bodys (for/list ([body (in-list bodys)]) (add-scope body sc))) (define sc-bodys (if sc
(for/list ([body (in-list bodys)]) (add-scope body sc))
bodys))
(log-expand ctx 'lambda-renames sc-formals sc-bodys) (log-expand ctx 'lambda-renames sc-formals sc-bodys)
;; Expand the function body: ;; Expand the function body:
(define body-ctx (struct*-copy expand-context ctx (define body-ctx (struct*-copy expand-context ctx
[env body-env] [env body-env]
[scopes (cons sc (expand-context-scopes ctx))] [scopes (if sc
[binding-layer (increment-binding-layer ids ctx sc)] (cons sc (expand-context-scopes ctx))
(expand-context-scopes ctx))]
[binding-layer (if sc
(increment-binding-layer ids ctx sc)
(expand-context-binding-layer ctx))]
[frame-id #:parent root-expand-context #f])) [frame-id #:parent root-expand-context #f]))
(define exp-body (expand-body sc-bodys body-ctx #:source (keep-as-needed ctx s #:keep-for-error? #t))) (define exp-body (if sc
(expand-body sc-bodys body-ctx #:source (keep-as-needed ctx s #:keep-for-error? #t))
(for/list ([sc-body (in-list sc-bodys)])
(expand sc-body body-ctx))))
;; Return formals (with new scope) and expanded body: ;; Return formals (with new scope) and expanded body:
(values (if (expand-context-to-parsed? ctx) (values (if (expand-context-to-parsed? ctx)
(unflatten-like-formals keys formals) (unflatten-like-formals keys formals)
@ -126,7 +138,9 @@
(define (parse-and-flatten-formals all-formals sc s) (define (parse-and-flatten-formals all-formals sc s)
(let loop ([formals all-formals]) (let loop ([formals all-formals])
(cond (cond
[(identifier? formals) (list (add-scope formals sc))] [(identifier? formals) (list (if sc
(add-scope formals sc)
formals))]
[(syntax? formals) [(syntax? formals)
(define p (syntax-e formals)) (define p (syntax-e formals))
(cond (cond
@ -171,8 +185,13 @@
(define-match val-m disarmed-s #:unless syntaxes? (define-match val-m disarmed-s #:unless syntaxes?
'(let-values ([(id:val ...) val-rhs] ...) '(let-values ([(id:val ...) val-rhs] ...)
body ...+)) body ...+))
(define sc (new-scope 'local)) (define sc (and (not (expand-context-parsing-expanded? ctx))
(define body-sc (and rec? (new-scope 'letrec-body))) (new-scope 'local)))
(when (and syntaxes? (not sc))
(raise-syntax-error #f
"encountered `letrec-syntaxes` in form that should be fully expanded"
s))
(define body-sc (and sc rec? (new-scope 'letrec-body)))
(define phase (expand-context-phase ctx)) (define phase (expand-context-phase ctx))
(define frame-id (and syntaxes? (define frame-id (and syntaxes?
(make-reference-record))) ; accumulates info on referenced variables (make-reference-record))) ; accumulates info on referenced variables
@ -184,13 +203,17 @@
(for/list ([rhs (in-list (stx-m 'trans-rhs))]) (for/list ([rhs (in-list (stx-m 'trans-rhs))])
(add-scope rhs sc)) (add-scope rhs sc))
'())) '()))
(define val-idss (for/list ([ids (in-list (if syntaxes? (stx-m 'id:val) (val-m 'id:val)))]) (define val-idss (let ([val-idss (if syntaxes? (stx-m 'id:val) (val-m 'id:val))])
(for/list ([id (in-list ids)]) (if sc
(add-scope id sc)))) (for/list ([ids (in-list val-idss)])
(define val-rhss (if rec? (for/list ([id (in-list ids)])
(for/list ([rhs (in-list (if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs)))]) (add-scope id sc)))
(add-scope rhs sc)) val-idss)))
(if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs)))) (define val-rhss (let ([val-rhss (if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs))])
(if (and rec? sc)
(for/list ([rhs (in-list val-rhss)])
(add-scope rhs sc))
val-rhss)))
(define val-clauses ; for syntax tracking (define val-clauses ; for syntax tracking
(cond (cond
[syntaxes? [syntaxes?
@ -208,18 +231,23 @@
(for/list ([id (in-list ids)]) (for/list ([id (in-list ids)])
(add-local-binding! id phase counter (add-local-binding! id phase counter
#:frame-id frame-id #:in s #:frame-id frame-id #:in s
#:local-sym local-sym)))) #:local-sym local-sym))))
(define val-keyss (for/list ([ids (in-list val-idss)]) (define val-keyss (for/list ([ids (in-list val-idss)])
(for/list ([id (in-list ids)]) (for/list ([id (in-list ids)])
(add-local-binding! id phase counter (if sc
#:frame-id frame-id #:in s (add-local-binding! id phase counter
#:local-sym local-sym)))) #:frame-id frame-id #:in s
#:local-sym local-sym)
(existing-binding-key id (expand-context-phase ctx))))))
;; Add new scope to body: ;; Add new scope to body:
(define bodys (for/list ([body (in-list (if syntaxes? (stx-m 'body) (val-m 'body)))]) (define bodys (let ([bodys (if syntaxes? (stx-m 'body) (val-m 'body))])
(define new-body (add-scope body sc)) (if sc
(if rec? (for/list ([body (in-list bodys)])
(add-scope new-body body-sc) (define new-body (add-scope body sc))
new-body))) (if rec?
(add-scope new-body body-sc)
new-body))
bodys)))
(log-expand ctx 'letX-renames trans-idss trans-rhss val-idss val-rhss bodys) (log-expand ctx 'letX-renames trans-idss trans-rhss val-idss val-rhss bodys)
;; Evaluate compile-time expressions (if any): ;; Evaluate compile-time expressions (if any):
(when syntaxes? (when syntaxes?
@ -255,17 +283,21 @@
(define orig-rrs (expand-context-reference-records expr-ctx)) (define orig-rrs (expand-context-reference-records expr-ctx))
(define rec-ctx (struct*-copy expand-context expr-ctx (define rec-ctx (struct*-copy expand-context expr-ctx
[env rec-env] [env rec-env]
[scopes (let ([scopes (cons sc (expand-context-scopes ctx))]) [scopes (if sc
(if rec? (let ([scopes (cons sc (expand-context-scopes ctx))])
(cons body-sc scopes) (if rec?
scopes))] (cons body-sc scopes)
scopes))
(expand-context-scopes ctx))]
[reference-records (if split-by-reference? [reference-records (if split-by-reference?
(cons frame-id orig-rrs) (cons frame-id orig-rrs)
orig-rrs)] orig-rrs)]
[binding-layer (increment-binding-layer [binding-layer (if sc
(cons trans-idss val-idss) (increment-binding-layer
ctx (cons trans-idss val-idss)
sc)])) ctx
sc)
(expand-context-binding-layer ctx))]))
(define letrec-values-id (define letrec-values-id
(and (not (expand-context-to-parsed? ctx)) (and (not (expand-context-to-parsed? ctx))
(if syntaxes? (if syntaxes?
@ -280,10 +312,14 @@
val-idss)) val-idss))
(define (get-body) (define (get-body)
(define body-ctx (struct*-copy expand-context rec-ctx (cond
[reference-records orig-rrs])) [(expand-context-parsing-expanded? ctx)
(expand-body bodys (as-tail-context body-ctx #:wrt ctx) #:source rebuild-s)) (for/list ([body (in-list bodys)])
(expand body rec-ctx))]
[else
(define body-ctx (struct*-copy expand-context rec-ctx
[reference-records orig-rrs]))
(expand-body bodys (as-tail-context body-ctx #:wrt ctx) #:source rebuild-s)]))
(define result-s (define result-s
(cond (cond
[(not split-by-reference?) [(not split-by-reference?)
@ -645,7 +681,7 @@
(root-expand-context-self-mpi ctx)))) (root-expand-context-self-mpi ctx))))
(raise-syntax-error #f "cannot mutate module-required identifier" s id)) (raise-syntax-error #f "cannot mutate module-required identifier" s id))
(log-expand ctx 'next) (log-expand ctx 'next)
(register-variable-referenced-if-local! binding) (register-variable-referenced-if-local! binding ctx)
(define rebuild-s (keep-as-needed ctx s)) (define rebuild-s (keep-as-needed ctx s))
(define exp-rhs (expand (m 'rhs) (as-expression-context ctx))) (define exp-rhs (expand (m 'rhs) (as-expression-context ctx)))
(if (expand-context-to-parsed? ctx) (if (expand-context-to-parsed? ctx)

9
racket/src/expander/expand/main.rkt
View File

@ -300,7 +300,7 @@
(define adj-s (avoid-current-expand-context (substitute-alternate-id s id) t ctx)) (define adj-s (avoid-current-expand-context (substitute-alternate-id s id) t ctx))
(log-expand ctx 'tag/context adj-s) (log-expand ctx 'tag/context adj-s)
(expand adj-s ctx)] (expand adj-s ctx)]
[(and (expand-context-should-not-encounter-macros? ctx) [(and (expand-context-parsing-expanded? ctx)
;; It's ok to have a rename transformer whose target ;; It's ok to have a rename transformer whose target
;; is a primitive form, so if it's a rename transformer, ;; is a primitive form, so if it's a rename transformer,
;; delay the check for another step ;; delay the check for another step
@ -334,7 +334,7 @@
[else [else
(log-expand ctx 'variable s id) (log-expand ctx 'variable s id)
;; A reference to a variable expands to itself ;; A reference to a variable expands to itself
(register-variable-referenced-if-local! binding) (register-variable-referenced-if-local! binding ctx)
;; If the variable is locally bound, replace the use's scopes with the binding's scopes ;; If the variable is locally bound, replace the use's scopes with the binding's scopes
(define result-s (substitute-variable id t #:no-stops? (free-id-set-empty-or-just-module*? (expand-context-stops ctx)))) (define result-s (substitute-variable id t #:no-stops? (free-id-set-empty-or-just-module*? (expand-context-stops ctx))))
(cond (cond
@ -526,11 +526,12 @@
s) s)
s)])) s)]))
(define (register-variable-referenced-if-local! binding) (define (register-variable-referenced-if-local! binding ctx)
;; If the binding's frame has a reference record, then register ;; If the binding's frame has a reference record, then register
;; the use for the purposes of `letrec` splitting ;; the use for the purposes of `letrec` splitting
(when (and (local-binding? binding) (when (and (local-binding? binding)
(reference-record? (binding-frame-id binding))) (reference-record? (binding-frame-id binding))
(not (expand-context-parsing-expanded? ctx)))
(reference-record-used! (binding-frame-id binding) (local-binding-key binding)))) (reference-record-used! (binding-frame-id binding) (local-binding-key binding))))
;; ---------------------------------------- ;; ----------------------------------------

1627
racket/src/racket/src/startup.inc
View File

File diff suppressed because it is too large Load Diff