~ chicken-core (chicken-5) 022dce8264fb9aead93ecc98b88ad7cc7cc79915

commit 022dce8264fb9aead93ecc98b88ad7cc7cc79915
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Tue Dec 8 21:43:16 2015 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Tue Dec 8 21:43:16 2015 +0100

    Improve irregex matching performance
    
    We add type declarations to "cset-contains?" to ensure unsafe versions
    of char comparison functions, vector access and car/cdr are used.  This
    hacks up irregex core even further, but it's worthwhile: in some cases a
    regex match can run twice as fast.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/irregex-core.scm b/irregex-core.scm
index 71939af1..bae78d99 100644
--- a/irregex-core.scm
+++ b/irregex-core.scm
@@ -3718,20 +3718,24 @@
               (vector->list cset))))
 
 (define (cset-contains? cset ch)
-  (let ((len (vector-length cset)))
-    (case len
-      ((0) #f)
-      ((1) (let ((range (vector-ref cset 0)))
-             (and (char<=? ch (cdr range)) (char<=? (car range) ch))))
-      (else (let lp ((lower 0) (upper len))
-              (let* ((middle (quotient (+ upper lower) 2))
-                     (range (vector-ref cset middle)))
-                (cond ((char<? (cdr range) ch)
-                       (let ((next (+ middle 1)))
-                         (and (< next upper) (lp next upper))))
-                      ((char<? ch (car range))
-                       (and (< lower middle) (lp lower middle)))
-                      (else #t))))))))
+  ;; CHICKEN: Type assumption added for performance.  This is a very
+  ;; hot code path, so every type improvement matters.
+  (assume ((cset (vector-of (pair char char)))
+           (ch char))
+    (let ((len (vector-length cset)))
+      (case len
+        ((0) #f)
+        ((1) (let ((range (vector-ref cset 0)))
+               (and (char<=? ch (cdr range)) (char<=? (car range) ch))))
+        (else (let lp ((lower 0) (upper len))
+                (let* ((middle (quotient (+ upper lower) 2))
+                       (range (vector-ref cset middle)))
+                  (cond ((char<? (cdr range) ch)
+                         (let ((next (+ middle 1)))
+                           (and (< next upper) (lp next upper))))
+                        ((char<? ch (car range))
+                         (and (< lower middle) (lp lower middle)))
+                        (else #t)))))))))
 
 (define (char-ranges-union a b)
   (cons (if (char<=? (car a) (car b)) (car a) (car b))