Synchronize processors for GC, purify and fasdump.

diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index b050e9f6b8d00afd140736867c26c6915f3482d9..59885267374ebfebe6899264560cd6d4e3884500 100644 (file)
--- a/src/runtime/gc.scm
+++ b/src/runtime/gc.scm
@@ -68,10 +68,12 @@ USA.
 (define default-safety-margin)
 \f
 (define (default/gc-flip safety-margin)
-  (if (and (not (eq? '() constant-space-queue))
-          (not (object-constant? constant-space-queue)))
-      (purify-internal constant-space-queue safety-margin)
-      (gc-flip-internal safety-margin)))
+  (with-gc-lock
+   (lambda ()
+     (if (and (not (eq? '() constant-space-queue))
+             (not (object-constant? constant-space-queue)))
+        (purify-internal constant-space-queue safety-margin)
+        (gc-flip-internal safety-margin)))))
 
 (define (default/purify item pure-space? queue?)
   pure-space?
@@ -82,7 +84,9 @@ USA.
            (lambda ()
              (set! constant-space-queue (cons item constant-space-queue))
              unspecific))
-         (purify-internal item default-safety-margin))))
+         (with-heap-lock
+          (lambda ()
+            (purify-internal item default-safety-margin))))))
 
 (define (default/stack-overflow)
   (abort->nearest "Aborting!: maximum recursion depth exceeded"))

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 02dae7738ecb2fac715a8bdce8740b1a825faafb..63679cad1b9f263393ebad758684544d9baa8187 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -388,8 +388,10 @@ USA.
     (let ((do-it
           (lambda ()
             (let loop ()
-              (if (not ((ucode-primitive primitive-fasdump)
-                        object filename dump-option))
+              (if (not (with-heap-lock
+                        (lambda ()
+                          ((ucode-primitive primitive-fasdump)
+                           object filename dump-option))))
                   (begin
                     (with-simple-restart 'RETRY "Try again."
                       (lambda ()

diff --git a/src/runtime/intrpt.scm b/src/runtime/intrpt.scm
index 0c197aeb9877b721f243d42b736f84aa4955d633..5a8c4d6817d89e70e490607730e9981ade060018 100644 (file)
--- a/src/runtime/intrpt.scm
+++ b/src/runtime/intrpt.scm
@@ -115,6 +115,10 @@ USA.
   args
   (abort->nearest "Aborting! Out of memory"))
 
+(define (global-gc-interrupt-handler interrupt-code interrupt-enables)
+  interrupt-code interrupt-enables
+  ((ucode-primitive smp-gc-wait 0)))
+
 (define after-gc-interrupt-handler
   (let ((running? #f))
     (named-lambda (after-gc-interrupt-handler interrupt-code interrupt-enables)
@@ -236,6 +240,11 @@ USA.
        (vector-set! interrupt-mask-vector gc-slot
                     interrupt-mask/none)
 
+       (vector-set! system-interrupt-vector global-gc-slot
+                    global-gc-interrupt-handler)
+       (vector-set! interrupt-mask-vector global-gc-slot
+                    interrupt-mask/none)
+
        (vector-set! system-interrupt-vector timer-slot
                     timer-interrupt-handler)
        (vector-set! interrupt-mask-vector timer-slot

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 551234d9478ecfac67d15379b55b37b35196c25d..4f98c6bf5e0b0181ac55474966e4d0ee4b415247 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -544,6 +544,7 @@ USA.
          with-values
          write-to-string)
   (import (runtime thread)
+         with-heap-lock
          with-obarray-lock)
   (initialization (initialize-package!)))
 
@@ -1992,6 +1993,9 @@ USA.
          hook/hardware-trap)
   (export (runtime gc-notification)
          abort-if-heap-low)
+  (import (runtime thread)
+         with-gc-lock
+         with-heap-lock)
   (initialization (initialize-package!)))
 
 (define-package (runtime gc-daemons)
@@ -2006,6 +2010,8 @@ USA.
          trigger-secondary-gc-daemons!)
   (export (runtime interrupt-handler)
          trigger-gc-daemons!)
+  (import (runtime thread)
+         enable-smp?)
   (initialization (initialize-package!)))
 
 (define-package (runtime gc-finalizer)

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index f59d570860f7731ba7463f07a5797c82a8f66cc7..87ccd2aab1813c21773a18fd27d616f23b8eedca 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -237,6 +237,42 @@ USA.
        (set-interrupt-enables! mask)
        value)))
 
+(define (with-gc-lock thunk)
+  ;; Serialize processors wanting to GC.
+  ;; If this processor loses the race to lock the heap, punt THUNK and
+  ;; just wait for the winner to perform the GC.
+  (%assert (eq? interrupt-mask/none (get-interrupt-enables))
+          "with-gc-lock: wrong interrupt mask")
+  (if enable-smp?
+      (if ((ucode-primitive smp-gc-lock 0))
+         (let ((value (thunk)))
+           ((ucode-primitive smp-gc-unlock 0))
+           value)
+         (begin
+           ((ucode-primitive smp-gc-wait 0))
+           (let ((space ((ucode-primitive gc-space-status))))
+             (- (vector-ref space 14)    ;shared_heap_end
+                (vector-ref space 13)    ;shared_heap_free
+                ))))
+      (thunk)))
+
+(define (with-heap-lock thunk)
+  ;; Serialize other access (besides GC) to the heap.
+  ;; If this processor loses the race to lock the heap, wait and then
+  ;; try again.
+  (with-absolutely-no-interrupts
+   (lambda ()
+     (if enable-smp?
+        (let retry ()
+          (if ((ucode-primitive smp-gc-lock 0))
+              (let ((value (thunk)))
+                ((ucode-primitive smp-gc-unlock 0))
+                value)
+              (begin
+                ((ucode-primitive smp-gc-wait 0))
+                (retry))))
+        (thunk)))))
+
 (define (threads-list)
   (with-thread-lock
    (lambda ()