syntax/parse: optimize common ellipsis patterns
This commit is contained in:
Ryan Culpepper
parent
2a3d6d5c31
commit
3e6069a70f
|
|
@ -3,6 +3,8 @@
|
|||
"private/litconv.rkt"
|
||||
"private/lib.rkt")
|
||||
(provide (except-out (all-from-out "private/sc.rkt")
|
||||
syntax-parser/template parser/rhs)
|
||||
define-integrable-syntax-class
|
||||
syntax-parser/template
|
||||
parser/rhs)
|
||||
(all-from-out "private/litconv.rkt")
|
||||
(all-from-out "private/lib.rkt"))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
(require "sc.rkt"
|
||||
"keywords.rkt"
|
||||
syntax/parse/private/residual ;; keep abs.
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide identifier
|
||||
|
|
@ -23,17 +24,9 @@
|
|||
|
||||
;; == Integrable syntax classes ==
|
||||
|
||||
(define-syntax-class identifier
|
||||
#:description (quote "identifier")
|
||||
(pattern (~fail #:unless (identifier? this-syntax))))
|
||||
|
||||
(define-syntax-class keyword
|
||||
#:description (quote "keyword")
|
||||
(pattern (~fail #:unless (keyword? (syntax-e this-syntax)))))
|
||||
|
||||
(define-syntax-class expr
|
||||
#:description (quote "expression")
|
||||
(pattern (~fail #:when (keyword? (syntax-e this-syntax)))))
|
||||
(define-integrable-syntax-class identifier (quote "identifier") identifier?)
|
||||
(define-integrable-syntax-class expr (quote "expression") expr-stx?)
|
||||
(define-integrable-syntax-class keyword (quote "keyword") keyword-stx?)
|
||||
|
||||
;; == Normal syntax classes ==
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require (for-template "parse.rkt"))
|
||||
(provide id:define-syntax-class
|
||||
id:define-splicing-syntax-class
|
||||
id:define-integrable-syntax-class
|
||||
id:syntax-parse
|
||||
id:syntax-parser
|
||||
id:define/syntax-parse
|
||||
|
|
@ -11,6 +12,7 @@
|
|||
|
||||
(define (id:define-syntax-class) #'define-syntax-class)
|
||||
(define (id:define-splicing-syntax-class) #'define-splicing-syntax-class)
|
||||
(define (id:define-integrable-syntax-class) #'define-integrable-syntax-class)
|
||||
(define (id:syntax-parse) #'syntax-parse)
|
||||
(define (id:syntax-parser) #'syntax-parser)
|
||||
(define (id:define/syntax-parse) #'define/syntax-parse)
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@
|
|||
|
||||
(provide define-syntax-class
|
||||
define-splicing-syntax-class
|
||||
define-integrable-syntax-class
|
||||
syntax-parse
|
||||
syntax-parser
|
||||
define/syntax-parse
|
||||
|
|
@ -39,53 +40,45 @@
|
|||
(let-values ([(name formals arity)
|
||||
(let ([p (check-stxclass-header #'header stx)])
|
||||
(values (car p) (cadr p) (caddr p)))])
|
||||
(let* ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)]
|
||||
[opt-rhs+def
|
||||
(and (andmap identifier? (syntax->list formals))
|
||||
(optimize-rhs the-rhs (syntax->list formals)))]
|
||||
[the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)])
|
||||
(let ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)])
|
||||
(with-syntax ([name name]
|
||||
[formals formals]
|
||||
[parser (generate-temporary (format-symbol "parse-~a" name))]
|
||||
[arity arity]
|
||||
[attrs (rhs-attrs the-rhs)]
|
||||
[(opt-def ...)
|
||||
(if opt-rhs+def
|
||||
(list (cadr opt-rhs+def))
|
||||
'())]
|
||||
[options (rhs-options the-rhs)]
|
||||
[integrate-expr
|
||||
(syntax-case (rhs-integrate the-rhs) ()
|
||||
[#s(integrate predicate description)
|
||||
#'(integrate (quote-syntax predicate)
|
||||
'description)]
|
||||
[#f
|
||||
#''#f])])
|
||||
[options (rhs-options the-rhs)])
|
||||
#`(begin (define-syntax name
|
||||
(stxclass 'name 'arity
|
||||
'attrs
|
||||
(quote-syntax parser)
|
||||
'#,splicing?
|
||||
options
|
||||
integrate-expr))
|
||||
opt-def ...
|
||||
#f))
|
||||
(define-values (parser)
|
||||
;; If opt-rhs, do not reparse:
|
||||
;; need to keep same generated predicate name
|
||||
#,(if opt-rhs+def
|
||||
(begin
|
||||
#`(parser/rhs/parsed
|
||||
name formals attrs #,the-rhs
|
||||
#,(and (rhs-description the-rhs) #t)
|
||||
#,splicing? #,stx))
|
||||
#`(parser/rhs
|
||||
name formals attrs rhss #,splicing? #,stx))))))))])))
|
||||
(parser/rhs name formals attrs rhss #,splicing? #,stx)))))))])))
|
||||
|
||||
(define-syntax define-syntax-class
|
||||
(lambda (stx) (tx:define-*-syntax-class stx #f)))
|
||||
(define-syntax define-splicing-syntax-class
|
||||
(lambda (stx) (tx:define-*-syntax-class stx #t)))
|
||||
|
||||
(define-syntax (define-integrable-syntax-class stx)
|
||||
(syntax-case stx (quote)
|
||||
[(_ name (quote description) predicate)
|
||||
(with-syntax ([parser (generate-temporary (format-symbol "parse-~a" (syntax-e #'name)))]
|
||||
[no-arity no-arity])
|
||||
#'(begin (define-syntax name
|
||||
(stxclass 'name no-arity '()
|
||||
(quote-syntax parser)
|
||||
#f
|
||||
'#s(options #t #t)
|
||||
(integrate (quote-syntax predicate) 'description)))
|
||||
(define (parser x cx pr es fh0 cp0 success)
|
||||
(if (predicate x)
|
||||
(success fh0 cp0)
|
||||
(let ([es (cons (expect:thing 'description #t) es)])
|
||||
(fh0 (failure pr es)))))))]))
|
||||
|
||||
(define-syntax (parser/rhs stx)
|
||||
(syntax-case stx ()
|
||||
[(parser/rhs name formals attrs rhss splicing? ctx)
|
||||
|
|
@ -813,6 +806,30 @@ Conventions:
|
|||
;; In k: attrs(EH-pattern, S-pattern) are bound.
|
||||
(define-syntax (parse:dots stx)
|
||||
(syntax-case stx ()
|
||||
;; == Specialized cases
|
||||
;; -- (x ... . ())
|
||||
[(parse:dots x cx (#s(ehpat (attr0)
|
||||
#s(pat:var _attrs name #f _ () _ _)
|
||||
#f))
|
||||
#s(pat:datum () ()) pr es k)
|
||||
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f)])
|
||||
(case status
|
||||
((ok) (let-attributes ([attr0 result]) k))
|
||||
(else (fail result))))]
|
||||
;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr
|
||||
[(parse:dots x cx (#s(ehpat (attr0)
|
||||
#s(pat:integrated _attrs _name _argu pred? desc)
|
||||
#f))
|
||||
#s(pat:datum () ()) pr es k)
|
||||
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc)])
|
||||
(case status
|
||||
((ok) (let-attributes ([attr0 result]) k))
|
||||
(else (fail result))))]
|
||||
;; -- (x:sc ... . ()) where sc is a stxclass with commit
|
||||
;; Since head pattern does commit, no need to thread fail-handler, cut-prompt through.
|
||||
;; Microbenchmark suggests this isn't a useful specialization
|
||||
;; (probably try-or-pair/null-check already does the useful part)
|
||||
;; == General case
|
||||
[(parse:dots x cx (#s(ehpat head-attrs head head-repc) ...) tail pr es k)
|
||||
(let ()
|
||||
(define repcs (wash-list wash #'(head-repc ...)))
|
||||
|
|
|
|||
|
|
@ -27,9 +27,6 @@
|
|||
(-> syntax? (or/c false/c (listof sattr?)) boolean?
|
||||
#:context (or/c false/c syntax?)
|
||||
rhs?)]
|
||||
[optimize-rhs
|
||||
(-> rhs? any/c
|
||||
(or/c #f (list/c rhs? syntax?)))]
|
||||
[parse-pattern+sides
|
||||
(-> syntax? syntax?
|
||||
#:splicing? boolean?
|
||||
|
|
@ -199,63 +196,6 @@
|
|||
|
||||
;; ----
|
||||
|
||||
#|
|
||||
A syntax class is integrable if
|
||||
- only positional params without defaults
|
||||
- no attributes
|
||||
- description is a string constant
|
||||
- one variant: (~fail #:when/unless cond) ... no message
|
||||
- and thus no txlifted definitions, no convention definitions, etc
|
||||
- don't care about commit?, delimit-cut?, transparent?
|
||||
because other restrictions make them irrelevant
|
||||
|#
|
||||
|
||||
;; optimize-rhs : RHS stxlist -> (list RHS stx)/#f
|
||||
;; Returns #f to indicate cannot integrate.
|
||||
(define (optimize-rhs rhs0 params)
|
||||
(define (check-stx-string x)
|
||||
(syntax-case x (quote)
|
||||
[(quote str) (string? (syntax-e #'str)) #'str]
|
||||
[_ #f]))
|
||||
(define (stx-false? x)
|
||||
(syntax-case x (quote)
|
||||
[(quote #f) #t]
|
||||
[_ #f]))
|
||||
(match rhs0
|
||||
[(rhs _o '() _trans? (? check-stx-string description) (list variant0) '() _opts '#f)
|
||||
(match variant0
|
||||
[(variant _o '() pattern0 '())
|
||||
(match pattern0
|
||||
[(pat:action '() (action:fail '() cond-stx msg-stx) (pat:any '()))
|
||||
(cond [(stx-false? msg-stx)
|
||||
;; Yes!
|
||||
(with-syntax ([(predicate) (generate-temporaries #'(predicate))]
|
||||
[(param ...) params]
|
||||
[fail-condition cond-stx])
|
||||
(let* ([predicate-def
|
||||
#'(define (predicate x param ...)
|
||||
(syntax-parameterize ((this-syntax
|
||||
(make-rename-transformer
|
||||
(quote-syntax x))))
|
||||
(#%expression (not fail-condition))))]
|
||||
[integrate* (make integrate #'predicate
|
||||
(check-stx-string description))]
|
||||
[pattern*
|
||||
(create-pat:action
|
||||
(create-action:fail #'(not (predicate this-syntax param ...)) #'#f)
|
||||
(create-pat:any))]
|
||||
[variant*
|
||||
(variant _o '() pattern* '())])
|
||||
(list
|
||||
(make rhs _o '() _trans? description (list variant*) '() _opts integrate*)
|
||||
predicate-def)))]
|
||||
[else #f])]
|
||||
[_ #f])]
|
||||
[_ #f])]
|
||||
[_ #f]))
|
||||
|
||||
;; ----
|
||||
|
||||
(define (parse-variants rest decls splicing? expected-attrs)
|
||||
(define (gather-variants stx)
|
||||
(syntax-case stx (pattern)
|
||||
|
|
|
|||
|
|
@ -192,3 +192,37 @@
|
|||
(lazy-require
|
||||
["runtime-report.rkt"
|
||||
(syntax-patterns-fail)])
|
||||
|
||||
;; == predicates and parsers
|
||||
|
||||
(provide keyword-stx?
|
||||
expr-stx?
|
||||
predicate-ellipsis-parser)
|
||||
|
||||
(define (keyword-stx? x)
|
||||
(and (syntax? x) (keyword? (syntax-e x))))
|
||||
|
||||
(define (expr-stx? x)
|
||||
(not (keyword-stx? x)))
|
||||
|
||||
;; Specialized ellipsis parser
|
||||
;; returns (values 'ok attr-values) or (values 'fail failure)
|
||||
|
||||
(define (predicate-ellipsis-parser x cx pr es pred? desc)
|
||||
(let ([elems (stx->list x)])
|
||||
(if (and elems (andmap pred? elems))
|
||||
(values 'ok elems)
|
||||
(let loop ([x x] [cx cx] [i 0])
|
||||
(cond [(syntax? x)
|
||||
(loop (syntax-e x) x i)]
|
||||
[(pair? x)
|
||||
(if (pred? (car x))
|
||||
(loop (cdr x) cx (add1 i))
|
||||
(let* ([pr (ps-add-cdr pr i)]
|
||||
[pr (ps-add-car pr)]
|
||||
[es (cons (expect:thing desc #t) es)])
|
||||
(values 'fail (failure pr es))))]
|
||||
[else ;; not null, because stx->list failed
|
||||
(let ([pr (ps-add-cdr pr i)]
|
||||
[es (cons (expect:atom '()) es)])
|
||||
(values 'fail (failure pr es)))])))))
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
[syntax/parse/private/parse-aux
|
||||
(id:define-syntax-class
|
||||
id:define-splicing-syntax-class
|
||||
id:define-integrable-syntax-class
|
||||
id:syntax-parse
|
||||
id:syntax-parser
|
||||
id:define/syntax-parse
|
||||
|
|
@ -29,6 +30,7 @@
|
|||
|
||||
(provide define-syntax-class
|
||||
define-splicing-syntax-class
|
||||
define-integrable-syntax-class
|
||||
syntax-parse
|
||||
syntax-parser
|
||||
define/syntax-parse
|
||||
|
|
@ -46,6 +48,7 @@
|
|||
|
||||
(define-syntaxes (define-syntax-class
|
||||
define-splicing-syntax-class
|
||||
define-integrable-syntax-class
|
||||
syntax-parse
|
||||
syntax-parser
|
||||
define/syntax-parse
|
||||
|
|
@ -60,6 +63,7 @@
|
|||
(values
|
||||
(tx id:define-syntax-class)
|
||||
(tx id:define-splicing-syntax-class)
|
||||
(tx id:define-integrable-syntax-class)
|
||||
(tx id:syntax-parse)
|
||||
(tx id:syntax-parser)
|
||||
(tx id:define/syntax-parse)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user