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,6 +1397,13 @@ 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)
+  (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
@@ -1412,7 +1419,7 @@ See match-a-pattern.rkt for more details
                    (loop (cdr exp) patterns)))]
          [else
           (and ((car patterns) (car exp))
-            (loop (cdr exp) (cdr patterns)))])))
+               (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))
+                  
+    
+
+
 ;                                                                                             
 ;                                                                                             
 ;                                 ;;;                                ;