Remove without-interrupts from runtime/rgxcmp.scm.

Add a mutex to each of the memoization caches.

diff --git a/src/runtime/rgxcmp.scm b/src/runtime/rgxcmp.scm
index 0f71d79ec327652b6aba25d6fccbfc01d6c6aba1..5f885caf0e6973f4c3d97dc4854f9d0196b9ce62 100644 (file)
--- a/src/runtime/rgxcmp.scm
+++ b/src/runtime/rgxcmp.scm
@@ -146,35 +146,38 @@ USA.
        ((null? items))
       (set-car! items (cons (cons #f #f) #f)))
     (set-cdr! (last-pair items) items)
-    (cons 'CACHE items)))
+    (cons* 'CACHE (make-thread-mutex) items)))
+
+(define-integrable (with-cache-locked cache thunk)
+  (with-thread-mutex-lock (cadr cache)
+    (lambda ()
+      (without-interruption thunk))))
 
 (define (cache-result cache procedure key1 key2)
-  (let* ((tail (cdr cache))
-        (head (cdr tail)))
-    (let loop ((items head) (prev tail))
-      (let ((item (car items)))
-       (cond ((and (eq? key1 (caar item))
-                   (eq? key2 (cdar item)))
-              (cond ((eq? tail items)
-                     (set-cdr! cache prev))
-                    ((not (eq? head items))
-                     (without-interrupts
-                      (lambda ()
-                        (set-cdr! prev (cdr items))
-                        (set-cdr! items head)
-                        (set-cdr! tail items)))))
-              (cdr item))
-             ((eq? tail items)
-              (let ((result (procedure key1 key2)))
-                (without-interrupts
-                 (lambda ()
-                   (set-car! (car item) key1)
-                   (set-cdr! (car item) key2)
-                   (set-cdr! item result)
-                   (set-cdr! cache prev)))
-                result))
-             (else
-              (loop (cdr items) items)))))))
+  (with-cache-locked cache
+    (lambda ()
+      (let* ((tail (cddr cache))
+            (head (cdr tail)))
+       (let loop ((items head) (prev tail))
+         (let ((item (car items)))
+           (cond ((and (eq? key1 (caar item))
+                       (eq? key2 (cdar item)))
+                  (cond ((eq? tail items)
+                         (set-cdr! (cdr cache) prev))
+                        ((not (eq? head items))
+                         (set-cdr! prev (cdr items))
+                         (set-cdr! items head)
+                         (set-cdr! tail items)))
+                  (cdr item))
+                 ((eq? tail items)
+                  (let ((result (procedure key1 key2)))
+                    (set-car! (car item) key1)
+                    (set-cdr! (car item) key2)
+                    (set-cdr! item result)
+                    (set-cdr! (cdr cache) prev)
+                    result))
+                 (else
+                  (loop (cdr items) items)))))))))
 \f
 ;;;; String Compiler