Make intern.o state single-threaded.

Serialize operations on the obarray using a pthread mutex.  Drop the
mutex while consing the symbol's entry.

diff --git a/src/microcode/intern.c b/src/microcode/intern.c
index a4808a0355878ac574fdc7480e9a0cd8a9817a34..37ee373433cc6b5ce80c70e27be85ba0a00454ef 100644 (file)
--- a/src/microcode/intern.c
+++ b/src/microcode/intern.c
@@ -26,9 +26,15 @@ USA.
 
 /* String hash functions and interning of symbols. */
 
-#include "scheme.h"
 #include "prims.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 +129,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 +151,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 +203,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 *
@@ -272,5 +334,13 @@ When LOCK? is #F/non-#F, unlock/lock the pthread mutex serializing\n\
 access to the obarray.  Value is #T unless there was an error.")
 {
   PRIMITIVE_HEADER (1);
+  {
+#ifdef ENABLE_SMP
+    if (ARG_REF (1) != SHARP_F)
+       LOCK();
+    else
+       UNLOCK();
+#endif
+  }
   PRIMITIVE_RETURN (SHARP_T);
 }