emacs-27 cdc632f: Fix incorrect handling of module runtime and environment pointers.

[Philipp Stephani]

branch: emacs-27
commit cdc632fbe6e149318147a98cccf1b7af191f2ce8
Author: Philipp Stephani <phst@google.com>
Commit: Philipp Stephani <phst@google.com>

    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.
---
 src/emacs-module.c                | 131 +++++++++++++++++++++++++++++++-------
 test/data/emacs-module/mod-test.c |  10 +++
 test/src/emacs-module-tests.el    |  50 +++++++++++++++
 3 files changed, 169 insertions(+), 22 deletions(-)

diff --git a/src/emacs-module.c b/src/emacs-module.c
index a90a976..89d9683 100644
--- 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;
 
@@ -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)
@@ -1210,6 +1215,83 @@ module_out_of_memory (emacs_env *env)
 }
 
 
+/* 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);
+}
+
+
 /* Value conversion.  */
 
 /* Convert an `emacs_value' to the corresponding internal object.
@@ -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);
+        }
 }
 
 
@@ -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);
 }
 
 
@@ -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 8d1b421..528b4b4 100644
--- 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 9df0b25..f9bd82e 100644
--- 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