Fix incorrect handling of module runtime and environment pointers.

We used to store module runtime and environment pointers in the static
lists Vmodule_runtimes and Vmodule_environments.  However, this is
incorrect because these objects have to be kept per-thread.  With this
naive approach, interleaving module function calls in separate threads
leads to environments being removed in the wrong order, which in turn
can cause local module values to be incorrectly garbage-collected.

Instead, turn Vmodule_runtimes and Vmodule_environments into
hashtables keyed by the thread objects.  The fix is relatively
localized and should therefore be safe enough for the release branch.

Module assertions now have to walk the pointer list for the current
thread, which is more correct since they now only find environments
for the current thread.

Also add a unit test that exemplifies the problem.  It interleaves two
module calls in two threads so that the first call ends while the
second one is still active.  Without this change, this test triggers
an assertion failure.

* src/emacs-module.c (Fmodule_load, initialize_environment)
(finalize_environment, finalize_runtime_unwind): Store runtime and
environment pointers in per-thread lists.
(syms_of_module): Initialize runtimes and environments hashtables.
(module_assert_runtime, module_assert_env, value_to_lisp): Consider
only objects for the current thread.
(module_gc_hash_table_size, module_hash_push, module_hash_pop): New
generic hashtable helper functions.
(module_objects, module_push_pointer, module_pop_pointer): New helper
functions to main thread-specific lists of runtime and environment
pointers.
(mark_modules): Mark all environments in all threads.

* test/data/emacs-module/mod-test.c (Fmod_test_funcall): New test
function.
(emacs_module_init): Bind it.

* test/src/emacs-module-tests.el (emacs-module-tests--variable): New
helper type to guard access to state in a thread-safe way.
(emacs-module-tests--wait-for-variable)
(emacs-module-tests--change-variable): New helper functions.
(emacs-module-tests/interleaved-threads): New unit test.

diff --git a/src/emacs-module.c b/src/emacs-module.c
index a90a9765dbf69928f4316b5f27e0b8ad957f5c29..89d96839d2fb5ce2957ae34153cc425e3b03faae 100644 (file)
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -217,6 +217,9 @@ static void module_out_of_memory (emacs_env *);
 static void module_reset_handlerlist (struct handler **);
 static bool value_storage_contains_p (const struct emacs_value_storage *,
                                       emacs_value, ptrdiff_t *);
+static Lisp_Object module_objects (Lisp_Object);
+static void module_push_pointer (Lisp_Object, void *);
+static void module_pop_pointer (Lisp_Object, void *);
 
 static bool module_assertions = false;
 \f
@@ -1005,7 +1008,8 @@ module_signal_or_throw (struct emacs_env_private *env)
     }
 }
 
-/* Live runtime and environment objects, for assertions.  */
+/* Live runtime and environment objects, for assertions.  These are hashtables
+   keyed by the thread objects.  */
 static Lisp_Object Vmodule_runtimes;
 static Lisp_Object Vmodule_environments;
 
@@ -1046,7 +1050,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
   rt->private_members = &rt_priv;
   rt->get_environment = module_get_environment;
 
-  Vmodule_runtimes = Fcons (make_mint_ptr (rt), Vmodule_runtimes);
+  module_push_pointer (Vmodule_runtimes, rt);
   ptrdiff_t count = SPECPDL_INDEX ();
   record_unwind_protect_ptr (finalize_runtime_unwind, rt);
 
@@ -1146,7 +1150,8 @@ module_assert_runtime (struct emacs_runtime *ert)
   if (! module_assertions)
     return;
   ptrdiff_t count = 0;
