From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Mon, 6 Jul 2015 01:25:35 +0000 (-0700)
Subject: Remove without-interrupts from runtime/global.scm.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6e809a7dba54ee4a9d81d20b3e044bfaff543f7e;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-system-obarray-lock, that
uses new primitives to participate in the serialization.

Remove limit-interrupts!.  Like without-interrupts, it will not work
as expected in SMPing worlds.
---

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 5790243a0..98435c327 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -125,9 +125,6 @@ USA.
 (define-integrable (system-hunk3-cons type cxr0 cxr1 cxr2)
   (object-new-type type (hunk3-cons cxr0 cxr1 cxr2)))
 
-(define (limit-interrupts! limit-mask)
-  (set-interrupt-enables! (fix:and limit-mask (get-interrupt-enables))))
-
 (define-integrable (object-component-binder get-component set-component!)
   (lambda (object value thunk)
     (define (swap!)
@@ -314,7 +311,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 +342,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 aa48c9e9b..4f7c9fd49 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -458,7 +458,6 @@ USA.
 	  lexical-unassigned?
 	  lexical-unbound?
 	  lexical-unreferenceable?
-	  limit-interrupts!
 	  link-variables
 	  local-assignment
 	  make-cell
@@ -523,6 +522,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 d39b2b582..000ae1888 100644
--- a/src/runtime/thread.scm
+++ b/src/runtime/thread.scm
@@ -31,6 +31,21 @@ USA.
 
 ;;; This allows a host without the SMP primitives to avoid calling them.
 (define enable-smp? #f)
+
+(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?
+      (if ((ucode-primitive smp-lock-obarray 1) #t)
+	  (let ((value (thunk)))
+	    (if ((ucode-primitive smp-lock-obarray 1) #f)
+		value
+		(begin
+		  (outf-error ";with-obarray-lock: unlock failed\n")
+		  #f)))
+	  (begin
+	    (outf-error ";with-obarray-lock: lock failed\n")))
+      (without-interrupts thunk)))
 
 (define-structure (thread
 		   (constructor %make-thread ())
diff --git a/src/runtime/wind.scm b/src/runtime/wind.scm
index 5134b673f..9d5a6b40e 100644
--- a/src/runtime/wind.scm
+++ b/src/runtime/wind.scm
@@ -155,7 +155,9 @@ USA.
 
 (define (state-point/space point)
   (guarantee-state-point point 'STATE-POINT/SPACE)
-  (let ((interrupt-mask (limit-interrupts! interrupt-mask/gc-ok)))
+  (let ((interrupt-mask
+	 (set-interrupt-enables! (fix:and (get-interrupt-enables)
+					  interrupt-mask/gc-ok))))
     (let loop ((point point))
       (let ((nearer-point (state-point/nearer-point point)))
 	(if nearer-point
@@ -192,7 +194,9 @@ USA.
   (local #f read-only #t))
 
 (define (get-dynamic-state)
-  (let ((interrupt-mask (limit-interrupts! interrupt-mask/gc-ok)))
+  (let ((interrupt-mask
+	 (set-interrupt-enables! (fix:and (get-interrupt-enables)
+					  interrupt-mask/gc-ok))))
     (let ((state
 	   (make-dynamic-state
 	    (state-space/nearest-point state-space:global)