fix performance bug in Redex

The bug was in the way matching worked for lists. Specifically, if
you define a grammar like this one:

  e ::= (- e)
        (- e e)
        integer

and you have a term like this:

  (- (- (- (- (- (- (- 11)))))))

then at each step of matching against 'e', Redex would try both
alternatives, meaning it is attempting 2^n matches (where n is
the number of nested minus signs).

The fix eagerly checks the lengths of the lists and so brings this
back to a linear time matching problem.

(This came up in the delimited continuation model from the paper
 _Constraining Delimited Control with Contracts_, ESOP 2013, altho
 Redex's caching can mask the bad behavior, making this linear
 again in normal uses of that model.)

pkgs/redex-pkgs/redex-lib/redex/private/matcher.rkt

@@ -1397,22 +1397,29 @@ See match-a-pattern.rkt for more details
 
 ;; match-list/boolean : (listof (union repeat (any hole-info -> boolean))) sexp hole-info -> boolean
 (define (match-list/boolean patterns exp)
-  (let loop ([exp exp]
-             [patterns patterns])
-    (cond
-      [(null? exp)
-       (let loop ([patterns patterns])
-         (or (null? patterns)
-             (and (repeat? (car patterns))
-                  (loop (cdr patterns)))))]
-      [(null? patterns) #f]
-      [(repeat? (car patterns)) 
-       (or (loop exp (cdr patterns))
-           (and ((repeat-pat (car patterns)) (car exp))
-                (loop (cdr exp) patterns)))]
-      [else
-       (and ((car patterns) (car exp))
-            (loop (cdr exp) (cdr patterns)))])))
+  (define has-repeats? (ormap repeat? patterns))
+  (cond
+    [(not (list? exp)) #f]
+    [(and (not has-repeats?)
+          (not (= (length patterns) (length exp))))
+     #f]
+    [else
+     (let loop ([exp exp]
+                [patterns patterns])
+       (cond
+         [(null? exp)
+          (let loop ([patterns patterns])
+            (or (null? patterns)
+                (and (repeat? (car patterns))
+                     (loop (cdr patterns)))))]
+         [(null? patterns) #f]
+         [(repeat? (car patterns)) 
+          (or (loop exp (cdr patterns))
+              (and ((repeat-pat (car patterns)) (car exp))
+                   (loop (cdr exp) patterns)))]
+         [else
+          (and ((car patterns) (car exp))
+               (loop (cdr exp) (cdr patterns)))]))]))
 
 ;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings))
 (define (match-list patterns exp hole-info)

pkgs/redex-pkgs/redex-test/redex/tests/tl-test.rkt

@@ -539,6 +539,40 @@
                      (term (number_1 6) #:lang L))
           '(5 6)))
     
+(let ()
+  ;; test to make sure that reasonable short-circuiting is happening
+  ;; when matching lists of differing length to avoid exponential behavior
+  
+  ;; this test is fragile because it is based on cpu times.
+  ;; on my machine, with the bug in place it takes 2000+ msec
+  ;; to run and with the fix it takes 200 or so msec.
+  
+  (define-language abort-core-lang
+    (e integer
+       (- e)
+       (- e e)))
+  
+  (define (add-minuses t count)
+    (let loop ([i count])
+      (cond
+        [(zero? i) t]
+        [else `(- ,(loop (- i 1)))])))
+  
+  
+  (define-values (answer cpu real gc) 
+    (time-apply
+     (λ ()
+       (parameterize ([caching-enabled? #f])
+         (for ([count (in-range 20)])
+           (redex-match abort-core-lang
+                        e
+                        (add-minuses 11 count)))))
+     '()))
+  (test (< cpu 1000) #t))
+                  
+    
+
+
 ;                                                                                             
 ;                                                                                             
 ;                                 ;;;                                ;