From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 11 Jul 2015 19:31:03 +0000 (-0700)
Subject: Synchronize processors for GC, purify and fasdump.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=57fb39cb20bee97d82efe270a3dfc0aeadf1f730;p=mit-scheme.git

Synchronize processors for GC, purify and fasdump.
---

diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index 1084fc5b5..a2e31b46e 100644
--- 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 9fa64956e..7690cd765 100644
--- 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 c32f8bff1..1fd45dd93 100644
--- 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 4bb1457d9..f54e097e9 100644
--- 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 1dc711187..91ac09d5a 100644
--- 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)))