From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 6 Dec 2014 00:34:10 +0000 (-0700)
Subject: smp: share: string.o
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9088f507aeb1fc13116bea45f968a9d057a8600c;p=mit-scheme.git

smp: share: string.o
---

diff --git a/README.txt b/README.txt
index 842de1e32..7977e37a3 100644
--- a/README.txt
+++ b/README.txt
@@ -542,7 +542,10 @@ command line.  The remaining 12 belong to the 7 microcode modules and
 	Prim_primitive_purify.
 
   string.o:
-  00000000 b external_strings
+  00000000 b external_strings		locked
+
+	OK.  Serialized arg_extended_string and the primitives that
+	do not use it.
 
   syntax.o:
   00000080 D syntax_code_spec
diff --git a/src/microcode/string.c b/src/microcode/string.c
index 33d6ed45a..eaed42ae3 100644
--- a/src/microcode/string.c
+++ b/src/microcode/string.c
@@ -509,6 +509,13 @@ DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD-CI", Prim_match_backward_ci, 6, 6, 0
    registered in a hash table when it is allocated so that we can
    validate the incoming integers.  */
 
+#ifdef ENABLE_SMP
+static pthread_mutex_t mutex = MUTEX_INITIALIZER;
+#  ifdef ENABLE_DEBUGGING_TOOLS
+static bool locked_p = false;
+#  endif
+#endif
+
 typedef struct ht_record_s ht_record_t;
 struct ht_record_s
 {
@@ -553,12 +560,18 @@ DEFINE_PRIMITIVE ("ALLOCATE-EXTERNAL-STRING", Prim_alloc_external_string, 1, 1,
     ht_record_t * result = (malloc (n_bytes + 1 + (sizeof (ht_record_t))));
     if (result == 0)
       error_bad_range_arg (1);
-    if (external_strings == 0)
-      external_strings = (make_hash_table ());
     (HT_RECORD_N_BYTES (result)) = n_bytes;
     /* Guarantee zero termination in case used as C string.  */
     (((char *) (HT_RECORD_PTR (result))) [n_bytes]) = '\0';
-    PRIMITIVE_RETURN (ulong_to_integer (ht_insert (external_strings, result)));
+    {
+      ulong val;
+      LOCK();
+      if (external_strings == 0)
+	external_strings = (make_hash_table ());
+      val = ht_insert (external_strings, result);
+      UNLOCK();
+      PRIMITIVE_RETURN (ulong_to_integer (val));
+    }
   }
 }
 
@@ -570,9 +583,11 @@ DEFINE_PRIMITIVE ("EXTERNAL-STRING?", Prim_external_string_p, 1, 1, 0)
     if ((INTEGER_P (x)) && (integer_to_ulong_p (x)))
       {
 	ht_record_t * record;
+	LOCK();
 	if (external_strings == 0)
 	  external_strings = (make_hash_table ());
 	record = (ht_lookup (external_strings, (integer_to_ulong (x))));
+	UNLOCK();
 	PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (record != 0));
       }
     else
@@ -586,12 +601,17 @@ DEFINE_PRIMITIVE ("DEALLOCATE-EXTERNAL-STRING", Prim_dealloc_external_string, 1,
   {
     unsigned long n = (arg_ulong_integer (1));
     ht_record_t * record;
+    LOCK();
     if (external_strings == 0)
       external_strings = (make_hash_table ());
     record = (ht_delete (external_strings, n));
     if (record == 0)
-      error_wrong_type_arg (1);
+      {
+	UNLOCK();
+	error_wrong_type_arg (1);
+      }
     free (record);
+    UNLOCK();
     PRIMITIVE_RETURN (UNSPECIFIC);
   }
 }
@@ -610,13 +630,18 @@ unsigned char *
 lookup_external_string (SCHEME_OBJECT descriptor, unsigned long * lp)
 {
   ht_record_t * record;
+  LOCK();
   if (external_strings == 0)
     external_strings = (make_hash_table ());
   record = (ht_lookup (external_strings, (integer_to_ulong (descriptor))));
   if (record == 0)
-    return (0);
+    {
+      UNLOCK();
+      return (0);
+    }
   if (lp != 0)
     (*lp) = (HT_RECORD_N_BYTES (record));
+  UNLOCK();
   return (HT_RECORD_PTR (record));
 }