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.
This commit is contained in:
Philipp Stephani
parent
c9160bda78
commit
cdc632fbe6
3 changed files with 169 additions and 22 deletions
|
|
@ -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)
|
||||
|
|
@ -1209,6 +1214,83 @@ module_out_of_memory (emacs_env *env)
|
|||
XCDR (Vmemory_signal_data));
|
||||
}
|
||||
|
||||
|
||||
/* 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. */
|
||||
|
||||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue