syntax/parse: optimize common ellipsis patterns

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"))

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
+(define-integrable-syntax-class identifier (quote "identifier") identifier?)
-  #:description (quote "identifier")
+(define-integrable-syntax-class expr (quote "expression") expr-stx?)
-  (pattern (~fail #:unless (identifier? this-syntax))))
+(define-integrable-syntax-class keyword (quote "keyword") keyword-stx?)
-
-(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)))))
 
 ;; == Normal syntax classes ==
 

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)

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)]
+          (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)])
             (with-syntax ([name name]
                           [formals formals]
                           [parser (generate-temporary (format-symbol "parse-~a" name))]
                           [arity arity]
                           [attrs (rhs-attrs the-rhs)]
-                          [(opt-def ...)
+                          [options (rhs-options the-rhs)])
-                           (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])])
               #`(begin (define-syntax name
                          (stxclass 'name 'arity
                                    'attrs
                                    (quote-syntax parser)
                                    '#,splicing?
                                    options
-                                   integrate-expr))
+                                   #f))
-                       opt-def ...
                        (define-values (parser)
-                         ;; If opt-rhs, do not reparse:
+                         (parser/rhs name formals attrs rhss #,splicing? #,stx)))))))])))
-                         ;; 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))))))))])))
 
 (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 ...)))

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)

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)))])))))

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)