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 5790243a07f2a2039f4c747af604db3de25cdcdd..98435c3279f6a7f7a65f108d861efd72551ac2c1 100644 (file)
--- 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))
 \f
 (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 aa48c9e9b80407127d400c343741662832707290..4f7c9fd4932a51a150edb9351f705fa618ec97bf 100644 (file)
--- 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 d39b2b582f6712968216fcc0f13083ce05be35ba..000ae1888406dee3971dc018ba8d63138873fe0e 100644 (file)
--- 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)))
 \f
 (define-structure (thread
                   (constructor %make-thread ())

diff --git a/src/runtime/wind.scm b/src/runtime/wind.scm
index 5134b673f28246f40d4c4b23e4e66bba50127e11..9d5a6b40e693bcd11324f9adc341ac8914f0ef76 100644 (file)
--- 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)