master 23974cf: Fix incorrect handling of module runtime and environment pointers.

[Philipp Stephani]

branch: master
commit 23974cfa48b9245658667eff81d132b3aecd2618
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.
    The fix isn't completely trivial: specbinding the lists wouldn't work
    either, because then the garbage collector wouldn't find the
    environments in other threads than the current ones, again leading to
    objects being garbage-collected incorrectly.  While introducing custom
    pseudovector types would fix this, it's simpler to put the runtime and
    environment pointers into the specbinding list as new specbinding
    kinds.  This works since we need to unwind them anyway, and we only
    ever treat the lists as a stack.  The thread switching machinery
    ensures that the specbinding lists are thread-local, and that all
    elements of the specbinding lists in all threads are marked during
    garbage collection.
    
    Module assertions now have to walk the specbinding list for the
    current thread, which is more correct since they now only find
    environments for the current thread.  As a result, we can now remove
    the faulty Vmodule_runtimes and Vmodule_environments variables
    entirely.
    
    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/lisp.h (enum specbind_tag): Add new tags for module runtimes and
    environments.
    
    * src/eval.c (record_unwind_protect_module): New function to record a
    module object in the specpdl list.
    (do_one_unbind): Unwind module objects.
    (backtrace_eval_unrewind, default_toplevel_binding, lexbound_p)
    (Fbacktrace__locals): Deal with new specbinding types.
    (mark_specpdl): Mark module environments as needed.
    
    * src/alloc.c (garbage_collect): Remove call to 'mark-modules'.
    Garbage collection of module values is now handled as part of marking
    the specpdl of each thread.
    
    * src/emacs-module.c (Fmodule_load, funcall_module): Use specpdl to
    record module runtimes and environments.
    (module_assert_runtime, module_assert_env, value_to_lisp): Walk
    through specpdl list instead of list variables.
    (mark_module_environment): Rename from 'mark_modules'.  Don't attempt
    to walk though current thread's environments only, since that would
    miss other threads.
    (initialize_environment, finalize_environment): Don't change
    Vmodule_environments variable; environments are now in the specpdl
    list.
    (finalize_environment_unwind, finalize_runtime_unwind): Make 'extern'
    since do_one_unbind now calls them.
    (finalize_runtime_unwind): Don't change Vmodule_runtimes variable;
    runtimes are now in the specpdl list.
    (syms_of_module): Remove Vmodule_runtimes and Vmodule_environments.
    
    * 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/alloc.c                                |   4 --
 src/emacs-module.c                         | 104 ++++++++++++-----------------
 src/eval.c                                 |  41 ++++++++++++
 src/lisp.h                                 |   9 ++-
 test/src/emacs-module-resources/mod-test.c |  10 +++
 test/src/emacs-module-tests.el             |  50 ++++++++++++++
 6 files changed, 151 insertions(+), 67 deletions(-)

diff --git a/src/alloc.c b/src/alloc.c
index 2b3643e..504ef17 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -6061,10 +6061,6 @@ garbage_collect (void)
   mark_fringe_data ();
 #endif
 
-#ifdef HAVE_MODULES
-  mark_modules ();
-#endif
-
   /* Everything is now marked, except for the data in font caches,
      undo lists, and finalizers.  The first two are compacted by
      removing an items which aren't reachable otherwise.  */
diff --git a/src/emacs-module.c b/src/emacs-module.c
index 23b8e86..5f97815 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -200,8 +200,6 @@ static AVOID module_abort (const char *, ...) 
ATTRIBUTE_FORMAT_PRINTF (1, 2);
 static emacs_env *initialize_environment (emacs_env *,
                                          struct emacs_env_private *);
 static void finalize_environment (emacs_env *);
-static void finalize_environment_unwind (void *);
-static void finalize_runtime_unwind (void *);
 static void module_handle_nonlocal_exit (emacs_env *, enum nonlocal_exit,
                                          Lisp_Object);
 static void module_non_local_exit_signal_1 (emacs_env *,
@@ -1089,10 +1087,6 @@ module_signal_or_throw (struct emacs_env_private *env)
     }
 }
 
