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

syntax/parse: reduce allocation when parsing cannot fail

Browse Source 
When parsing cannot fail, avoid allocating expectstacks and
failures (thanks samth for the idea). Allocation still happens
for progress and failuresets (conses of #t, now), though.

Compile with `PLTSTDERR="debug@syntax-parse"` to log cannot-fail
syntax-parse expressions and syntax class definitions.
This commit is contained in:
Ryan Culpepper 2016-12-01 21:26:26 -05:00
parent e676ba74a5
commit bcc8535b78
4 changed files with 56 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
racket/collects/syntax/parse/private/parse.rkt
View File

@ -97,7 +97,7 @@
(if (predicate x)
(success fh0)
(let ([es (es-add-thing pr 'description #t rl es)])
(fh0 (failure pr es)))))))]))
(fh0 (failure* pr es)))))))]))
(define-syntax (parser/rhs stx)
(syntax-case stx ()
@ -108,23 +108,27 @@
(parameterize ((current-syntax-context #'ctx))
(parse-rhs #'rhss (syntax->datum #'relsattrs) (syntax-e #'splicing?)
#:context #'ctx)))
(rhs->parser #'name #'formals #'relsattrs the-rhs (syntax-e #'splicing?))))]))
(rhs->parser #'name #'formals #'relsattrs the-rhs (syntax-e #'splicing?) #'ctx)))]))
(begin-for-syntax
(define (rhs->parser name formals relsattrs the-rhs splicing?)
(define (rhs->parser name formals relsattrs the-rhs splicing? [ctx #f])
(define-values (transparent? description variants defs commit? delimit-cut?)
(match the-rhs
[(rhs _ transparent? description variants defs commit? delimit-cut?)
(values transparent? description variants defs commit? delimit-cut?)]))
(define vdefss (map variant-definitions variants))
(define formals* (rewrite-formals formals #'x #'rl))
(define patterns (map variant-pattern variants))
(define no-fail?
(and (not splicing?) ;; FIXME: commit? needed?
(patterns-cannot-fail? patterns)))
(when no-fail? (log-syntax-parse-debug "(stxclass) cannot fail: ~e" ctx))
(define body
(cond [(null? variants)
#'(fail (failure pr es))]
(cond [(null? patterns)
#'(fail (failure* pr es))]
[splicing?
(with-syntax ([(alternative ...)
(for/list ([variant (in-list variants)])
(define pattern (variant-pattern variant))
(for/list ([pattern (in-list patterns)])
(with-syntax ([pattern pattern]
[relsattrs relsattrs]
[iattrs (pattern-attrs pattern)]
@ -140,8 +144,7 @@
[else
(with-syntax ([matrix
(optimize-matrix
(for/list ([variant (in-list variants)])
(define pattern (variant-pattern variant))
(for/list ([pattern (in-list patterns)])
(with-syntax ([iattrs (pattern-attrs pattern)]
[relsattrs relsattrs]
[commit? commit?])
@ -165,7 +168,8 @@
(syntax-parameterize ((this-context-syntax
(syntax-rules ()
[(tbs) (ps-context-syntax pr)])))
(let ([es (es-add-thing pr description 'transparent? rl es)]
(let ([es (es-add-thing pr description 'transparent? rl
#,(if no-fail? #'#f #'es))]
[pr (if 'transparent? pr (ps-add-opaque pr))])
(with ([fail-handler fh0]
[cut-prompt cp0])
@ -274,6 +278,7 @@ Some optimizations:
- commit protocol for stxclasses (but not ~commit, no point)
- avoid continue-vs-end choice point in (EH ... . ()) by eager pair check
- integrable stxclasses, specialize ellipses of integrable stxclasses
- pattern lists that cannot fail set es=#f to disable ExpectStack allocation
|#
;; ----
@ -425,10 +430,12 @@ Conventions:
(define-values (patterns body-exprs defs2s)
(for/lists (patterns body-exprs defs2s) ([clause (in-list (stx->list clauses-stx))])
(for-clause clause)))
(define no-fail? (patterns-cannot-fail? patterns))
(when no-fail? (log-syntax-parse-debug "cannot fail: ~e" #'ctx))
(with-syntax ([(def ...) (apply append (get-txlifts-as-definitions) defs defs2s)])
#`(let* ([ctx0 (normalize-context '#,who #,context x)]
[pr (ps-empty x (cadr ctx0))]
[es #f]
[es #,(if no-fail? #'#f #'#t)]
[cx x]
[fh0 (syntax-patterns-fail ctx0)])
def ...
@ -450,7 +457,7 @@ Conventions:
#`(try alternative ...))
|#]
[else
#`(fail (failure pr es))]))))))))]))
#`(fail (failure* pr es))]))))))))]))
;; ----
@ -488,7 +495,7 @@ Conventions:
[tpr (ps-add-cdr pr)])
(parse:matrix ((hx hcx hpr es) (tx tcx tpr es) . ins) inner))
(let ([es* (if (null? datum) (es-add-proper-pair (first-desc:matrix inner) es) es)])
(fail (failure pr es*)))))]
(fail (failure* pr es*)))))]
[(parse:pk (in1 . ins) #s(pk/and inner))
#'(parse:matrix (in1 in1 . ins) inner)]))
@ -569,12 +576,12 @@ Conventions:
#`(let ([d unwrap-x])
(if (equal? d (quote datum))
k
(fail (failure pr (es-add-atom 'datum es))))))]
(fail (failure* pr (es-add-atom 'datum es))))))]
[#s(pat:literal literal input-phase lit-phase)
#`(if (and (identifier? x)
(free-identifier=? x (quote-syntax literal) input-phase lit-phase))
k
(fail (failure pr (es-add-literal (quote-syntax literal) es))))]
(fail (failure* pr (es-add-literal (quote-syntax literal) es))))]
[#s(pat:action action subpattern)
#'(parse:A x cx action pr es (parse:S x cx subpattern pr es k))]
[#s(pat:head head tail)
@ -607,7 +614,7 @@ Conventions:
(with ([fail-handler fail-to-succeed]
[cut-prompt fail-to-succeed]) ;; to be safe
(parse:S x cx subpattern pr es
(fh0 (failure pr0 es0)))))]
(fh0 (failure* pr0 es0)))))]
[#s(pat:pair head tail)
#`(let ([datum (if (syntax? x) (syntax-e x) x)]
[cx (if (syntax? x) x cx)]) ;; FIXME: shadowing cx?!
@ -620,7 +627,7 @@ Conventions:
(parse:S hx hcx head hpr es
(parse:S tx cx tail tpr es k)))
(let ([es* (if (null? datum) (es-add-proper-pair (first-desc:S head) es) es)])
(fail (failure pr es*)))))]
(fail (failure* pr es*)))))]
[#s(pat:vector subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)])
(if (vector? datum)
@ -628,7 +635,7 @@ Conventions:
[vcx (if (syntax? x) x cx)] ;; FIXME: (vector? datum) => (syntax? x) ???
[pr* (ps-add-unvector pr)])
(parse:S datum vcx subpattern pr* es k))
(fail (failure pr es))))]
(fail (failure* pr es))))]
[#s(pat:box subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)])
(if (box? datum)
@ -636,7 +643,7 @@ Conventions:
[bcx (if (syntax? x) x cx)] ;; FIXME: (box? datum) => (syntax? x) ???
[pr* (ps-add-unbox pr)])
(parse:S datum bcx subpattern pr* es k))
(fail (failure pr es))))]
(fail (failure* pr es))))]
[#s(pat:pstruct key subpattern)
#`(let ([datum (if (syntax? x) (syntax-e x) x)])
(if (let ([xkey (prefab-struct-key datum)])
@ -645,7 +652,7 @@ Conventions:
[scx (if (syntax? x) x cx)] ;; FIXME: (struct? datum) => (syntax? x) ???
[pr* (ps-add-unpstruct pr)])
(parse:S datum scx subpattern pr* es k))
(fail (failure pr es))))]
(fail (failure* pr es))))]
[#s(pat:describe pattern description transparent? role)
#`(let ([es* (es-add-thing pr description transparent? role es)]
[pr* (if 'transparent? pr (ps-add-opaque pr))])
@ -677,7 +684,7 @@ Conventions:
(if (predicate x*)
(let-attributes (name-attr ...) k)
(let ([es* (es-add-thing pr 'description #t role es)])
(fail (failure pr es*))))))])]))
(fail (failure* pr es*))))))])]))
;; (first-desc:S S-pattern) : expr[FirstDesc]
(define-syntax (first-desc:S stx)
@ -758,7 +765,7 @@ Conventions:
(if c
(let ([pr* (if (syntax? c) (ps-add-stx pr c) pr)]
[es* (es-add-message message es)])
(fail (failure pr* es*)))
(fail (failure* pr* es*)))
k))]
[#s(action:parse pattern expr)
#`(let* ([y (datum->syntax/with-clause (wrap-user-code expr))]
@ -917,7 +924,7 @@ Conventions:
(with ([fail-handler fail-to-succeed]
[cut-prompt fail-to-succeed]) ;; to be safe
(parse:H x cx rest-x rest-cx rest-pr subpattern pr es
(fh0 (failure pr0 es0)))))]
(fh0 (failure* pr0 es0)))))]
[_
#'(parse:S x cx
;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq)
@ -995,7 +1002,7 @@ Conventions:
...)
(cond [(< rel-rep (rep:min-number rel-repc))
(let ([es (expectation-of-reps/too-few es rel-rep rel-repc rel-head)])
(fail (failure loop-pr es)))]
(fail (failure* loop-pr es)))]
...
[else
(let-attributes ([a (rep:finalize a attr-repc alt-id)] ...)
@ -1010,7 +1017,7 @@ Conventions:
[(topc #t x cx pr es pair-alt null-alt)
(cond [(stx-pair? x) pair-alt]
[(stx-null? x) null-alt]
[else (fail (failure pr es))])]
[else (fail (failure* pr es))])]
[(topc _ x cx pr es alt1 alt2)
(try alt1 alt2)]))
@ -1041,7 +1048,7 @@ Conventions:
(if (< rep (rep:max-number repc))
(let ([rep (add1 rep)]) k*)
(let ([es* (expectation-of-reps/too-many es rep repc)])
(fail (failure pr* es*)))))]))]))
(fail (failure* pr* es*)))))]))]))
;; (rep:initial-value RepConstraint) : expr
(define-syntax (rep:initial-value stx)

9
racket/collects/syntax/parse/private/rep-patterns.rkt
View File

@ -511,6 +511,15 @@ A RepConstraint is one of
;; ----
;; patterns-cannot-fail? : (Listof SinglePattern) -> Boolean
;; Returns true if the disjunction of the patterns always succeeds---and thus no
;; failure-tracking needed. Note: beware cut!
(define (patterns-cannot-fail? patterns)
(and (not (ormap pattern-has-cut? patterns))
(ormap pattern-cannot-fail? patterns)))
;; ----
;; An AbsNullable is 'yes | 'no | 'unknown (3-valued logic)
(define (3and a b)

18
racket/collects/syntax/parse/private/runtime-progress.rkt
View File

@ -20,6 +20,8 @@
ps-difference
(struct-out failure)
failure*
expect?
(struct-out expect:thing)
(struct-out expect:atom)
@ -49,6 +51,8 @@ A FailFunction = (FailureSet -> Answer)
|#
(define-struct failure (progress expectstack) #:prefab)
;; failure* : PS ExpectStack/#f -> Failure/#t
(define (failure* ps es) (if es (failure ps es) #t))
;; == Progress ==
@ -177,11 +181,15 @@ An ExpectStack (during parsing) is one of
* (expect:atom Datum ExpectStack)
* (expect:literal Identifier ExpectStack)
* (expect:proper-pair FirstDesc ExpectStack)
* #t
The *-marked variants can only occur at the top of the stack (ie, not
in the next field of another Expect). The top of the stack contains
the most specific information.
An ExpectStack can also be #f, which means no failure tracking is
requested (and thus no more ExpectStacks should be allocated).
-- During reporting, the goal is ease of manipulation.
An ExpectList (during reporting) is (listof Expect).
@ -221,23 +229,23 @@ RExpectList when the most specific information comes last.
(expect:proper-pair? x)))
(define (es-add-thing ps description transparent? role next)
(if description
(if (and next description)
(expect:thing ps description transparent? role next)
next))
(define (es-add-message message next)
(if message
(if (and next message)
(expect:message message next)
next))
(define (es-add-atom atom next)
(expect:atom atom next))
(and next (expect:atom atom next)))
(define (es-add-literal literal next)
(expect:literal literal next))
(and next (expect:literal literal next)))
(define (es-add-proper-pair first-desc next)
(expect:proper-pair first-desc next))
(and next (expect:proper-pair first-desc next)))
#|
A FirstDesc is one of

1
racket/collects/syntax/parse/private/runtime-report.rkt
View File

@ -292,6 +292,7 @@ ie (ps->stx+index ps1) = (ps->stx+index ps2).
(let loop ([es es] [acc null])
(match es
['#f acc]
['#t acc]
[(expect:thing ps desc tr? role rest-es)
(cond [(and truncate-opaque? (not tr?))
(loop rest-es (cons (expect:thing #f desc #t role (ps->stx+index ps)) null))]