-  for (Lisp_Object tail = Vmodule_runtimes; CONSP (tail); tail = XCDR (tail))
+  for (Lisp_Object tail = module_objects (Vmodule_runtimes); CONSP (tail);
+       tail = XCDR (tail))
     {
       if (xmint_pointer (XCAR (tail)) == ert)
         return;
@@ -1162,7 +1167,7 @@ module_assert_env (emacs_env *env)
   if (! module_assertions)
     return;
   ptrdiff_t count = 0;
-  for (Lisp_Object tail = Vmodule_environments; CONSP (tail);
+  for (Lisp_Object tail = module_objects (Vmodule_environments); CONSP (tail);
        tail = XCDR (tail))
     {
       if (xmint_pointer (XCAR (tail)) == env)
@@ -1209,6 +1214,83 @@ module_out_of_memory (emacs_env *env)
                                  XCDR (Vmemory_signal_data));
 }
 
+\f
+/* Hash table helper functions.  */
+
+/* Like HASH_TABLE_SIZE, but also works during garbage collection.  */
+
+static ptrdiff_t
+module_gc_hash_table_size (const struct Lisp_Hash_Table *h)
+{
+  ptrdiff_t size = gc_asize (h->next);
+  eassert (0 <= size);
+  return size;
+}
+
+/* Like (push NEWELT (gethash KEY TABLE)).  */
+
+static void
+module_hash_push (Lisp_Object table, Lisp_Object key, Lisp_Object newelt)
+{
+  /* Inline calls to Fgethash/Fputhash to avoid duplicate hash lookup.  */
+  struct Lisp_Hash_Table *h = XHASH_TABLE (table);
+  Lisp_Object hash;
+  ptrdiff_t i = hash_lookup (h, key, &hash);
+  if (i >= 0)
+    set_hash_value_slot (h, i, Fcons (newelt, HASH_VALUE (h, i)));
+  else
+    hash_put (h, key, list1 (newelt), hash);
+}
+
+/* Like (pop (gethash KEY TABLE)), but removes KEY from TABLE if the new value
+   is nil.  */
+
+static Lisp_Object
+module_hash_pop (Lisp_Object table, Lisp_Object key)
+{
+  /* Inline calls to Fgethash/Fputhash to avoid duplicate hash lookup.  */
+  struct Lisp_Hash_Table *h = XHASH_TABLE (table);
+  Lisp_Object hash;
+  ptrdiff_t i = hash_lookup (h, key, &hash);
+  eassert (i >= 0);
+  Lisp_Object value = HASH_VALUE (h, i);
+  Lisp_Object rest = XCDR (value);
+  if (NILP (rest))
+    hash_remove_from_table(h, key);
+  else
+    set_hash_value_slot (h, i, rest);
+  return XCAR (value);
+}
+
+/* Returns the list of objects for the current thread in TABLE.  The keys of
+   TABLE are thread objects.  */
+
+static Lisp_Object
+module_objects (Lisp_Object table)
+{
+ return Fgethash (Fcurrent_thread (), table, Qnil);
+}
+
+/* Adds PTR to the front of the list of objects for the current thread in TABLE.
+   The keys of TABLE are thread objects.  */
+
+static void
+module_push_pointer (Lisp_Object table, void *ptr)
+{
+  module_hash_push (table, Fcurrent_thread (), make_mint_ptr (ptr));
+}
+
+/* Removes the first object from the list of objects for the current thread in
+   TABLE.  The keys of TABLE are thread objects.  Checks that the first object
+   is a pointer with value PTR.  */
+
+static void
+module_pop_pointer (Lisp_Object table, void *ptr)
+{
+  Lisp_Object value = module_hash_pop (table, Fcurrent_thread ());
+  eassert (xmint_pointer (value) == ptr);
+}
+
 \f
 /* Value conversion.  */
 
@@ -1226,7 +1308,7 @@ value_to_lisp (emacs_value v)
          environments.  */
       ptrdiff_t num_environments = 0;
       ptrdiff_t num_values = 0;
-      for (Lisp_Object environments = Vmodule_environments;
+      for (Lisp_Object environments = module_objects (Vmodule_environments);
            CONSP (environments); environments = XCDR (environments))
         {
           emacs_env *env = xmint_pointer (XCAR (environments));
@@ -1326,16 +1408,19 @@ allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage,
 void
 mark_modules (void)
 {
-  for (Lisp_Object tem = Vmodule_environments; CONSP (tem); tem = XCDR (tem))
-    {
-      emacs_env *env = xmint_pointer (XCAR (tem));
-      struct emacs_env_private *priv = env->private_members;
-      for (struct emacs_value_frame *frame = &priv->storage.initial;
-          frame != NULL;
-          frame = frame->next)
-        for (int i = 0; i < frame->offset; ++i)
-          mark_object (frame->objects[i].v);
-    }
+  const struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_environments);
+  /* Can't use HASH_TABLE_SIZE because we are in the mark phase of the GC.  */
+  for (ptrdiff_t i = 0; i < module_gc_hash_table_size (h); ++i)
+    if (!EQ (HASH_KEY (h, i), Qunbound))
+      for (Lisp_Object tem = HASH_VALUE (h, i); CONSP (tem); tem = XCDR (tem))
+        {
+          emacs_env *env = xmint_pointer (XCAR (tem));
+          struct emacs_env_private *priv = env->private_members;
+          for (struct emacs_value_frame *frame = &priv->storage.initial;
+               frame != NULL; frame = frame->next)
+            for (int i = 0; i < frame->offset; ++i)
+              mark_object (frame->objects[i].v);
+        }
 }
 
 \f
@@ -1390,7 +1475,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv)
   env->make_time = module_make_time;
   env->extract_big_integer = module_extract_big_integer;
   env->make_big_integer = module_make_big_integer;
-  Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments);
+  module_push_pointer (Vmodule_environments, env);
   return env;
 }
 
@@ -1400,8 +1485,7 @@ static void
 finalize_environment (emacs_env *env)
 {
   finalize_storage (&env->private_members->storage);
-  eassert (xmint_pointer (XCAR (Vmodule_environments)) == env);
-  Vmodule_environments = XCDR (Vmodule_environments);
+  module_pop_pointer (Vmodule_environments, env);
 }
 
 static void