-/* Live runtime and environment objects, for assertions.  */
-static Lisp_Object Vmodule_runtimes;
-static Lisp_Object Vmodule_environments;
-
 DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
        doc: /* Load module FILE.  */)
   (Lisp_Object file)
@@ -1137,9 +1131,9 @@ 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);
   ptrdiff_t count = SPECPDL_INDEX ();
-  record_unwind_protect_ptr (finalize_runtime_unwind, rt);
+  record_unwind_protect_module (SPECPDL_MODULE_RUNTIME, rt);
+  record_unwind_protect_module (SPECPDL_MODULE_ENVIRONMENT, rt_priv.env);
 
   int r = module_init (rt);
 
@@ -1167,7 +1161,7 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, 
Lisp_Object *arglist)
   struct emacs_env_private priv;
   emacs_env *env = initialize_environment (&pub, &priv);
   ptrdiff_t count = SPECPDL_INDEX ();
-  record_unwind_protect_ptr (finalize_environment_unwind, env);
+  record_unwind_protect_module (SPECPDL_MODULE_ENVIRONMENT, env);
 
   USE_SAFE_ALLOCA;
   emacs_value *args = nargs > 0 ? SAFE_ALLOCA (nargs * sizeof *args) : NULL;
@@ -1243,12 +1237,13 @@ module_assert_runtime (struct emacs_runtime *runtime)
   if (! module_assertions)
     return;
   ptrdiff_t count = 0;
-  for (Lisp_Object tail = Vmodule_runtimes; CONSP (tail); tail = XCDR (tail))
-    {
-      if (xmint_pointer (XCAR (tail)) == runtime)
-        return;
-      ++count;
-    }
+  for (const union specbinding *pdl = specpdl; pdl != specpdl_ptr; ++pdl)
+    if (pdl->kind == SPECPDL_MODULE_RUNTIME)
+      {
+        if (pdl->unwind_ptr.arg == runtime)
+          return;
+        ++count;
+      }
   module_abort ("Runtime pointer not found in list of %"pD"d runtimes",
                count);
 }
@@ -1259,13 +1254,13 @@ module_assert_env (emacs_env *env)
   if (! module_assertions)
     return;
   ptrdiff_t count = 0;
-  for (Lisp_Object tail = Vmodule_environments; CONSP (tail);
-       tail = XCDR (tail))
-    {
-      if (xmint_pointer (XCAR (tail)) == env)
-        return;
-      ++count;
-    }
+  for (const union specbinding *pdl = specpdl; pdl != specpdl_ptr; ++pdl)
+    if (pdl->kind == SPECPDL_MODULE_ENVIRONMENT)
+      {
+        if (pdl->unwind_ptr.arg == env)
+          return;
+        ++count;
+      }
   module_abort ("Environment pointer not found in list of %"pD"d environments",
                 count);
 }
@@ -1323,22 +1318,22 @@ value_to_lisp (emacs_value v)
          environments.  */
       ptrdiff_t num_environments = 0;
       ptrdiff_t num_values = 0;
-      for (Lisp_Object environments = Vmodule_environments;
-           CONSP (environments); environments = XCDR (environments))
-        {
-          emacs_env *env = xmint_pointer (XCAR (environments));
-          struct emacs_env_private *priv = env->private_members;
-          /* The value might be one of the nonlocal exit values.  Note
-             that we don't check whether a nonlocal exit is currently
-             pending, because the module might have cleared the flag
-             in the meantime.  */
-          if (&priv->non_local_exit_symbol == v
-              || &priv->non_local_exit_data == v)
-            goto ok;
-          if (value_storage_contains_p (&priv->storage, v, &num_values))
-            goto ok;
-          ++num_environments;
-        }
+      for (const union specbinding *pdl = specpdl; pdl != specpdl_ptr; ++pdl)
+        if (pdl->kind == SPECPDL_MODULE_ENVIRONMENT)
+          {
+            const emacs_env *env = pdl->unwind_ptr.arg;
+            struct emacs_env_private *priv = env->private_members;
+            /* The value might be one of the nonlocal exit values.  Note
+               that we don't check whether a nonlocal exit is currently
+               pending, because the module might have cleared the flag
+               in the meantime.  */
+            if (&priv->non_local_exit_symbol == v
+                || &priv->non_local_exit_data == v)
+              goto ok;
+            if (value_storage_contains_p (&priv->storage, v, &num_values))
+              goto ok;
+            ++num_environments;
+          }
       /* Also check global values.  */
       if (module_global_reference_p (v, &num_values))
         goto ok;
