From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 21 Feb 2015 20:11:16 +0000 (-0700)
Subject: smp: without-interrupts: generic.scm
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ba4c087eea37501f8a6a618a0e753dd363edaac3;p=mit-scheme.git

smp: without-interrupts: generic.scm
---

diff --git a/README.txt b/README.txt
index c9010798e..d37659256 100644
--- a/README.txt
+++ b/README.txt
@@ -1134,8 +1134,16 @@ The hits with accompanying analysis:
 	tables, however, is now provided via a thread-mutex.
 
   generic.scm:104:    (without-interrupts
+	Caller: set-generic-procedure-generator!
   generic.scm:132:  (without-interrupts
+	Caller: %purge-generic-procedure-cache!
   generic.scm:277:      (without-interrupts
+	Caller: compute-method-and-store
+
+	OK.  Used to avoid inopportune aborts.  Serial access to
+	particular generic functions is the responsibility of the
+	luser.  Serial access to the generic-procedure-records table
+	is now provided via a thread-mutex.
 
   global.scm:36:  get-interrupt-enables set-interrupt-enables! with-interrupt-mask
   global.scm:129:  (set-interrupt-enables! (fix:and limit-mask (get-interrupt-enables))))
diff --git a/src/runtime/generic.scm b/src/runtime/generic.scm
index c7d94c61c..de020f93a 100644
--- a/src/runtime/generic.scm
+++ b/src/runtime/generic.scm
@@ -52,7 +52,9 @@ USA.
 				(new-cache (procedure-arity-min arity)))))
       (let ((generic (compute-apply-generic record)))
 	(set-generic-record/procedure! record generic)
-	(eqht/put! generic-procedure-records generic record)
+	(with-thread-mutex-locked generic-procedure-records-mutex
+	  (lambda ()
+	    (eqht/put! generic-procedure-records generic record)))
 	generic))))
 
 (define-structure (generic-record
@@ -69,7 +71,9 @@ USA.
   procedure)
 
 (define (generic-procedure? object)
-  (if (eqht/get generic-procedure-records object #f) #t #f))
+  (with-thread-mutex-locked generic-procedure-records-mutex
+    (lambda ()
+      (if (eqht/get generic-procedure-records object #f) #t #f))))
 
 (define (generic-record/arity record)
   (make-procedure-arity (generic-record/arity-min record)
@@ -116,7 +120,9 @@ USA.
 	     (lambda (generic record)
 	       (%purge-generic-procedure-cache! generic record filter)))))
     (if (eq? 'ALL-PROCEDURES generic)
-	(eqht/for-each generic-procedure-records operator)
+	(with-thread-mutex-locked generic-procedure-records-mutex
+	  (lambda ()
+	    (eqht/for-each generic-procedure-records operator)))
 	(operator
 	 generic
 	 (guarantee-generic-procedure generic
@@ -137,7 +143,9 @@ USA.
 			   (lambda (tags) (filter generic tags)))))))
 
 (define (guarantee-generic-procedure generic caller)
-  (or (eqht/get generic-procedure-records generic #f)
+  (or (with-thread-mutex-locked generic-procedure-records-mutex
+	(lambda ()
+	  (eqht/get generic-procedure-records generic #f)))
       (error:wrong-type-argument generic "generic procedure" caller)))
 
 (define (guarantee-generator generator caller)
@@ -351,6 +359,7 @@ USA.
 
 (define standard-generic-procedure-tag)
 (define generic-procedure-records)
+(define generic-procedure-records-mutex)
 (define built-in-tags)
 (define microcode-type-tag-table)
 (define microcode-type-method-table)
@@ -359,6 +368,7 @@ USA.
   (set! standard-generic-procedure-tag
 	(make-dispatch-tag 'STANDARD-GENERIC-PROCEDURE))
   (set! generic-procedure-records (make-eqht))
+  (set! generic-procedure-records-mutex (make-thread-mutex))
 
   ;; Initialize the built-in tag tables.
   (set! built-in-tags '())
@@ -380,7 +390,9 @@ USA.
 			   (vector-ref microcode-type-tag-table code)))
 	     (vector-set! microcode-type-tag-table code #f)))))
     (define-integrable (maybe-generic object default-tag)
-      (let ((record (eqht/get generic-procedure-records object #f)))
+      (let ((record (with-thread-mutex-locked generic-procedure-records-mutex
+		      (lambda ()
+			(eqht/get generic-procedure-records object #f)))))
 	(if record
 	    (generic-record/tag record)
 	    default-tag)))