From bf81271ed54bd304403bc9c903565f4be44334fd Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 20 Dec 2014 12:15:31 -0700
Subject: [PATCH] smp: share: primutl.o

---
 README.txt              | 26 +++++++++++++++-----------
 src/microcode/primutl.c | 37 +++++++++++++++++++++++++++----------
 2 files changed, 42 insertions(+), 21 deletions(-)

diff --git a/README.txt b/README.txt
index fdbb6438f..c85454aba 100644
--- 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 c2557313c..0192c57d3 100644
--- 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);
 }
 
@@ -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)));
     }
-- 
2.25.1