From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Wed, 17 Jun 2015 02:34:03 +0000 (-0700)
Subject: Remove without-interrupts from runtime/rgxcmp.scm.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~50
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4615a333fdc7f66870d1e76504c6b9f2f424ed2d;p=mit-scheme.git

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 0f71d79ec..5f885caf0 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)
+  (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)))))))))
 
 ;;;; String Compiler