From 4407f75e8e19ea17e3405b5993d50daf4787270c Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 30 Sep 2005 12:19:07 +0000
Subject: [PATCH] improved matchers performance somewhat

svn: r948
---
 .../private/matcher-test.ss                   |  25 ++
 .../reduction-semantics/private/matcher.ss    | 282 ++++++++++++++----
 2 files changed, 253 insertions(+), 54 deletions(-)

diff --git a/collects/reduction-semantics/private/matcher-test.ss b/collects/reduction-semantics/private/matcher-test.ss
index 162ce9fc03..0ef7d30a2a 100644
--- a/collects/reduction-semantics/private/matcher-test.ss
+++ b/collects/reduction-semantics/private/matcher-test.ss
@@ -11,19 +11,28 @@
     (test-empty 'any "a" (list (make-test-mtch (make-bindings null) "a" none)))
     (test-empty 'any '(a b) (list (make-test-mtch (make-bindings null) '(a b) none)))
     (test-empty 1 1 (list (make-test-mtch (make-bindings null) 1 none)))
+    (test-empty 1 '() #f)
     (test-empty 99999999999999999999999999999999999999999999999
                 99999999999999999999999999999999999999999999999
                 (list (make-test-mtch (make-bindings null) 
                                  99999999999999999999999999999999999999999999999
                                  none)))
+    (test-empty 99999999999999999999999999999999999999999999999
+                '()
+                #f)
     (test-empty 'x 'x (list (make-test-mtch (make-bindings null) 'x none)))
+    (test-empty 'x '() #f)
     (test-empty 1 2 #f)
     (test-empty "a" "b" #f)
+    (test-empty "a" '(x) #f)
+    (test-empty "a" '() #f)
     (test-empty "a" "a" (list (make-test-mtch (make-bindings null) "a" none)))
     (test-empty 'number 1 (list (make-test-mtch (make-bindings null) 1 none)))
     (test-empty 'number 'x #f)
+    (test-empty 'number '() #f)
     (test-empty 'string "a" (list (make-test-mtch (make-bindings null) "a" none)))
     (test-empty 'string 1 #f)
+    (test-empty 'string '() #f)
     (test-empty 'variable 'x (list (make-test-mtch (make-bindings null) 'x none)))
     (test-empty 'variable 1 #f)
     (test-empty '(variable-except x) 1 #f)
@@ -200,6 +209,12 @@
     (test-empty '(a ... b) '(b c) #f)
     (test-empty '(a ... b) '(a b c) #f)
     
+    (test-xab 'lsts '() (list (make-test-mtch (make-bindings null) '() none)))
+    (test-xab 'lsts '(x) (list (make-test-mtch (make-bindings null) '(x) none)))
+    (test-xab 'lsts 'x (list (make-test-mtch (make-bindings null) 'x none)))
+    (test-xab 'lsts #f (list (make-test-mtch (make-bindings null) #f none)))
+    (test-xab 'split-out '1 (list (make-test-mtch (make-bindings null) '1 none)))
+
     (test-xab 'exp 1 (list (make-test-mtch (make-bindings null) 1 none)))
     (test-xab 'exp '(+ 1 2) (list (make-test-mtch (make-bindings null) '(+ 1 2) none)))
     (test-xab '(in-hole ctxt any)
@@ -487,6 +502,16 @@
 
                                     (make-nt 'same-in-nt (list (make-rhs '((name x any) (name x any)))))
                                     
+                                    (make-nt 'lsts
+                                             (list (make-rhs '())
+                                                   (make-rhs '(x))
+                                                   (make-rhs 'x)
+                                                   (make-rhs '#f)))
+                                    (make-nt 'split-out
+                                             (list (make-rhs 'split-out2)))
+                                    (make-nt 'split-out2
+                                             (list (make-rhs 'number)))
+                                    
                                     (make-nt 'nesting-names
                                              (list (make-rhs '(a (name x nesting-names)))
                                                    (make-rhs 'b)))))))
diff --git a/collects/reduction-semantics/private/matcher.ss b/collects/reduction-semantics/private/matcher.ss
index ae0c640b51..27214dc30d 100644
--- a/collects/reduction-semantics/private/matcher.ss
+++ b/collects/reduction-semantics/private/matcher.ss
@@ -70,6 +70,7 @@ before the pattern compiler is invoked.
   ;; compiled-lang : (make-compiled-lang (listof nt) 
   ;;                                     hash-table[sym -o> compiled-pattern]
   ;;                                     hash-table[sym -o> compiled-pattern]
+  ;;                                     hash-table[sym -o> compiled-pattern]
   ;;                                     hash-table[sym -o> boolean])
   ;;                                     hash-table[sexp[pattern] -o> (cons compiled-pattern boolean)])
   ;; hole-info = (union #f none symbol)
@@ -78,7 +79,7 @@ before the pattern compiler is invoked.
   ;;               symbol means we're looking for a named hole named by the symbol
   (define compiled-pattern (any/c (union false/c none? symbol?) . -> . (union false/c (listof mtch?))))
   
-  (define-struct compiled-lang (lang ht across-ht has-hole-ht cache))
+  (define-struct compiled-lang (lang ht list-ht across-ht has-hole-ht cache))
   
   ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any
   (define lookup-binding 
@@ -97,29 +98,44 @@ before the pattern compiler is invoked.
   ;; compile-language : lang -> compiled-lang
   (define (compile-language lang)
     (let* ([clang-ht (make-hash-table)]
+           [clang-list-ht (make-hash-table)]
            [across-ht (make-hash-table)]
            [has-hole-ht (build-has-hole-ht lang)]
            [cache (make-hash-table 'equal)]
-           [clang (make-compiled-lang lang clang-ht across-ht has-hole-ht cache)]
+           [clang (make-compiled-lang lang clang-ht clang-list-ht across-ht has-hole-ht cache)]
+           [non-list-nt-table (build-non-list-nt-label lang)]
+           [list-nt-table (build-list-nt-label lang)]
            [do-compilation
-            (lambda (ht lang prefix-cross?)
+            (lambda (ht list-ht lang prefix-cross?)
               (for-each
                (lambda (nt)
                  (for-each
                   (lambda (rhs)
                     (let-values ([(compiled-pattern has-hole?) 
                                   (compile-pattern/cross? clang (rhs-pattern rhs) prefix-cross?)])
-                      (hash-table-put!
-                       ht
-                       (nt-name nt)
-                       (cons compiled-pattern
-                             (hash-table-get ht (nt-name nt))))))
+                      (let ([add-to-ht
+                             (lambda (ht)
+                               (hash-table-put!
+                                ht
+                                (nt-name nt)
+                                (cons compiled-pattern
+                                      (hash-table-get ht (nt-name nt)))))])
+                        (when (may-be-non-list-pattern? (rhs-pattern rhs)
+                                                        non-list-nt-table)
+                          (add-to-ht ht))
+                        (when (may-be-list-pattern? (rhs-pattern rhs) 
+                                                     list-nt-table)
+                          (add-to-ht list-ht)))))
                   (nt-rhs nt)))
-               lang))])
+               lang))]
+           [init-ht
+            (lambda (ht)
+              (for-each (lambda (nt) (hash-table-put! ht (nt-name nt) null))
+                        lang))])
+      
+      (init-ht clang-ht)
+      (init-ht clang-list-ht)
       
-      (for-each (lambda (nt)
-                  (hash-table-put! clang-ht (nt-name nt) null))
-                lang)
       (hash-table-for-each
        clang-ht
        (lambda (nt rhs)
@@ -131,19 +147,74 @@ before the pattern compiler is invoked.
         (for-each (lambda (nt)
                     (hash-table-put! across-ht (nt-name nt) null))
                   compatible-context-language)
-        (do-compilation clang-ht lang #t)
-        (do-compilation across-ht compatible-context-language #f)
+        (do-compilation clang-ht clang-list-ht lang #t)
+        (do-compilation across-ht across-ht compatible-context-language #f)
         clang)))
   
   ; build-has-hole-ht : (listof nt) -> hash-table[symbol -o> boolean]
   ; produces a map of nonterminal -> whether that nonterminal could produce a hole
   (define (build-has-hole-ht lang)
-    (let ([has-hole-ht (make-hash-table)])
-      (for-each
-       (lambda (nt) (hash-table-put! has-hole-ht (nt-name nt) #t))
-       lang)
-      has-hole-ht))
+    (build-nt-property 
+     lang
+     (lambda (pattern recur)
+       (match pattern
+         [`any #f]
+         [`number #f]
+         [`string #f]
+         [`variable #f] 
+         [`(variable-except ,@(vars ...)) #f]
+         [`hole #t]
+         [`(hole ,(? symbol? hole-name)) #t]
+         [(? string?) #f]
+         [(? symbol?)
+          ;; cannot be a non-terminal, otherwise this function isn't called
+          #f]
+         [`(name ,name ,pat)
+           (recur pat)]
+         [`(in-hole ,context ,contractum)
+           (recur contractum)]
+         [`(in-named-hole ,hole-name ,context ,contractum)
+           (recur contractum)]
+         [`(side-condition ,pat ,condition)
+           (recur pat)]
+         [(? list?)
+          (ormap recur pattern)]
+         [else #f]))
+     #t
+     (lambda (lst) (ormap values lst))))
   
+  ;; build-nt-property : lang (pattern[not-non-terminal] (pattern -> boolean) -> boolean) boolean
+  ;;                  -> hash-table[symbol[nt] -> boolean]
+  (define (build-nt-property lang test-rhs conservative-answer combine-rhss)
+    (let ([ht (make-hash-table)]
+          [rhs-ht (make-hash-table)])
+      (for-each
+       (lambda (nt)
+         (hash-table-put! rhs-ht (nt-name nt) (nt-rhs nt))
+         (hash-table-put! ht (nt-name nt) 'unknown))
+       lang)
+      (let ()
+        (define (check-nt nt-sym)
+          (let ([current (hash-table-get ht nt-sym)])
+            (case current
+              [(unknown)
+               (hash-table-put! ht nt-sym 'computing)
+               (let ([answer (combine-rhss 
+                              (map (lambda (x) (check-rhs (rhs-pattern x)))
+                                   (hash-table-get rhs-ht nt-sym)))])
+                 (hash-table-put! ht nt-sym answer)
+                 answer)]
+              [(computing) conservative-answer]
+              [else current])))
+        (define (check-rhs rhs)
+          (cond
+            [(hash-table-maps? ht rhs)
+             (check-nt rhs)]
+            [else (test-rhs rhs check-rhs)]))
+        (for-each (lambda (nt) (check-nt (nt-name nt)))
+                  lang)
+        ht)))
+          
   ;; build-compatible-context-language : lang -> lang
   (define (build-compatible-context-language clang-ht lang)
     (apply
@@ -252,6 +323,100 @@ before the pattern compiler is invoked.
             (lambda (l) pattern)]))
        count)))
   
+  ;; build-list-nt-label : lang -> hash-table[symbol -o> boolean]
+  (define (build-list-nt-label lang)
+    (build-nt-property 
+     lang
+     (lambda (pattern recur)
+       (may-be-list-pattern?/internal pattern
+                                      (lambda (sym) #f)
+                                      recur))
+     #t
+     (lambda (lst) (ormap values lst))))
+  
+  (define (may-be-list-pattern? pattern list-nt-table)
+    (let loop ([pattern pattern])
+      (may-be-list-pattern?/internal
+       pattern
+       (lambda (sym)
+         (hash-table-get list-nt-table
+                         sym
+                         (lambda () #f)))
+       loop)))
+  
+  (define (may-be-list-pattern?/internal pattern handle-symbol recur)
+    (match pattern
+      [`any #t]
+      [`number #f]
+      [`string #f]
+      [`variable #f] 
+      [`(variable-except ,@(vars ...)) #f]
+      [`hole  #t]
+      [`(hole ,(? symbol? hole-name)) #t]
+      [(? string?) #f]
+      [(? symbol?) 
+       (handle-symbol pattern)]
+      [`(name ,name ,pat)
+        (recur pat)]
+      [`(in-hole ,context ,contractum)
+        (recur context)]
+      [`(in-named-hole ,hole-name ,context ,contractum)
+        (recur context)]
+      [`(side-condition ,pat ,condition)
+        (recur pat)]
+      [(? list?)
+       #t]
+      [else 
+       ;; is this right?!
+       (or (null? pattern) (pair? pattern))]))
+
+  
+  ;; build-non-list-nt-label : lang -> hash-table[symbol -o> boolean]
+  (define (build-non-list-nt-label lang)
+    (build-nt-property 
+     lang
+     (lambda (pattern recur)
+       (may-be-non-list-pattern?/internal pattern
+                                 (lambda (sym) #t)
+                                 recur))
+     #t
+     (lambda (lst) (ormap values lst))))
+  
+  (define (may-be-non-list-pattern? pattern non-list-nt-table)
+    (let loop ([pattern pattern])
+      (may-be-non-list-pattern?/internal
+       pattern
+       (lambda (sym)
+         (hash-table-get non-list-nt-table
+                         sym
+                         (lambda () #t)))
+       loop)))
+  
+  (define (may-be-non-list-pattern?/internal pattern handle-sym recur)
+    (match pattern
+      [`any #t]
+      [`number #t]
+      [`string #t]
+      [`variable #t] 
+      [`(variable-except ,@(vars ...)) #t]
+      [`hole #t]
+      [`(hole ,(? symbol? hole-name)) #t]
+      [(? string?) #t]
+      [(? symbol?) (handle-sym pattern)]
+      [`(name ,name ,pat)
+        (recur pat)]
+      [`(in-hole ,context ,contractum)
+        (recur context)]
+      [`(in-named-hole ,hole-name ,context ,contractum)
+        (recur context)]
+      [`(side-condition ,pat ,condition)
+        (recur pat)]
+      [(? list?)
+       #f]
+      [else 
+       ;; is this right?!
+       (not (or (null? pattern) (pair? pattern)))]))
+  
   ;; match-pattern : compiled-pattern exp -> (union #f (listof bindings))
   (define (match-pattern compiled-pattern exp)
     (let ([results (compiled-pattern exp #f)])
@@ -300,7 +465,7 @@ before the pattern compiler is invoked.
          (mtch-hole match)))))
   
   (define underscore-allowed '(any number string variable))
-
+  
   ;; compile-pattern : compiled-lang pattern -> compiled-pattern
   (define compile-pattern
     (opt-lambda (clang pattern)
@@ -310,6 +475,7 @@ before the pattern compiler is invoked.
   ;; compile-pattern : compiled-lang pattern boolean -> (values compiled-pattern boolean)
   (define (compile-pattern/cross? clang pattern prefix-cross?)
     (define clang-ht (compiled-lang-ht clang))
+    (define clang-list-ht (compiled-lang-list-ht clang))
     (define has-hole-ht (compiled-lang-has-hole-ht clang))
     (define across-ht (compiled-lang-across-ht clang))
     (define compiled-pattern-cache (compiled-lang-cache clang))
@@ -325,7 +491,7 @@ before the pattern compiler is invoked.
                                    (hash-table-put! compiled-pattern-cache pattern val)
                                    val))))])
         (values (car compiled-cache) (cdr compiled-cache))))
-  
+    
     ;; consult-compiled-pattern-cache : sexp[pattern] (-> compiled-pattern) -> compiled-pattern
     (define (consult-compiled-pattern-cache pattern calc)
       (hash-table-get 
@@ -391,7 +557,9 @@ before the pattern compiler is invoked.
            [(hash-table-maps? clang-ht pattern)
             (values
              (lambda (exp hole-info)
-               (match-nt clang-ht pattern exp hole-info))
+               (match-nt (hash-table-get clang-list-ht pattern)
+                         (hash-table-get clang-ht pattern)
+                         pattern exp hole-info))
              (hash-table-get has-hole-ht pattern))]
            [(has-underscore? pattern)
             (let ([before (split-underscore pattern)])
@@ -413,10 +581,11 @@ before the pattern compiler is invoked.
                         (symbol-append pre-id '- pre-id)
                         pre-id)])
             (cond
-              [(hash-table-get across-ht id (lambda () #f))
+              [(hash-table-maps? across-ht id)
                (values
                 (lambda (exp hole-info)
-                  (match-nt across-ht id exp hole-info))
+                  (let ([rhs-list (hash-table-get across-ht id)])
+                    (match-nt rhs-list rhs-list id exp hole-info)))
                 #t)]
               [else
                (error 'compile-pattern "unknown cross reference ~a" id)]))]
@@ -516,7 +685,7 @@ before the pattern compiler is invoked.
   
   (define (memoize/key f key-fn statsbox)
     (let ([ht (make-hash-table 'equal)]
-	  [entries 0])
+          [entries 0])
       (lambda (x y)
         (set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox)))
         (let* ([key (key-fn x y)]
@@ -535,7 +704,7 @@ before the pattern compiler is invoked.
   
   (define-struct cache-stats (name misses hits))
   (define (new-cache-stats name) (make-cache-stats name 0 0))
-
+  
   (define w/hole (new-cache-stats "hole"))
   (define nohole (new-cache-stats "no-hole"))
   
@@ -544,20 +713,22 @@ before the pattern compiler is invoked.
       (for-each 
        (lambda (s) 
          (when (> (+ (cache-stats-hits s) (cache-stats-misses s)) 0)
-           (printf "~a has ~a hits, ~a misses (~a)\n" 
+           (printf "~a has ~a hits, ~a misses (~a% miss rate)\n" 
                    (cache-stats-name s)
                    (cache-stats-hits s)
                    (cache-stats-misses s)
-                   (* 100 (/ (cache-stats-hits s)
-                             (+ (cache-stats-hits s) (cache-stats-misses s)))))))
+                   (floor
+                    (* 100 (/ (cache-stats-misses s)
+                              (+ (cache-stats-hits s) (cache-stats-misses s))))))))
        stats)
       (let ((overall-hits (apply + (map cache-stats-hits stats)))
             (overall-miss (apply + (map cache-stats-misses stats))))
         (printf "---\nOverall hits: ~a\n" overall-hits)
-        (printf "\nOverall misses: ~a\n" overall-miss)
+        (printf "Overall misses: ~a\n" overall-miss)
         (when (> (+ overall-hits overall-miss) 0)
-          (printf "\nOverall rate: ~a\n" (* 100 (/ overall-hits (+ overall-hits overall-miss))))))))
-
+          (printf "Overall miss rate: ~a%\n" 
+                  (floor (* 100 (/ overall-miss (+ overall-hits overall-miss)))))))))
+  
   ;; match-hole : (union #f symbol) -> compiled-pattern
   (define (match-hole hole-id)
     (lambda (exp hole-info)
@@ -725,7 +896,7 @@ before the pattern compiler is invoked.
                                              (mtch-hole multiple-match))))))
                  bindingss)))
             multiple-bindingss)))
-    
+  
   ;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp)
   (define (pick-hole s1 s2)
     (cond
@@ -748,18 +919,20 @@ before the pattern compiler is invoked.
               (mtch-hole match))))
          matches))
   
-  ;; match-nt : hash-table[from compiled-lang] sym exp hole-info -> (union #f (listof bindings))
-  (define (match-nt clang-ht nt term hole-info)
-    (let ([compiled-rhss (hash-table-get clang-ht nt)])
-      (let loop ([rhss compiled-rhss]
-                 [anss null])
-        (cond
-          [(null? rhss) (if (null? anss) #f (apply append anss))]
-          [else
-           (let ([mth (remove-bindings/filter ((car rhss) term hole-info))])
-             (if mth
-                 (loop (cdr rhss) (cons mth anss))
-                 (loop (cdr rhss) anss)))]))))
+  ;; match-nt : (listof compiled-rhs) (listof compiled-rhs) sym exp hole-info
+  ;;        -> (union #f (listof bindings))
+  (define (match-nt list-rhs non-list-rhs nt term hole-info)
+    (let loop ([rhss (if (or (null? term) (pair? term))
+                         list-rhs
+                         non-list-rhs)]
+               [anss null])
+      (cond
+        [(null? rhss) (if (null? anss) #f (apply append anss))]
+        [else
+         (let ([mth (remove-bindings/filter ((car rhss) term hole-info))])
+           (if mth
+               (loop (cdr rhss) (cons mth anss))
+               (loop (cdr rhss) anss)))])))
   
   ;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch))
   (define (remove-bindings/filter matches)
@@ -816,7 +989,7 @@ before the pattern compiler is invoked.
         [`number ribs] 
         [`variable ribs] 
         [`(variable-except ,@(vars ...)) ribs]
-
+        
         [`hole (error 'match-pattern "cannot have a hole inside an ellipses")]
         [(? symbol?) 
          (cond
@@ -872,7 +1045,7 @@ before the pattern compiler is invoked.
           snd))
        fst)
       mtchs))
-
+  
   (define (hash-table-maps? ht key)
     (let/ec k
       (hash-table-get ht key (lambda () (k #f)))
@@ -885,7 +1058,8 @@ before the pattern compiler is invoked.
   ;;
   
   #|
-  This ADT isn't right yet -- need to figure out what to do about (name ...) patterns.
+  ;; This version of the ADT isn't right yet -- 
+  ;; need to figure out what to do about (name ...) patterns.
 
   (define-values (struct:context make-context context? context-ref context-set!)
     (make-struct-type 'context #f 1 0 #f '() #f 0))
@@ -897,7 +1071,8 @@ before the pattern compiler is invoked.
   (define (build-nested-context c1 c2) (make-context (lambda (x) (c1 (c2 x)))))
   (define (plug exp hole-stuff) (exp hole-stuff))
   (define (reverse-context c) (make-context (lambda (x) (reverse (c x)))))
-|#  
+
+|#
   (define (context? x) #t)
   (define hole
     (let ()
@@ -916,13 +1091,11 @@ before the pattern compiler is invoked.
         [(pair? exp) (cons (loop (car exp)) (loop (cdr exp)))]
         [(eq? exp hole) hole-stuff]
         [else exp])))
-
+  
   ;;
   ;; end context adt
   ;;
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-  
   
   (provide/contract
    (match-pattern (compiled-pattern any/c . -> . (union false/c (listof mtch?))))
@@ -941,7 +1114,9 @@ before the pattern compiler is invoked.
    (make-rib (symbol? any/c . -> . rib?))
    (rib? (any/c . -> . boolean?))
    (rib-name (rib? . -> . symbol?))
-   (rib-exp (rib? . -> . any/c)))
+   (rib-exp (rib? . -> . any/c))
+   
+   (print-stats (-> void?)))
   
   ;; for test suite
   (provide build-cons-context
@@ -960,7 +1135,6 @@ before the pattern compiler is invoked.
            plug
            none? none
            
-           print-stats
            make-repeat
            
            hole