Optimize match patterns of the form (list x ...).

This also applies to `(mlist x ...)`, even though
that involves two traversals when only one is
required by the old method. Timing suggests that
the new code is nonetheless faster.

racket/collects/racket/match/gen-match.rkt

@@ -42,7 +42,8 @@
      (define/with-syntax (exprs ...) es)
      (define/with-syntax outer-fail (generate-temporary #'fail))
      (define/with-syntax orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...)))
-     (define/with-syntax raise-error (quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name)))
+     (define/with-syntax raise-error
+       (quasisyntax/loc stx (match:error orig-expr (list (srcloc #,@srcloc-list)) 'form-name)))
      (define parsed-clauses
        (for/list ([clause (syntax->list clauses)]
                   [pats (syntax->list #'(pats ...))]

racket/collects/racket/match/parse-helper.rkt

@@ -8,7 +8,9 @@
 
 (provide ddk? parse-literal all-vars pattern-var? match:syntax-err
          match-expander-transform trans-match parse-struct
-         dd-parse parse-quote parse-id)
+         dd-parse parse-quote parse-id in-splicing?)
+
+(define in-splicing? (make-parameter #f))
 
 ;; parse x as a match variable
 ;; x : identifier
@@ -46,19 +48,27 @@
 ;; p : the repeated pattern
 ;; dd : the ... stx
 ;; rest : the syntax for the rest
-(define (dd-parse parse p dd rest #:mutable [mutable? #f])
+;; pred? : recognizer for the parsed data structure (such as list?)
-  (let* ([count (ddk? dd)]
+;; to-list: function to convert the value to a list
-         [min (and (number? count) count)])
+(define (dd-parse parse p dd rest pred? #:to-list [to-list #'values] #:mutable [mutable? #f])
-    (make-GSeq
+  (define count (ddk? dd))
-     (parameterize ([match-...-nesting (add1 (match-...-nesting))])
+  (define min (and (number? count) count))
-       (list (list (parse p))))
+  (define pat (parameterize ([match-...-nesting (add1 (match-...-nesting))])
+                (parse p)))
+  (define rest-pat (parse rest))
+  (cond [(and (not (in-splicing?)) ;; when we're inside splicing, rest-pat isn't the rest
+              (not min) ;; if we have a count, better generate general code
+              (Null? rest-pat)
+              (or (Var? pat) (Dummy? pat)))
+         (make-And (list (make-Pred pred?) (make-App to-list (list pat))))]
+        [else (make-GSeq (list (list pat))
                          (list min)
                          ;; no upper bound
                          (list #f)
                          ;; patterns in p get bound to lists
                          (list #f)
-     (parse rest)
+                         rest-pat
-     mutable?)))
+                         mutable?)]))
 
 ;; stx : the syntax object for the whole pattern
 ;; parse : the pattern parser

racket/collects/racket/match/parse-legacy.rkt

@@ -64,7 +64,7 @@
      (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
     [(p .. . rest)
      (ddk? #'..)
-     (dd-parse parse #'p #'.. #'rest)]
+     (dd-parse parse #'p #'.. #'rest #'list?)]
     [(e . es)
      (make-Pair (parse #'e) (parse (syntax/loc stx es)))]
     [x

racket/collects/racket/match/parse-quasi.rkt

@@ -32,7 +32,7 @@
   (syntax-case stx (quasiquote unquote quote unquote-splicing)
     [(unquote p) (parse #'p)]
     [((unquote-splicing p) . rest)
-     (let ([pat (parse #'p)]
+     (let ([pat (parameterize ([in-splicing? #t]) (parse #'p))]
            [rpat (pq #'rest)])
        (if (null-terminated? pat)
            (append-pats pat rpat)
@@ -40,6 +40,7 @@
                                stx #'p)))]
     [(p dd . rest)
      (ddk? #'dd)
+     ;; FIXME: parameterize dd-parse so that it can be used here
      (let* ([count (ddk? #'dd)]
             [min (and (number? count) count)])
        (make-GSeq

racket/collects/racket/match/parse.rkt

@@ -4,7 +4,7 @@
          "patterns.rkt"
          "parse-helper.rkt"
          "parse-quasi.rkt"
-         (for-template (only-in "runtime.rkt" matchable?)
+         (for-template (only-in "runtime.rkt" matchable? mlist? mlist->list)
                        racket/base))
 
 (provide parse)
@@ -136,10 +136,10 @@
      (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
     [(list p .. . rest)
      (ddk? #'..)
-     (dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)))]
+     (dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'list?)]
     [(mlist p .. . rest)
      (ddk? #'..)
-     (dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #:mutable #t)]
+     (dd-parse rearm+parse #'p #'.. (syntax/loc stx (list . rest)) #'mlist? #:to-list #'mlist->list #:mutable #t)]
     [(list e es ...)
      (Pair (rearm+parse #'e) (rearm+parse (syntax/loc stx (list es ...))))]
     [(mlist e es ...)
@@ -150,7 +150,7 @@
      (rearm+parse #'e)]
     [(list-rest p dd . rest)
      (ddk? #'dd)
-     (dd-parse rearm+parse #'p #'dd (syntax/loc stx (list-rest . rest)))]
+     (dd-parse rearm+parse #'p #'dd (syntax/loc stx (list-rest . rest)) #'list?)]
     [(list-rest e . es)
      (Pair (rearm+parse #'e) (rearm+parse (syntax/loc #'es (list-rest . es))))]
     [(cons e1 e2) (Pair (rearm+parse #'e1) (rearm+parse #'e2))]

racket/collects/racket/match/patterns.rkt

@@ -50,7 +50,7 @@
 (define-struct (Null Atom) () #:transparent)
 
 ;; expr is an expression
-;; p is a pattern
+;; ps is a list of patterns
 (define-struct (App Pat) (expr ps) #:transparent)
 
 ;; pred is an expression

racket/collects/racket/match/runtime.rkt

@@ -8,7 +8,8 @@
          match:error
          fail
          matchable?
-         match-prompt-tag)
+         match-prompt-tag
+         mlist? mlist->list)
 
 (define match-prompt-tag (make-continuation-prompt-tag 'match)) 
 
@@ -32,3 +33,28 @@
 ;; can we pass this value to regexp-match?
 (define (matchable? e)
   (or (string? e) (bytes? e)))
+
+;; duplicated because we can't depend on `compatibility` here
+(define (mlist? l)
+  (cond
+   [(null? l) #t]
+   [(mpair? l)
+    (let loop ([turtle l][hare (mcdr l)])
+      (cond
+       [(null? hare) #t]
+       [(eq? hare turtle) #f]
+       [(mpair? hare)
+        (let ([hare (mcdr hare)])
+          (cond
+           [(null? hare) #t]
+           [(eq? hare turtle) #f]
+           [(mpair? hare)
+            (loop (mcdr turtle) (mcdr hare))]
+           [else #f]))]
+       [else #f]))]
+   [else #f]))
+
+(define (mlist->list l)
+  (cond
+   [(null? l) null]
+   [else (cons (mcar l) (mlist->list (mcdr l)))]))