@@ -1421,18 +1416,14 @@ allocate_emacs_value (emacs_env *env, Lisp_Object obj)
 /* Mark all objects allocated from local environments so that they
    don't get garbage-collected.  */
 void
-mark_modules (void)
+mark_module_environment (void *ptr)
 {
-  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);
-    }
+  emacs_env *env = ptr;
+  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);
 }
 
 
@@ -1495,7 +1486,6 @@ initialize_environment (emacs_env *env, struct 
emacs_env_private *priv)
   env->set_function_finalizer = module_set_function_finalizer;
   env->open_channel = module_open_channel;
   env->make_interactive = module_make_interactive;
-  Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments);
   return env;
 }
 
@@ -1505,22 +1495,18 @@ 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);
 }
 
-static void
+void
 finalize_environment_unwind (void *env)
 {
   finalize_environment (env);
 }
 
-static void
+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);
 }
 
@@ -1610,12 +1596,6 @@ syms_of_module (void)
                       DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
                       Qnil, false);
 
-  staticpro (&Vmodule_runtimes);
-  Vmodule_runtimes = Qnil;
-
-  staticpro (&Vmodule_environments);
-  Vmodule_environments = Qnil;
-
   DEFSYM (Qmodule_load_failed, "module-load-failed");
   Fput (Qmodule_load_failed, Qerror_conditions,
        pure_list (Qmodule_load_failed, Qerror));
diff --git a/src/eval.c b/src/eval.c
index 3f9dcf6..d9a424b 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -681,6 +681,10 @@ default_toplevel_binding (Lisp_Object symbol)
        case SPECPDL_UNWIND_EXCURSION:
        case SPECPDL_UNWIND_VOID:
        case SPECPDL_BACKTRACE:
+#ifdef HAVE_MODULES
+        case SPECPDL_MODULE_RUNTIME:
+        case SPECPDL_MODULE_ENVIRONMENT:
+#endif
        case SPECPDL_LET_LOCAL:
          break;
 
@@ -720,6 +724,10 @@ lexbound_p (Lisp_Object symbol)
        case SPECPDL_UNWIND_EXCURSION:
        case SPECPDL_UNWIND_VOID:
        case SPECPDL_BACKTRACE:
+#ifdef HAVE_MODULES
+        case SPECPDL_MODULE_RUNTIME:
+        case SPECPDL_MODULE_ENVIRONMENT:
+#endif
        case SPECPDL_LET_LOCAL:
          break;
 
@@ -3480,6 +3488,15 @@ record_unwind_protect_void (void (*function) (void))
 }
 
 void
