Synchronize processors for GC, purify and fasdump.

diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index 1084fc5b59418967f95dd24dda9885fa9cf4147e..a2e31b46ecee8236d41564c8b03f74247afd77a1 100644 (file)
--- a/src/runtime/gc.scm
+++ b/src/runtime/gc.scm
@@ -82,7 +82,9 @@ USA.
            (lambda ()
              (set! constant-space-queue (cons item constant-space-queue))
              unspecific))
-         (purify-internal item default-safety-margin))))
+         (with-absolutely-no-interrupts
+          (lambda ()
+            (purify-internal item default-safety-margin))))))
 
 (define (default/stack-overflow)
   (abort->nearest "Aborting!: maximum recursion depth exceeded"))
@@ -97,17 +99,22 @@ USA.
 (define hook/gc-finish)
 
 (define (gc-flip-internal safety-margin)
-  (let ((start-value (hook/gc-start)))
-    (let ((space-remaining ((ucode-primitive garbage-collect) safety-margin)))
-      (gc-finish start-value space-remaining)
-      space-remaining)))
+  (with-gc-lock
+   (lambda ()
+     (let ((start-value (hook/gc-start)))
+       (let ((space-remaining
+             ((ucode-primitive garbage-collect) safety-margin)))
+        (gc-finish start-value space-remaining)
+        space-remaining)))))
 
 (define (purify-internal item safety-margin)
-  (let ((start-value (hook/gc-start)))
-    (let ((result
-          ((ucode-primitive primitive-purify) item #f safety-margin)))
-      (gc-finish start-value (cdr result))
-      (cdr result))))
+  (with-gc-lock
+   (lambda ()
+     (let ((start-value (hook/gc-start)))
+       (let ((result
+             ((ucode-primitive primitive-purify) item #f safety-margin)))
+        (gc-finish start-value (cdr result))
+        (cdr result))))))
 
 (define (default/gc-start)
   #f)

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 9fa64956e22ee2da3a5d38257aed78cc4595dfc1..7690cd7652f4826f8c102c73253ebe558dd7359a 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -385,8 +385,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 c32f8bff14d5246cf3c905a4063e2f241eda9eb8..1fd45dd93b73add915474aa5610048786d3d8832 100644 (file)
--- a/src/runtime/intrpt.scm
+++ b/src/runtime/intrpt.scm
@@ -114,6 +114,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)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 4bb1457d98a6547257b57b10e168644aff4701ea..f54e097e92adbd66101c05b297f4ad36c575905b 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -523,6 +523,7 @@ USA.
          with-values
          write-to-string)
   (import (runtime thread)
+         with-heap-lock
          with-obarray-lock)
   (initialization (initialize-package!)))
 
@@ -1971,6 +1972,8 @@ USA.
          hook/hardware-trap)
   (export (runtime thread)
          abort-if-heap-low)
+  (import (runtime thread)
+         with-gc-lock)
   (initialization (initialize-package!)))
 
 (define-package (runtime gc-daemons)

diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 1dc711187510203717c39546a8362aa6f2381286..91ac09d5add6f1a189d87910a0f5e8740fd7b47c 100644 (file)
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -87,6 +87,49 @@ USA.
        (set-interrupt-enables! mask)
        value)))
 
+(define (with-gc-lock thunk)
+  ;; Serialize processors for GC and purify.
+  (%assert (interrupt-mask-ok?) "with-gc-lock: wrong interrupt mask")
+  (if enable-smp?
+      (let ((result ((ucode-primitive smp-lock-heap 1) #t)))
+       (cond ((eq? #t result)
+              (let ((value (thunk)))
+                (if (not (eq? #t ((ucode-primitive smp-lock-heap 1) #f)))
+                    (%outf-error "with-gc-lock: unlock failed"))
+                value))
+             ((eq? #f result)
+              ((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
+                   )))
+             (else
+              (%assert #f "with-gc-lock: lock failed; GCing anyway...")
+              (thunk))))
+      (thunk)))
+
+(define (with-heap-lock thunk)
+  ;; Serialize other access (besides purify or GC) to the heap.
+  (let* ((mask (set-interrupt-enables! interrupt-mask/none))
+        (value
+         (if (not enable-smp?)
+             (thunk)
+             (let wait ()
+               (let ((result ((ucode-primitive smp-lock-heap 1) #t)))
+                 (cond
+                  ((eq? #t result)
+                   (let ((value (thunk)))
+                     (if (not (eq? #t ((ucode-primitive smp-lock-heap 1) #f)))
+                         (%assert #f "with-heap-lock: unlock failed"))
+                     value))
+                  ((eq? #f result)
+                   (wait))
+                  (else
+                   (%assert #f "with-heap-lock: lock failed")
+                   #f)))))))
+    (set-interrupt-enables! mask)
+    value))
+
 (define (without-preemption thunk)
   (let* ((thread (current-thread))
         (state (thread/execution-state thread)))