smp: without-interrupts: rgxcmp.scm

diff --git a/README.txt b/README.txt
index 5325082a0ba6b24884c876abaa38cf1f30f84e52..6154a1bf36851f8dcf6136424bd3ed5916ac6a48 100644 (file)
--- a/README.txt
+++ b/README.txt
@@ -1527,6 +1527,8 @@ The hits with accompanying analysis:
   rgxcmp.scm:161:                    (without-interrupts
   rgxcmp.scm:169:               (without-interrupts
 
+       Added a mutex to each of the two memoization caches.  
+
   runtime.pkg:165:       with-absolutely-no-interrupts
   runtime.pkg:166:       with-limited-interrupts
   runtime.pkg:167:       without-interrupts)

diff --git a/src/runtime/rgxcmp.scm b/src/runtime/rgxcmp.scm
index 0f71d79ec327652b6aba25d6fccbfc01d6c6aba1..9189585cda58a5a756107043b1ab6267b71cbf03 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)
+  (without-interruption
+   (lambda ()
+     (with-thread-mutex-locked (cadr cache) 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