From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Mon, 13 Jul 2015 00:23:52 +0000 (-0700)
Subject: Remove without-interrupts from runtime/global.scm.
X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~41
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ee83b3ff5b398b471f57174b6f57bd4a01fb350;p=mit-scheme.git

Remove without-interrupts from runtime/global.scm.

Clean-obarray runs as a secondary-gc-deamon and thus, in SMPing
worlds, it may run in parallel with other threads on other processors.

A number of primitives and compiler utilities modify the obarray so an
SMPing microcode will use a pthread mutex to serialize access to it.
Clean-obarray now uses a new procedure, with-obarray-lock, that uses
new primitives to participate in the serialization.
---

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 5790243a0..e6e79b097 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -314,7 +314,9 @@ USA.
   (object-new-type (ucode-type constant) 1))
 
 (define (for-each-interned-symbol procedure)
-  (for-each-symbol-in-obarray (fixed-objects-item 'OBARRAY) procedure))
+  (with-obarray-lock
+    (lambda ()
+      (for-each-symbol-in-obarray (fixed-objects-item 'OBARRAY) procedure))))
 
 (define (for-each-symbol-in-obarray obarray procedure)
   (let per-bucket ((index (vector-length obarray)))
@@ -343,7 +345,7 @@ USA.
     list))
 
 (define (clean-obarray)
-  (without-interrupts
+  (with-obarray-lock
    (lambda ()
      (let ((obarray (fixed-objects-item 'OBARRAY)))
        (let loop ((index (vector-length obarray)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 3f9435b94..6bd86cd68 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -543,6 +543,8 @@ USA.
 	  with-interrupt-mask
 	  with-values
 	  write-to-string)
+  (import (runtime thread)
+	  with-obarray-lock)
   (initialization (initialize-package!)))
 
 (define-package (runtime alternative-lambda)
diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm
index 370b91357..6074bbb48 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -180,6 +180,23 @@ USA.
       (set-thread/execution-state! thread state)
       value)))
 
+(define (with-obarray-lock thunk)
+  ;; Serialize with myriad parts of the microcode that hack the
+  ;; obarray element of the fixed-objects vector.
+  (if enable-smp?
+      (without-preemption
+       (lambda ()
+	 (if (not (eq? #t ((ucode-primitive smp-lock-obarray 1) #t)))
+	     (outf-error "\nwith-obarray-lock: lock failed\n"))
+	 (let ((value (thunk)))
+	   (if (not (eq? #t ((ucode-primitive smp-lock-obarray 1) #f)))
+	       (outf-error "\nwith-obarray-lock: unlock failed\n"))
+	   value)))
+      (let* ((mask (set-interrupt-enables! interrupt-mask/gc-ok))
+	     (value (thunk)))
+	(set-interrupt-enables! mask)
+	value)))
+
 (define (threads-list)
   (map-over-population thread-population (lambda (thread) thread)))