+record_unwind_protect_module (enum specbind_tag kind, void *ptr)
+{
+  specpdl_ptr->kind = kind;
+  specpdl_ptr->unwind_ptr.func = NULL;
+  specpdl_ptr->unwind_ptr.arg = ptr;
+  grow_specpdl ();
+}
+
+void
 rebind_for_thread_switch (void)
 {
   union specbinding *bind;
@@ -3529,6 +3546,14 @@ do_one_unbind (union specbinding *this_binding, bool 
unwinding,
       break;
     case SPECPDL_BACKTRACE:
       break;
+#ifdef HAVE_MODULES
+    case SPECPDL_MODULE_RUNTIME:
+      finalize_runtime_unwind (this_binding->unwind_ptr.arg);
+      break;
+    case SPECPDL_MODULE_ENVIRONMENT:
+      finalize_environment_unwind (this_binding->unwind_ptr.arg);
+      break;
+#endif
     case SPECPDL_LET:
       { /* If variable has a trivial value (no forwarding), and isn't
           trapped, we can just set it.  */
@@ -3859,6 +3884,10 @@ backtrace_eval_unrewind (int distance)
        case SPECPDL_UNWIND_INTMAX:
        case SPECPDL_UNWIND_VOID:
        case SPECPDL_BACKTRACE:
+#ifdef HAVE_MODULES
+        case SPECPDL_MODULE_RUNTIME:
+        case SPECPDL_MODULE_ENVIRONMENT:
+#endif
          break;
        case SPECPDL_LET:
          { /* If variable has a trivial value (no forwarding), we can
@@ -3994,6 +4023,10 @@ NFRAMES and BASE specify the activation frame to use, as 
in `backtrace-frame'.
          case SPECPDL_UNWIND_EXCURSION:
          case SPECPDL_UNWIND_VOID:
          case SPECPDL_BACKTRACE:
+#ifdef HAVE_MODULES
+          case SPECPDL_MODULE_RUNTIME:
+          case SPECPDL_MODULE_ENVIRONMENT:
+#endif
            break;
 
          default:
@@ -4040,6 +4073,14 @@ mark_specpdl (union specbinding *first, union 
specbinding *ptr)
          }
          break;
 
+#ifdef HAVE_MODULES
+        case SPECPDL_MODULE_RUNTIME:
+          break;
+        case SPECPDL_MODULE_ENVIRONMENT:
+          mark_module_environment (pdl->unwind_ptr.arg);
+          break;
+#endif
+
        case SPECPDL_LET_DEFAULT:
        case SPECPDL_LET_LOCAL:
          mark_object (specpdl_where (pdl));
diff --git a/src/lisp.h b/src/lisp.h
index 31614b9..a95913c 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3127,6 +3127,10 @@ enum specbind_tag {
   SPECPDL_UNWIND_EXCURSION,    /* Likewise, on an excursion.  */
   SPECPDL_UNWIND_VOID,         /* Likewise, with no arg.  */
   SPECPDL_BACKTRACE,           /* An element of the backtrace.  */
+#ifdef HAVE_MODULES
+  SPECPDL_MODULE_RUNTIME,       /* A live module runtime.  */
+  SPECPDL_MODULE_ENVIRONMENT,   /* A live module environment.  */
+#endif
   SPECPDL_LET,                 /* A plain and simple dynamic let-binding.  */
   /* Tags greater than SPECPDL_LET must be "subkinds" of LET.  */
   SPECPDL_LET_LOCAL,           /* A buffer-local let-binding.  */
@@ -4146,6 +4150,7 @@ extern void record_unwind_protect_intmax (void (*) 
(intmax_t), intmax_t);
 extern void record_unwind_protect_void (void (*) (void));
 extern void record_unwind_protect_excursion (void);
 extern void record_unwind_protect_nothing (void);
+extern void record_unwind_protect_module (enum specbind_tag, void *);
 extern void clear_unwind_protect (ptrdiff_t);
 extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), 
Lisp_Object);
 extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *);
@@ -4216,7 +4221,9 @@ extern module_funcptr module_function_address
   (struct Lisp_Module_Function const *);
 extern void *module_function_data (const struct Lisp_Module_Function *);
 extern void module_finalize_function (const struct Lisp_Module_Function *);
-extern void mark_modules (void);
+extern void mark_module_environment (void *);
+extern void finalize_runtime_unwind (void *);
+extern void finalize_environment_unwind (void *);
 extern void init_module_assertions (bool);
 extern void syms_of_module (void);
 #endif
diff --git a/test/src/emacs-module-resources/mod-test.c 
b/test/src/emacs-module-resources/mod-test.c
index 258a679..4196212 100644
--- a/test/src/emacs-module-resources/mod-test.c
+++ b/test/src/emacs-module-resources/mod-test.c
@@ -691,6 +691,14 @@ Fmod_test_identity (emacs_env *env, ptrdiff_t nargs, 
emacs_value *args,
   return args[0];
 }
 
+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.  */
@@ -780,6 +788,8 @@ emacs_module_init (struct emacs_runtime *ert)
   DEFUN ("mod-test-function-finalizer-calls",
          Fmod_test_function_finalizer_calls, 0, 0, NULL, NULL);
   DEFUN ("mod-test-async-pipe", Fmod_test_async_pipe, 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 fb4ed4a..99d4caf 100644
--- a/test/src/emacs-module-tests.el
+++ b/test/src/emacs-module-tests.el
@@ -506,4 +506,54 @@ See Bug#36226."
     (should (not (multibyte-string-p (mod-test-return-unibyte))))
     (should (equal result "foo\x00zot"))))
 
+(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