smp: without-interrupts: global.scm

diff --git a/README.txt b/README.txt
index d3765925608c566b89191c6844c52b0e7fb071a5..c987ab4ede941790ff25ab1e5d6d493a82d23285 100644 (file)
--- a/README.txt
+++ b/README.txt
@@ -1146,9 +1146,29 @@ The hits with accompanying analysis:
        is now provided via a thread-mutex.
 
   global.scm:36:  get-interrupt-enables set-interrupt-enables! with-interrupt-mask
+       Definitions.
   global.scm:129:  (set-interrupt-enables! (fix:and limit-mask (get-interrupt-enables))))
+       Caller: limit-interrupts!
+                 No callers, but exported to ().
   global.scm:234:  (with-absolutely-no-interrupts (ucode-primitive halt))
+       Caller: %quit
   global.scm:346:  (without-interrupts
+       Caller: clean-obarray
+
+       OK.  Callers of limit-interrupts! should be warned in the
+       Release Notes?  Why does %quit use with-absolutely-no-
+       interrupts?
+
+       The big problem was clean-obarray.  It runs as a
+       secondary-gc-daemon (running in parallel with other
+       processors), and was using without-interrupts to ensure sole
+       access to the obarray.
+
+       A number of primitives and compiler utilities modify the
+       obarray so a pthread mutex was introduced to serialize access
+       to it (conservatively, without much study of its modifier
+       procedures).  Clean-obarray serializes with these C functions
+       using the new smp-lock-obarray primitive.
 
   hash.scm:168:    (with-absolutely-no-interrupts
   hash.scm:213:    (with-absolutely-no-interrupts

diff --git a/src/microcode/intern.c b/src/microcode/intern.c
index af6760715eb928f51b10bdbfd6d511673180d437..e1c7b3545fda4b8ebd769c8e1e13d32dbb3c5065 100644 (file)
--- a/src/microcode/intern.c
+++ b/src/microcode/intern.c
@@ -26,9 +26,16 @@ USA.
 
 /* String hash functions and interning of symbols. */
 
-#include "scheme.h"
 #include "prims.h"
+#include "ossmp.h"
 #include "trap.h"
+
+#ifdef ENABLE_SMP
+static pthread_mutex_t mutex = MUTEX_INITIALIZER;
+#  ifdef ENABLE_DEBUGGING_TOOLS
+static bool locked_p = false;
+#  endif
+#endif
 \f
 /* The FNV hash, short for Fowler/Noll/Vo in honor of its creators.  */
 
@@ -123,17 +130,21 @@ replace_symbol_bucket_type (SCHEME_OBJECT symbol, unsigned int type)
 void
 strengthen_symbol (SCHEME_OBJECT symbol)
 {
+  LOCK();
   replace_symbol_bucket_type (symbol, TC_LIST);
+  UNLOCK();
 }
 
 void
 weaken_symbol (SCHEME_OBJECT symbol)
 {
+  LOCK();
   replace_symbol_bucket_type (symbol, TC_WEAK_CONS);
+  UNLOCK();
 }
 
 static SCHEME_OBJECT
-make_symbol (SCHEME_OBJECT string, SCHEME_OBJECT * cell)
+make_symbol_entry (SCHEME_OBJECT string)
 {
   Primitive_GC_If_Needed (4);
   {
@@ -141,26 +152,47 @@ make_symbol (SCHEME_OBJECT string, SCHEME_OBJECT * cell)
     Free += 2;
     MEMORY_SET (symbol, SYMBOL_NAME, string);
     MEMORY_SET (symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
-    (*cell) = (system_pair_cons (TC_WEAK_CONS, symbol, EMPTY_LIST));
-    return (symbol);
+    return (system_pair_cons (TC_WEAK_CONS, symbol, EMPTY_LIST));
   }
 }
 
 SCHEME_OBJECT
 find_symbol (unsigned long length, const char * string)
 {
-  SCHEME_OBJECT * cell = (find_symbol_internal (length, string));
-  return ((INTERNED_SYMBOL_P (*cell)) ? (*cell) : SHARP_F);
+  SCHEME_OBJECT * cell, result;
+  LOCK();
+  cell = (find_symbol_internal (length, string));
+  result = ((INTERNED_SYMBOL_P (*cell)) ? (*cell) : SHARP_F);
+  UNLOCK();
+  return (result);
 }
 \f
 SCHEME_OBJECT
 memory_to_symbol (unsigned long length, const void * string)
 {
-  SCHEME_OBJECT * cell = (find_symbol_internal (length, string));
-  return
-    ((INTERNED_SYMBOL_P (*cell))
-     ? (*cell)
-     : (make_symbol ((memory_to_string (length, string)), cell)));
+  SCHEME_OBJECT * cell, result;
+  LOCK();
+  cell = (find_symbol_internal (length, string));
+  if (INTERNED_SYMBOL_P (*cell))
+    result = (*cell);
+  else
+    {
+      SCHEME_OBJECT entry;
+      UNLOCK();
+      /* May abort for GC. */
+      entry = (make_symbol_entry (memory_to_string (length, string)));
+      LOCK();
+      cell = (find_symbol_internal (length, string));
+      if (INTERNED_SYMBOL_P (*cell))
+       result = (*cell);
+      else
+       {
+         (*cell) = entry;
+         result = PAIR_CAR (entry);
+       }
+    }
+  UNLOCK();
+  return (result);
 }
 
 SCHEME_OBJECT
@@ -172,29 +204,60 @@ char_pointer_to_symbol (const char * string)
 SCHEME_OBJECT
 string_to_symbol (SCHEME_OBJECT string)
 {
-  SCHEME_OBJECT * cell
-    = (find_symbol_internal ((STRING_LENGTH (string)),
-                            (STRING_POINTER (string))));
-  return ((INTERNED_SYMBOL_P (*cell))
-         ? (*cell)
-         : (make_symbol (string, cell)));
+  unsigned long length = (STRING_LENGTH (string));
+  const char * chars = (STRING_POINTER (string));
+  SCHEME_OBJECT * cell, result;
+  LOCK();
+  cell = (find_symbol_internal (length, chars));
+  if (INTERNED_SYMBOL_P (*cell))
+    result = (*cell);
+  else
+    {
+      SCHEME_OBJECT entry;
+      UNLOCK();
+      /* May abort for GC. */
+      entry = (make_symbol_entry (string));
+      LOCK();
+      cell = (find_symbol_internal (length, chars));
+      if (INTERNED_SYMBOL_P (*cell))
+       result = (*cell);
+      else
+       {
+         (*cell) = entry;
+         result = PAIR_CAR (entry);
+       }
+    }
+  UNLOCK();
+  return (result);
 }
 
 SCHEME_OBJECT
 intern_symbol (SCHEME_OBJECT symbol)
 {
-  SCHEME_OBJECT name = (MEMORY_REF (symbol, SYMBOL_NAME));
-  SCHEME_OBJECT * cell
-    = (find_symbol_internal ((STRING_LENGTH (name)),
-                            (STRING_POINTER (name))));
+  SCHEME_OBJECT string = (MEMORY_REF (symbol, SYMBOL_NAME));
+  unsigned long length = (STRING_LENGTH (string));
+  const char * chars = (STRING_POINTER (string));
+  SCHEME_OBJECT * cell, result;
+  LOCK();
+  cell = (find_symbol_internal (length, chars));
   if (INTERNED_SYMBOL_P (*cell))
-    return (*cell);
+    result = (*cell);
   else
     {
-      SCHEME_OBJECT result = (OBJECT_NEW_TYPE (TC_INTERNED_SYMBOL, symbol));
-      (*cell) = (system_pair_cons (TC_WEAK_CONS, result, EMPTY_LIST));
-      return (result);
+      SCHEME_OBJECT entry;
+      UNLOCK();
+      /* May abort for GC. */
+      result = (OBJECT_NEW_TYPE (TC_INTERNED_SYMBOL, symbol));
+      entry = (system_pair_cons (TC_WEAK_CONS, result, EMPTY_LIST));
+      LOCK();
+      cell = (find_symbol_internal (length, chars));
+      if (INTERNED_SYMBOL_P (*cell))
+       result = (*cell);
+      else
+       (*cell) = entry;
     }
+  UNLOCK();
+  return (result);
 }
 
 const char *
@@ -265,3 +328,20 @@ Equivalent to (MODULO (STRING-HASH STRING) DENOMINATOR).")
                        % (arg_ulong_integer (2))));
   }
 }
