smp: without-interrupts: generic.scm

diff --git a/README.txt b/README.txt
index c9010798e498163c3284308aa9bc5fb41cbdb7ef..d3765925608c566b89191c6844c52b0e7fb071a5 100644 (file)
--- 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 c7d94c61cf0552038694013341463989b77ea7db..de020f93a0192e20850c9f164198d95ab5bf6c53 100644 (file)
--- 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)))