smp: without-interrupts: gcfinal.scm

diff --git a/README.txt b/README.txt
index fd41be916df22fdff29af16d6e4ef2ddcadca72f..cb39dab51ee347afc75005fccc35e2d7c86a8037 100644 (file)
--- a/README.txt
+++ b/README.txt
@@ -1082,12 +1082,25 @@ The hits with accompanying analysis:
        enqueuers can be serialized in the usual way.
 
   gcfinal.scm:69:  (without-interrupts
+       Caller: add-to-gc-finalizer!
   gcfinal.scm:89:    (without-interrupts
+       Caller: remove-from-gc-finalizer!
   gcfinal.scm:111:    (without-interrupts
+       Caller: remove-all-from-gc-finalizer!
   gcfinal.scm:129:  (without-interrupts
+       Caller: search-gc-finalizer
   gcfinal.scm:140:  (without-interrupts
+       Caller: gc-finalizer-elements
   gcfinal.scm:164:        (without-interrupts
+       Caller: make-gc-finalized-object
   gcfinal.scm:180:  (without-interrupts
+       Caller: reset-gc-finalizers
+
+       OK.  Replaced without-interrupts with with-thread-mutex-
+       locked.  Added a thread-mutex to each finalizer, and one to
+       serialize access to the list of gc-finalizers.  This required
+       changes to the bootstrap, which now loads/inits thread.scm
+       (and vector.scm and wind.scm) before gcfinal.scm.
 
   gdbm.scm:61:    (without-interrupts
 

diff --git a/src/runtime/gcfinal.scm b/src/runtime/gcfinal.scm
index b27e0eee3bf123d8898fc0bd4ee472e305e18b55..18b0da65c2fa3f4c218a3562f523eee24bbb73ee 100644 (file)
--- a/src/runtime/gcfinal.scm
+++ b/src/runtime/gcfinal.scm
@@ -37,7 +37,8 @@ USA.
   (object? #f read-only #t)
   (object-context #f read-only #t)
   (set-object-context! #f read-only #t)
-  (items '()))
+  (mutex #f read-only #t)
+  items)
 
 (define (guarantee-gc-finalizer object procedure)
   (if (not (gc-finalizer? object))
@@ -56,8 +57,11 @@ USA.
                             object?
                             object-context
                             set-object-context!
+                            (make-thread-mutex)
                             '())))
-    (set! gc-finalizers (weak-cons finalizer gc-finalizers))
+    (with-thread-mutex-locked gc-finalizers-mutex
+      (lambda ()
+       (set! gc-finalizers (weak-cons finalizer gc-finalizers))))
     finalizer))
 
 (define (add-to-gc-finalizer! finalizer object)
@@ -66,14 +70,14 @@ USA.
       (error:wrong-type-argument object
                                 "finalized object"
                                 'ADD-TO-GC-FINALIZER!))
-  (without-interrupts
-   (lambda ()
-     (let ((context ((gc-finalizer-object-context finalizer) object)))
-       (if (not context)
-          (error:bad-range-argument object 'ADD-TO-GC-FINALIZER!))
-       (set-gc-finalizer-items! finalizer
-                               (cons (weak-cons object context)
-                                     (gc-finalizer-items finalizer))))))
+  (with-thread-mutex-locked (gc-finalizer-mutex finalizer)
+    (lambda ()
+      (let ((context ((gc-finalizer-object-context finalizer) object)))
+       (if (not context)
+           (error:bad-range-argument object 'ADD-TO-GC-FINALIZER!))
+       (set-gc-finalizer-items! finalizer
+                                (cons (weak-cons object context)
+                                      (gc-finalizer-items finalizer))))))
   object)
 
 (define (remove-from-gc-finalizer! finalizer object)
@@ -86,67 +90,67 @@ USA.
        (error:wrong-type-argument object
                                   "finalized object"
                                   'REMOVE-FROM-GC-FINALIZER!))
-    (without-interrupts
-     (lambda ()
-       (let ((context (object-context object)))
-        (if (not context)
-            (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!))
-        (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
-          (if (not (pair? items))
-              (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!))
-          (if (eq? object (weak-car (car items)))
-              (let ((next (cdr items)))
-                (if prev
-                    (set-cdr! prev next)
-                    (set-gc-finalizer-items! finalizer next))
-                (set-object-context! object #f)
-                (procedure context))
-              (loop (cdr items) items))))))))
+    (with-thread-mutex-locked (gc-finalizer-mutex finalizer)
+      (lambda ()
+       (let ((context (object-context object)))
+         (if (not context)
+             (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!))
+         (let loop ((items (gc-finalizer-items finalizer)) (prev #f))
+           (if (not (pair? items))
+               (error:bad-range-argument object 'REMOVE-FROM-GC-FINALIZER!))
+           (if (eq? object (weak-car (car items)))
+               (let ((next (cdr items)))
+                 (if prev
+                     (set-cdr! prev next)
+                     (set-gc-finalizer-items! finalizer next))
+                 (set-object-context! object #f)
+                 (procedure context))
+               (loop (cdr items) items))))))))
 \f
 (define (remove-all-from-gc-finalizer! finalizer)
   (guarantee-gc-finalizer finalizer 'REMOVE-ALL-FROM-GC-FINALIZER!)
   (let ((procedure (gc-finalizer-procedure finalizer))
        (object-context (gc-finalizer-object-context finalizer))
        (set-object-context! (gc-finalizer-set-object-context! finalizer)))
-    (without-interrupts
-     (lambda ()
-       (let loop ()
-        (let ((items (gc-finalizer-items finalizer)))
-          (if (pair? items)
-              (let ((item (car items)))
-                (set-gc-finalizer-items! finalizer (cdr items))
-                (let ((object (weak-car item)))
-                  (let ((context (object-context object)))
-                    (if context
-                        (begin
-                          (if object
-                              (set-object-context! object #f))
-                          (procedure context)))))
-                (loop)))))))))
+    (with-thread-mutex-locked (gc-finalizer-mutex finalizer)
+      (lambda ()
+       (let loop ()
+         (let ((items (gc-finalizer-items finalizer)))
+           (if (pair? items)
+               (let ((item (car items)))
+                 (set-gc-finalizer-items! finalizer (cdr items))
+                 (let ((object (weak-car item)))
+                   (let ((context (object-context object)))
+                     (if context
+                         (begin
+                           (if object
+                               (set-object-context! object #f))
+                           (procedure context)))))
+                 (loop)))))))))
 
 (define (search-gc-finalizer finalizer predicate)
   (guarantee-gc-finalizer finalizer 'SEARCH-GC-FINALIZER)
-  (without-interrupts
-   (lambda ()
-     (let loop ((items (gc-finalizer-items finalizer)))
-       (and (pair? items)
-           (let ((object (weak-car (car items))))
-             (if (and object (predicate object))
-                 object
-                 (loop (cdr items)))))))))
+  (with-thread-mutex-locked (gc-finalizer-mutex finalizer)
+    (lambda ()
+      (let loop ((items (gc-finalizer-items finalizer)))
+       (and (pair? items)
+            (let ((object (weak-car (car items))))
+              (if (and object (predicate object))
+                  object
+                  (loop (cdr items)))))))))
 
 (define (gc-finalizer-elements finalizer)
   (guarantee-gc-finalizer finalizer 'GC-FINALIZER-ELEMENTS)
-  (without-interrupts
-   (lambda ()
-     (let loop ((items (gc-finalizer-items finalizer)) (objects '()))
-       (if (pair? items)
-          (loop (cdr items)
-                (let ((object (weak-car (car items))))
-                  (if object
-                      (cons object objects)
-                      objects)))
-          (reverse! objects))))))
+  (with-thread-mutex-locked (gc-finalizer-mutex finalizer)
+    (lambda ()
+      (let loop ((items (gc-finalizer-items finalizer)) (objects '()))
+       (if (pair? items)
+           (loop (cdr items)
+                 (let ((object (weak-car (car items))))
+                   (if object
+                       (cons object objects)
+                       objects)))
+           (reverse! objects))))))
 
 (define (make-gc-finalized-object finalizer get-context context->object)
   ;; A bunch of hair to permit microcode descriptors be opened with
@@ -161,12 +165,12 @@ USA.
        (get-context p)
        (let ((context (weak-cdr p)))
         (let ((object (context->object context)))
-          (without-interrupts
-           (lambda ()
-             (weak-set-car! p object)
-             (set-gc-finalizer-items!
-              finalizer
-              (cons p (gc-finalizer-items finalizer)))))
+          (with-thread-mutex-locked (gc-finalizer-mutex finalizer)
+            (lambda ()
+              (weak-set-car! p object)
+              (set-gc-finalizer-items!
+               finalizer
+               (cons p (gc-finalizer-items finalizer)))))
           object)))
      (lambda ()
        (if (and (not (weak-pair/car? p)) (weak-cdr p))
@@ -174,14 +178,15 @@ USA.
             ((gc-finalizer-procedure finalizer) (weak-cdr p))
             (weak-set-cdr! p #f)))))))
 \f
-(define gc-finalizers)
+(define gc-finalizers '())
+(define gc-finalizers-mutex (make-thread-mutex))
 
 (define (reset-gc-finalizers)
-  (without-interrupts
-   (lambda ()
-     (walk-gc-finalizers-list
-      (lambda (finalizer)
-       (set-gc-finalizer-items! finalizer '()))))))
+  (walk-gc-finalizers-list
+   (lambda (finalizer)
+     (with-thread-mutex-locked (gc-finalizer-mutex finalizer)
+       (lambda ()
+        (set-gc-finalizer-items! finalizer '()))))))
 
 (define (run-gc-finalizers)
   (walk-gc-finalizers-list
@@ -200,21 +205,22 @@ USA.
                   (loop next prev)))))))))
 
 (define (walk-gc-finalizers-list procedure)
-  (let loop ((finalizers gc-finalizers) (prev #f))
-    (if (weak-pair? finalizers)
-       (let ((finalizer (weak-car finalizers)))
-         (if finalizer
-             (begin
-               (procedure finalizer)
-               (loop (weak-cdr finalizers) finalizers))
-             (let ((next (weak-cdr finalizers)))
-               (if prev
-                   (weak-set-cdr! prev next)
-                   (set! gc-finalizers next))
-               (loop next prev)))))))
+  (with-thread-mutex-locked gc-finalizers-mutex
+    (lambda ()
+      (let loop ((finalizers gc-finalizers) (prev #f))
+       (if (weak-pair? finalizers)
+           (let ((finalizer (weak-car finalizers)))
+             (if finalizer
+                 (begin
+                   (procedure finalizer)
+                   (loop (weak-cdr finalizers) finalizers))
+                 (let ((next (weak-cdr finalizers)))
+                   (if prev
+                       (weak-set-cdr! prev next)
+                       (set! gc-finalizers next))
+                   (loop next prev)))))))))
 
 (define (initialize-package!)
-  (set! gc-finalizers '())
   (add-gc-daemon! run-gc-finalizers))
 
 (define (initialize-events!)

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index fb0bc315a68d45aee03c211d0265eada37b1abae..a6220ac743d0fb297fed558ac55ed6fdeea29064 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -374,8 +374,12 @@ USA.
         ("prop1d" . (RUNTIME 1D-PROPERTY))
         ("events" . (RUNTIME EVENT-DISTRIBUTOR))
         ("gdatab" . (RUNTIME GLOBAL-DATABASE))
+        ("vector" . (RUNTIME VECTOR))
+        ("thread" . (RUNTIME THREAD))
+        ("wind" . (RUNTIME WIND))
         ("gcfinal" . (RUNTIME GC-FINALIZER))
-        ("string" . (RUNTIME STRING))))
+        ("string" . (RUNTIME STRING))  ; First GC-finalizer.
+        ))
       (load-files
        (lambda (files)
         (do ((files files (cdr files)))
@@ -396,6 +400,7 @@ USA.
   (package-initialize '(RUNTIME GLOBAL-DATABASE) #f #t)
   (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t)
+  (package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t)
   (package-initialize '(RUNTIME GC-FINALIZER) #f #t)
   (package-initialize '(RUNTIME STRING) #f #t)
 
@@ -431,8 +436,6 @@ USA.
  '(
    ;; Microcode interface
    ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES!)
-   ((RUNTIME THREAD) INITIALIZE-LOW!)
-   (RUNTIME WIND)
    (RUNTIME APPLY)
    (RUNTIME HASH)                      ; First GC daemon!
    (RUNTIME PRIMITIVE-IO)