smp: share: primutl.o

diff --git a/README.txt b/README.txt
index fdbb6438ff4b603ca3f5fcc15d6c75efde5c3bce..c85454abad0d8a2f6cc36f5d8fdfb79ea8f07957 100644 (file)
--- a/README.txt
+++ b/README.txt
@@ -434,17 +434,21 @@ command line.  The remaining 12 belong to the 7 microcode modules and
   prim.o:
 
   primutl.o:
-  00000000 B MAX_PRIMITIVE
-  00000008 B Primitive_Arity_Table
-  0000000c B Primitive_Count_Table
-  00000014 B Primitive_Documentation_Table
-  00000010 B Primitive_Name_Table
-  00000004 B Primitive_Procedure_Table
-  00000018 B load_renumber_table
-  00000088 d null_string.6141
-  00000020 b prim_procedure_tree
-  0000001c b prim_table_size
-  00000000 d primitive_aliases
+  00000000 B MAX_PRIMITIVE             locked
+  00000008 B Primitive_Arity_Table     locked
+  0000000c B Primitive_Count_Table     locked
+  00000014 B Primitive_Documentation_Table     locked
+  00000010 B Primitive_Name_Table      locked
+  00000004 B Primitive_Procedure_Table locked
+  00000018 B load_renumber_table       used nowhere!
+  00000088 d null_string.6141          read-only
+  00000020 b prim_procedure_tree       locked
+  0000001c b prim_table_size           locked
+  00000000 d primitive_aliases         read-only
+
+       OK.  Most of these are modified, after initialization, by
+       declare_primitive_internal or find_primitive_cname.  Serialize
+       the former and eliminate the hackery in the latter.
 
   ptrvec.o:
 

diff --git a/src/microcode/primutl.c b/src/microcode/primutl.c
index c2557313ceeef155b3825c426306fb5c1b0b0d12..0192c57d3e57f51233e26dfcc0bf1c63b60e3734 100644 (file)
--- a/src/microcode/primutl.c
+++ b/src/microcode/primutl.c
@@ -33,7 +33,6 @@ USA.
  * duration of a single Scheme session.
  */
 
-#include "scheme.h"
 #include "prims.h"
 #include "os.h"
 #include "usrdef.h"
@@ -43,6 +42,13 @@ USA.
 #include "cmpgc.h"
 #include <ctype.h>
 
+#ifdef ENABLE_SMP
+static pthread_mutex_t mutex = MUTEX_INITIALIZER;
+#  ifdef ENABLE_DEBUGGING_TOOLS
+static bool locked_p = false;
+#  endif
+#endif
+
 #ifndef UPDATE_PRIMITIVE_TABLE_HOOK
 #  define UPDATE_PRIMITIVE_TABLE_HOOK(low, high) do { } while (0)
 #endif
@@ -138,6 +144,9 @@ static void
 grow_primitive_tables (void)
 {
   unsigned long new_size = (MAX_PRIMITIVE + (MAX_PRIMITIVE / 10));
+#if defined(ENABLE_SMP) && defined(ENABLE_DEBUGGING_TOOLS)
+  assert (locked_p == true);
+#endif
   COPY_TABLE (Primitive_Arity_Table, Static_Primitive_Arity_Table, int, int);
   COPY_TABLE (Primitive_Count_Table, Static_Primitive_Count_Table, int, int);
   COPY_TABLE (Primitive_Name_Table,
@@ -166,7 +175,14 @@ initialize_primitives (void)
   /* MAX_STATIC_PRIMITIVE is the index of the last primitive */
 
   MAX_PRIMITIVE = (MAX_STATIC_PRIMITIVE + 1);
+#if defined(ENABLE_SMP) && defined(ENABLE_DEBUGGING_TOOLS)
+  /* Avoid annoying the assert. */
+  locked_p = true;
   grow_primitive_tables ();
+  locked_p = false;
+#else
+  grow_primitive_tables ();
+#endif
 
   tree_error_message = ((char *) NULL);
   prim_procedure_tree = (tree_build (MAX_PRIMITIVE, Primitive_Name_Table, 0));
@@ -224,7 +240,10 @@ declare_primitive_internal (bool override_p,
   unsigned long index;
   SCHEME_OBJECT primitive;
   const char * ndocstr = docstr;
-  tree_node prim = (tree_lookup (prim_procedure_tree, name));
+  tree_node prim;
+
+  LOCK();
+  prim = (tree_lookup (prim_procedure_tree, name));
 
   if (prim != ((tree_node) NULL))
   {
@@ -233,7 +252,10 @@ declare_primitive_internal (bool override_p,
     if ((((PRIMITIVE_ARITY (primitive)) != nargs_hi)
         && ((PRIMITIVE_ARITY (primitive)) != UNKNOWN_PRIMITIVE_ARITY))
        || ((IMPLEMENTED_PRIMITIVE_P (primitive)) && (! override_p)))
-      return (LONG_TO_UNSIGNED_FIXNUM (PRIMITIVE_NUMBER (primitive)));
+      {
+       UNLOCK();
+       return (LONG_TO_UNSIGNED_FIXNUM (PRIMITIVE_NUMBER (primitive)));
+      }
     if (docstr == 0)
       ndocstr = (Primitive_Documentation_Table[index]);
   }
@@ -250,6 +272,7 @@ declare_primitive_internal (bool override_p,
     {
       outf_error (tree_error_message, tree_error_noise);
       tree_error_message = ((char *) NULL);
+      UNLOCK();
       return (SHARP_F);
     }
     prim_procedure_tree = prim;
@@ -264,6 +287,7 @@ declare_primitive_internal (bool override_p,
   Primitive_Count_Table[index]         = (nargs_hi * (sizeof (SCHEME_OBJECT)));
   Primitive_Documentation_Table[index] = ndocstr;
   UPDATE_PRIMITIVE_TABLE_HOOK (index, (index + 1));
+  UNLOCK();
   return (primitive);
 }
 \f
@@ -344,13 +368,6 @@ find_primitive_cname (const char * name, bool intern_p, bool allow_p, int arity)
          || (arity == (PRIMITIVE_ARITY (primitive))))
        return (primitive);
 
-      if ((PRIMITIVE_ARITY (primitive)) == UNKNOWN_PRIMITIVE_ARITY)
-       {
-         /* We've just learned the arity of the primitive. */
-         (Primitive_Arity_Table[PRIMITIVE_NUMBER (primitive)]) = arity;
-         return (primitive);
-       }
-
       /* Arity mismatch, notify the runtime system. */
       return (LONG_TO_FIXNUM (PRIMITIVE_ARITY (primitive)));
     }