syntax/parse: reduce allocation when parsing cannot fail

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.

racket/collects/syntax/parse/private/parse.rkt

@@ -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)
+     (cond [(null? patterns)
-            #'(fail (failure pr es))]
+            #'(fail (failure* pr es))]
            [splicing?
             (with-syntax ([(alternative ...)
-                           (for/list ([variant (in-list variants)])
+                           (for/list ([pattern (in-list patterns)])
-                             (define pattern (variant-pattern variant))
                              (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)])
+                            (for/list ([pattern (in-list patterns)])
-                              (define pattern (variant-pattern variant))
                               (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)

racket/collects/syntax/parse/private/rep-patterns.rkt

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

racket/collects/syntax/parse/private/runtime-progress.rkt

@@ -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

racket/collects/syntax/parse/private/runtime-report.rkt

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