From b67eb6dd1147b6c667a7e3e96507d2c9d62accf1 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Tue, 18 Aug 2015 09:21:26 -0700
Subject: [PATCH] Synchronize processors for GC, purify and fasdump.

---
 src/runtime/gc.scm      | 14 +++++++++-----
 src/runtime/global.scm  |  6 ++++--
 src/runtime/intrpt.scm  |  9 +++++++++
 src/runtime/runtime.pkg |  6 ++++++
 src/runtime/thread.scm  | 36 ++++++++++++++++++++++++++++++++++++
 5 files changed, 64 insertions(+), 7 deletions(-)

diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index b050e9f6b..598852673 100644
--- a/src/runtime/gc.scm
+++ b/src/runtime/gc.scm
@@ -68,10 +68,12 @@ USA.
 (define default-safety-margin)
 
 (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 02dae7738..63679cad1 100644
--- 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 0c197aeb9..5a8c4d681 100644
--- 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 551234d94..4f98c6bf5 100644
--- 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 f59d57086..87ccd2aab 100644
--- 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 ()
-- 
2.25.1