From e3d324d733fbc17ea55120ad2f307b5cd39ed98a Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Tue, 8 Dec 2015 21:43:16 +0100
Subject: [PATCH] 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.
---
 NEWS             |  1 +
 irregex-core.scm | 32 ++++++++++++++++++--------------
 2 files changed, 19 insertions(+), 14 deletions(-)

diff --git a/NEWS b/NEWS
index 027e7e5..fb80932 100644
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,7 @@
 - Core libraries
    - SRFI-18: thread-join! no longer gives an error when passed a
       thread in the "sleeping" state (thanks to Joerg Wittenberger)
+   - Irregex matching performance has been improved.
 
 - Unit "posix": The following posix procedures now work on port
     objects: file-stat, file-size, file-owner, file-permissions,
diff --git a/irregex-core.scm b/irregex-core.scm
index 9d09a48..5f6f332 100644
--- a/irregex-core.scm
+++ b/irregex-core.scm
@@ -3681,20 +3681,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))
-- 
2.1.4