@@ -1414,9 +1498,8 @@ static void
 finalize_runtime_unwind (void *raw_ert)
 {
   struct emacs_runtime *ert = raw_ert;
-  eassert (xmint_pointer (XCAR (Vmodule_runtimes)) == ert);
-  Vmodule_runtimes = XCDR (Vmodule_runtimes);
   finalize_environment (ert->private_members->env);
+  module_pop_pointer (Vmodule_runtimes, ert);
 }
 
 \f
@@ -1506,10 +1589,14 @@ syms_of_module (void)
                       Qnil, false);
 
   staticpro (&Vmodule_runtimes);
-  Vmodule_runtimes = Qnil;
+  Vmodule_runtimes
+    = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE,
+                       DEFAULT_REHASH_THRESHOLD, Qnil, false);
 
   staticpro (&Vmodule_environments);
-  Vmodule_environments = Qnil;
+  Vmodule_environments
+    = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE, DEFAULT_REHASH_SIZE,
+                       DEFAULT_REHASH_THRESHOLD, Qnil, false);
 
   DEFSYM (Qmodule_load_failed, "module-load-failed");
   Fput (Qmodule_load_failed, Qerror_conditions,

diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c
index 8d1b421bb401da950f6953db0b2c7b1e43adbeb3..528b4b4c58232b730bf1adef320bae2f01a15a55 100644 (file)
--- a/test/data/emacs-module/mod-test.c
+++ b/test/data/emacs-module/mod-test.c
@@ -547,6 +547,14 @@ Fmod_test_double (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
   return result;
 }
 
+static emacs_value
+Fmod_test_funcall (emacs_env *env, ptrdiff_t nargs, emacs_value *args,
+                   void *data)
+{
+  assert (0 < nargs);
+  return env->funcall (env, args[0], nargs - 1, args + 1);
+}
+
 /* Lisp utilities for easier readability (simple wrappers).  */
 
 /* Provide FEATURE to Emacs.  */
@@ -629,6 +637,8 @@ emacs_module_init (struct emacs_runtime *ert)
   DEFUN ("mod-test-add-nanosecond", Fmod_test_add_nanosecond, 1, 1, NULL, NULL);
   DEFUN ("mod-test-nanoseconds", Fmod_test_nanoseconds, 1, 1, NULL, NULL);
   DEFUN ("mod-test-double", Fmod_test_double, 1, 1, NULL, NULL);
+  DEFUN ("mod-test-funcall", Fmod_test_funcall, 1, emacs_variadic_function,
+         NULL, NULL);
 
 #undef DEFUN
 

diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el
index 9df0b25a0c5fd19488856d57a94a2b1da7429fc8..f9bd82e78c613428ac6b897fef426d5293a91f1b 100644 (file)
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -419,4 +419,54 @@ Interactively, you can try hitting \\[keyboard-quit] to quit."
     (ert-info ((format "input: %d" input))
       (should (= (mod-test-double input) (* 2 input))))))
 
+(cl-defstruct (emacs-module-tests--variable
+               (:constructor nil)
+               (:constructor emacs-module-tests--make-variable
+                             (name
+                              &aux
+                              (mutex (make-mutex name))
+                              (condvar (make-condition-variable mutex name))))
+               (:copier nil))
+  "A variable that's protected by a mutex."
+  value
+  (mutex nil :read-only t :type mutex)
+  (condvar nil :read-only t :type condition-variable))
+
+(defun emacs-module-tests--wait-for-variable (variable desired)
+  (with-mutex (emacs-module-tests--variable-mutex variable)
+    (while (not (eq (emacs-module-tests--variable-value variable) desired))
+      (condition-wait (emacs-module-tests--variable-condvar variable)))))
+
+(defun emacs-module-tests--change-variable (variable new)
+  (with-mutex (emacs-module-tests--variable-mutex variable)
+    (setf (emacs-module-tests--variable-value variable) new)
+    (condition-notify (emacs-module-tests--variable-condvar variable) :all)))
+
+(ert-deftest emacs-module-tests/interleaved-threads ()
+  (let* ((state-1 (emacs-module-tests--make-variable "1"))
+         (state-2 (emacs-module-tests--make-variable "2"))
+         (thread-1
+          (make-thread
+           (lambda ()
+             (emacs-module-tests--change-variable state-1 'before-module)
+             (mod-test-funcall
+              (lambda ()
+                (emacs-module-tests--change-variable state-1 'in-module)
+                (emacs-module-tests--wait-for-variable state-2 'in-module)))
+             (emacs-module-tests--change-variable state-1 'after-module))
+           "thread 1"))
+         (thread-2
+          (make-thread
+           (lambda ()
+             (emacs-module-tests--change-variable state-2 'before-module)
+             (emacs-module-tests--wait-for-variable state-1 'in-module)
+             (mod-test-funcall
+              (lambda ()
+                (emacs-module-tests--change-variable state-2 'in-module)
+                (emacs-module-tests--wait-for-variable state-1 'after-module)))
+             (emacs-module-tests--change-variable state-2 'after-module))
+           "thread 2")))
+    (thread-join thread-1)
+    (thread-join thread-2)))
+
 ;;; emacs-module-tests.el ends here