+
+DEFINE_PRIMITIVE ("SMP-LOCK-OBARRAY", Prim_smp_lock_obarray, 1, 1,
+                 "(SMP-LOCK-OBARRAY LOCK?)\n\
+When LOCK? is #F/non-#F, unlock/lock the pthread mutex serializing\n\
+accesses to the obarray.")
+{
+  PRIMITIVE_HEADER (1);
+  {
+#ifdef ENABLE_SMP
+    if (ARG_REF (1) != SHARP_F)
+       LOCK();
+    else
+       UNLOCK();
+#endif
+  }
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 5a4823df8c044ba0d23db89ba3583cc76f5c5634..23b3588c54794d202eea9204b956784ac00fafd6 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -313,8 +313,19 @@ USA.
 (define unspecific
   (object-new-type (ucode-type constant) 1))
 \f
+(define-integrable (with-system-obarray-locked thunk)
+  (if enable-smp?
+      (begin
+       ((ucode-primitive smp-lock-obarray 1) #t)
+       (let ((value (thunk)))
+         ((ucode-primitive smp-lock-obarray 1) #f)
+         value))
+      (thunk)))
+
 (define (for-each-interned-symbol procedure)
-  (for-each-symbol-in-obarray (fixed-objects-item 'OBARRAY) procedure))
+  (with-system-obarray-locked
+    (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 +354,7 @@ USA.
     list))
 
 (define (clean-obarray)
-  (without-interrupts
+  (with-system-obarray-locked
    (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 d94c1683fc8802728bd17cd642ed5dd4ddee013b..252f7eb2f4a2f8d320c58cf98a8040c084a8aba0 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -412,6 +412,8 @@ USA.
 (define-package (runtime miscellaneous-global)
   (files "global")
   (parent (runtime))
+  (import (runtime thread)
+         enable-smp?)
   (export ()
          %exit
          %quit