diff --git a/src/emacs-module.c b/src/emacs-module.c index a90a9765dbf..89d96839d2f 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) @@ -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, diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c index 8d1b421bb40..528b4b4c582 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 9df0b25a0c5..f9bd82e78c6 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