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?
to-correlated-linklet? ; compile to machine-independent linklets?
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
(define (make-expand-context ns
@ -218,7 +218,7 @@
(struct*-copy expand-context ctx
[to-parsed? #t]
[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-local-binding!
binding-lookup)
binding-lookup
existing-binding-key)
;; ----------------------------------------
@ -175,3 +177,11 @@
(raise-syntax-error #f
"cannot use identifier tainted by macro transformation"
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`
(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))
;; Parse and check formal arguments:
(define ids (parse-and-flatten-formals formals sc disarmed-s))
@ -42,20 +43,31 @@
(define counter (root-expand-context-counter ctx))
(define local-sym (and (expand-context-normalize-locals? ctx) 'arg))
(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)]
[id (in-list ids)])
(env-extend env key (local-variable id))))
(define sc-formals (add-scope formals sc))
(define sc-bodys (for/list ([body (in-list bodys)]) (add-scope body sc)))
(define sc-formals (if sc (add-scope formals sc) formals))
(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)
;; Expand the function body:
(define body-ctx (struct*-copy expand-context ctx
[env body-env]
[scopes (cons sc (expand-context-scopes ctx))]
[binding-layer (increment-binding-layer ids ctx sc)]
[scopes (if 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]))
(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:
(values (if (expand-context-to-parsed? ctx)
(unflatten-like-formals keys formals)
@ -126,7 +138,9 @@
(define (parse-and-flatten-formals all-formals sc s)
(let loop ([formals all-formals])
(cond
[(identifier? formals) (list (add-scope formals sc))]
[(identifier? formals) (list (if sc
(add-scope formals sc)
formals))]
[(syntax? formals)
(define p (syntax-e formals))
(cond
@ -171,8 +185,13 @@
(define-match val-m disarmed-s #:unless syntaxes?
'(let-values ([(id:val ...) val-rhs] ...)
body ...+))
(define sc (new-scope 'local))
(define body-sc (and rec? (new-scope 'letrec-body)))
(define sc (and (not (expand-context-parsing-expanded? ctx))
(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 frame-id (and syntaxes?
(make-reference-record))) ; accumulates info on referenced variables
@ -184,13 +203,17 @@
(for/list ([rhs (in-list (stx-m 'trans-rhs))])
(add-scope rhs sc))
'()))
(define val-idss (for/list ([ids (in-list (if syntaxes? (stx-m 'id:val) (val-m 'id:val)))])
(for/list ([id (in-list ids)])
(add-scope id sc))))
(define val-rhss (if rec?
(for/list ([rhs (in-list (if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs)))])
(add-scope rhs sc))
(if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs))))
(define val-idss (let ([val-idss (if syntaxes? (stx-m 'id:val) (val-m 'id:val))])
(if sc
(for/list ([ids (in-list val-idss)])
(for/list ([id (in-list ids)])
(add-scope id sc)))
val-idss)))
(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
(cond
[syntaxes?
@ -208,18 +231,23 @@
(for/list ([id (in-list ids)])
(add-local-binding! id phase counter
#:frame-id frame-id #:in s
#:local-sym local-sym))))
#:local-sym local-sym))))
(define val-keyss (for/list ([ids (in-list val-idss)])
(for/list ([id (in-list ids)])
(add-local-binding! id phase counter
#:frame-id frame-id #:in s
#:local-sym local-sym))))
(if sc
(add-local-binding! id phase counter
#:frame-id frame-id #:in s
#:local-sym local-sym)
(existing-binding-key id (expand-context-phase ctx))))))
;; Add new scope to body:
(define bodys (for/list ([body (in-list (if syntaxes? (stx-m 'body) (val-m 'body)))])
(define new-body (add-scope body sc))
(if rec?
(add-scope new-body body-sc)
new-body)))
(define bodys (let ([bodys (if syntaxes? (stx-m 'body) (val-m 'body))])
(if sc
(for/list ([body (in-list bodys)])
(define new-body (add-scope body sc))
(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)
;; Evaluate compile-time expressions (if any):
(when syntaxes?
@ -255,17 +283,21 @@
(define orig-rrs (expand-context-reference-records expr-ctx))
(define rec-ctx (struct*-copy expand-context expr-ctx
[env rec-env]
[scopes (let ([scopes (cons sc (expand-context-scopes ctx))])
(if rec?
(cons body-sc scopes)
scopes))]
[scopes (if sc
(let ([scopes (cons sc (expand-context-scopes ctx))])
(if rec?
(cons body-sc scopes)
scopes))
(expand-context-scopes ctx))]
[reference-records (if split-by-reference?
(cons frame-id orig-rrs)
orig-rrs)]
[binding-layer (increment-binding-layer
(cons trans-idss val-idss)
ctx
sc)]))
[binding-layer (if sc
(increment-binding-layer
(cons trans-idss val-idss)
ctx
sc)
(expand-context-binding-layer ctx))]))
(define letrec-values-id
(and (not (expand-context-to-parsed? ctx))
(if syntaxes?
@ -280,10 +312,14 @@
val-idss))
(define (get-body)
(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))
(cond
[(expand-context-parsing-expanded? ctx)
(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
(cond
[(not split-by-reference?)
@ -645,7 +681,7 @@
(root-expand-context-self-mpi ctx))))
(raise-syntax-error #f "cannot mutate module-required identifier" s id))
(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 exp-rhs (expand (m 'rhs) (as-expression-context 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))
(log-expand ctx 'tag/context adj-s)
(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
;; is a primitive form, so if it's a rename transformer,
;; delay the check for another step
@ -334,7 +334,7 @@
[else
(log-expand ctx 'variable s id)
;; 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
(define result-s (substitute-variable id t #:no-stops? (free-id-set-empty-or-just-module*? (expand-context-stops ctx))))
(cond
@ -526,11 +526,12 @@
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
;; the use for the purposes of `letrec` splitting
(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))))
;; ----------------------------------------

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

File diff suppressed because it is too large Load Diff