From 3e6069a70feba53d5a0bf6d93fd21b9336efb11b Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 27 Feb 2012 06:34:33 -0700 Subject: [PATCH] syntax/parse: optimize common ellipsis patterns --- collects/syntax/parse/pre.rkt | 4 +- collects/syntax/parse/private/lib.rkt | 15 ++--- collects/syntax/parse/private/parse-aux.rkt | 2 + collects/syntax/parse/private/parse.rkt | 75 +++++++++++++-------- collects/syntax/parse/private/rep.rkt | 60 ----------------- collects/syntax/parse/private/residual.rkt | 34 ++++++++++ collects/syntax/parse/private/sc.rkt | 4 ++ 7 files changed, 93 insertions(+), 101 deletions(-) diff --git a/collects/syntax/parse/pre.rkt b/collects/syntax/parse/pre.rkt index fb47c90cf0..b9f801ed60 100644 --- a/collects/syntax/parse/pre.rkt +++ b/collects/syntax/parse/pre.rkt @@ -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")) diff --git a/collects/syntax/parse/private/lib.rkt b/collects/syntax/parse/private/lib.rkt index b8ad8652db..c2b776c894 100644 --- a/collects/syntax/parse/private/lib.rkt +++ b/collects/syntax/parse/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 == diff --git a/collects/syntax/parse/private/parse-aux.rkt b/collects/syntax/parse/private/parse-aux.rkt index ab53814afc..2c0b2d5080 100644 --- a/collects/syntax/parse/private/parse-aux.rkt +++ b/collects/syntax/parse/private/parse-aux.rkt @@ -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) diff --git a/collects/syntax/parse/private/parse.rkt b/collects/syntax/parse/private/parse.rkt index b8448add48..85e5e5f494 100644 --- a/collects/syntax/parse/private/parse.rkt +++ b/collects/syntax/parse/private/parse.rkt @@ -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 ...))) diff --git a/collects/syntax/parse/private/rep.rkt b/collects/syntax/parse/private/rep.rkt index dcefc508fc..f8e37d9000 100644 --- a/collects/syntax/parse/private/rep.rkt +++ b/collects/syntax/parse/private/rep.rkt @@ -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) diff --git a/collects/syntax/parse/private/residual.rkt b/collects/syntax/parse/private/residual.rkt index d89144197a..60b7272060 100644 --- a/collects/syntax/parse/private/residual.rkt +++ b/collects/syntax/parse/private/residual.rkt @@ -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)))]))))) diff --git a/collects/syntax/parse/private/sc.rkt b/collects/syntax/parse/private/sc.rkt index b52ad86398..5cc902dac7 100644 --- a/collects/syntax/parse/private/sc.rkt +++ b/collects/syntax/parse/private/sc.rkt @@ -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)