From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 10 Mar 2015 21:59:41 +0000 (-0700)
Subject: smp: without-interrupts: rgxcmp.scm
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=26ccd585f37a2e349b82bad0714442a140cca66b;p=mit-scheme.git

smp: without-interrupts: rgxcmp.scm
---

diff --git a/README.txt b/README.txt
index 5325082a0..6154a1bf3 100644
--- 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 0f71d79ec..9189585cd 100644
--- 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)))))))))
 
 ;;;; String Compiler