From 093d3e78d21d3d6c718997368ef4b31f9884401c Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 21 Mar 2019 21:29:52 +0200 Subject: [PATCH] Revert "Revert "Rely on conservative stack scanning to find "emacs_value"s"" This reverts commit ee7ad83f20903208404a84b58b7a478b62924570. There was no consensus on reverting 3eb93c07f7a60ac9ce8a16f10c3afd5a3a31243a, so doing that will have to wait until the discussion ends. --- src/emacs-module.c | 373 ++++++++++++++++-------------- test/data/emacs-module/mod-test.c | 6 +- test/src/emacs-module-tests.el | 3 +- 3 files changed, 202 insertions(+), 180 deletions(-) diff --git a/src/emacs-module.c b/src/emacs-module.c index df9a491a864..4e2411cb295 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -25,7 +25,6 @@ along with GNU Emacs. If not, see . */ #include #include #include -#include #include "lisp.h" #include "dynlib.h" @@ -66,6 +65,18 @@ along with GNU Emacs. If not, see . */ #include "w32term.h" #endif +/* True if Lisp_Object and emacs_value have the same representation. + This is typically true unless WIDE_EMACS_INT. In practice, having + the same sizes and alignments and maximums should be a good enough + proxy for equality of representation. */ +enum + { + plain_values + = (sizeof (Lisp_Object) == sizeof (emacs_value) + && alignof (Lisp_Object) == alignof (emacs_value) + && INTPTR_MAX == EMACS_INT_MAX) + }; + /* Function prototype for the module init function. */ typedef int (*emacs_init_function) (struct emacs_runtime *); @@ -75,43 +86,6 @@ typedef int (*emacs_init_function) (struct emacs_runtime *); in this module, though, so this constraint is not enforced here. */ typedef void (*emacs_finalizer_function) (void *); - -/* Memory management. */ - -/* An `emacs_value' is just a pointer to a structure holding an - internal Lisp object. */ -struct emacs_value_tag { Lisp_Object v; }; - -/* Local value objects use a simple fixed-sized block allocation - scheme without explicit deallocation. All local values are - deallocated when the lifetime of their environment ends. Keep - track of a current frame from which new values are allocated, - appending further dynamically-allocated frames if necessary. */ - -enum { value_frame_size = 512 }; - -/* A block from which `emacs_value' object can be allocated. */ -struct emacs_value_frame -{ - /* Storage for values. */ - struct emacs_value_tag objects[value_frame_size]; - - /* Index of the next free value in `objects'. */ - int offset; - - /* Pointer to next frame, if any. */ - struct emacs_value_frame *next; -}; - -/* A structure that holds an initial frame (so that the first local - values require no dynamic allocation) and keeps track of the - current frame. */ -static struct emacs_value_storage -{ - struct emacs_value_frame initial; - struct emacs_value_frame *current; -} global_storage; - /* Private runtime and environment members. */ @@ -125,9 +99,12 @@ struct emacs_env_private /* Dedicated storage for non-local exit symbol and data so that storage is always available for them, even in an out-of-memory situation. */ - struct emacs_value_tag non_local_exit_symbol, non_local_exit_data; + Lisp_Object non_local_exit_symbol, non_local_exit_data; - struct emacs_value_storage storage; + /* List of values allocated from this environment. The code uses + this only if the user gave the -module-assertions command-line + option. */ + Lisp_Object values; }; /* The private parts of an `emacs_runtime' object contain the initial @@ -141,7 +118,6 @@ struct emacs_runtime_private /* Forward declarations. */ static Lisp_Object value_to_lisp (emacs_value); -static emacs_value allocate_emacs_value (emacs_env *, struct emacs_value_storage *, Lisp_Object); static emacs_value lisp_to_value (emacs_env *, Lisp_Object); static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *); static void module_assert_thread (void); @@ -163,7 +139,16 @@ static void module_non_local_exit_throw_1 (emacs_env *, static void module_out_of_memory (emacs_env *); static void module_reset_handlerlist (struct handler **); +/* We used to return NULL when emacs_value was a different type from + Lisp_Object, but nowadays we just use Qnil instead. Although they + happen to be the same thing in the current implementation, module + code should not assume this. */ +verify (NIL_IS_ZERO); +static emacs_value const module_nil = 0; + static bool module_assertions = false; +static emacs_env *global_env; +static struct emacs_env_private global_env_private; /* Convenience macros for non-local exit handling. */ @@ -308,7 +293,7 @@ module_get_environment (struct emacs_runtime *ert) static emacs_value module_make_global_ref (emacs_env *env, emacs_value ref) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); Lisp_Object new_obj = value_to_lisp (ref); EMACS_UINT hashcode; @@ -328,7 +313,7 @@ module_make_global_ref (emacs_env *env, emacs_value ref) hash_put (h, new_obj, make_fixed_natnum (1), hashcode); } - return allocate_emacs_value (env, &global_storage, new_obj); + return lisp_to_value (module_assertions ? global_env : env, new_obj); } static void @@ -356,16 +341,23 @@ module_free_global_ref (emacs_env *env, emacs_value ref) if (module_assertions) { + Lisp_Object globals = global_env_private.values; + Lisp_Object prev = Qnil; ptrdiff_t count = 0; - for (struct emacs_value_frame *frame = &global_storage.initial; - frame != NULL; frame = frame->next) + for (Lisp_Object tail = globals; CONSP (tail); + tail = XCDR (tail)) { - for (int i = 0; i < frame->offset; ++i) + emacs_value global = xmint_pointer (XCAR (tail)); + if (global == ref) { - if (&frame->objects[i] == ref) - return; - ++count; + if (NILP (prev)) + global_env_private.values = XCDR (globals); + else + XSETCDR (prev, XCDR (tail)); + return; } + ++count; + prev = tail; } module_abort ("Global value was not found in list of %"pD"d globals", count); @@ -396,8 +388,9 @@ module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) struct emacs_env_private *p = env->private_members; if (p->pending_non_local_exit != emacs_funcall_exit_return) { - *sym = &p->non_local_exit_symbol; - *data = &p->non_local_exit_data; + /* FIXME: lisp_to_value can exit non-locally. */ + *sym = lisp_to_value (env, p->non_local_exit_symbol); + *data = lisp_to_value (env, p->non_local_exit_data); } return p->pending_non_local_exit; } @@ -441,7 +434,7 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, emacs_subr subr, const char *documentation, void *data) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); if (! (0 <= min_arity && (max_arity < 0 @@ -474,7 +467,7 @@ static emacs_value module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, emacs_value args[]) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); /* Make a new Lisp_Object array starting with the function as the first arg, because that's what Ffuncall takes. */ @@ -495,14 +488,14 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, static emacs_value module_intern (emacs_env *env, const char *name) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); return lisp_to_value (env, intern (name)); } static emacs_value module_type_of (emacs_env *env, emacs_value value) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); return lisp_to_value (env, Ftype_of (value_to_lisp (value))); } @@ -535,7 +528,7 @@ module_extract_integer (emacs_env *env, emacs_value n) static emacs_value module_make_integer (emacs_env *env, intmax_t n) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); return lisp_to_value (env, make_int (n)); } @@ -551,7 +544,7 @@ module_extract_float (emacs_env *env, emacs_value f) static emacs_value module_make_float (emacs_env *env, double d) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); return lisp_to_value (env, make_float (d)); } @@ -588,7 +581,7 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, static emacs_value module_make_string (emacs_env *env, const char *str, ptrdiff_t length) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); if (! (0 <= length && length <= STRING_BYTES_BOUND)) overflow_error (); /* FIXME: AUTO_STRING_WITH_LEN requires STR to be null-terminated, @@ -601,7 +594,7 @@ module_make_string (emacs_env *env, const char *str, ptrdiff_t length) static emacs_value module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); return lisp_to_value (env, make_user_ptr (fin, ptr)); } @@ -663,7 +656,7 @@ module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) static emacs_value module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) { - MODULE_FUNCTION_BEGIN (NULL); + MODULE_FUNCTION_BEGIN (module_nil); Lisp_Object lvec = value_to_lisp (vec); check_vec_index (lvec, i); return lisp_to_value (env, AREF (lvec, i)); @@ -706,11 +699,9 @@ module_signal_or_throw (struct emacs_env_private *env) case emacs_funcall_exit_return: return; case emacs_funcall_exit_signal: - xsignal (value_to_lisp (&env->non_local_exit_symbol), - value_to_lisp (&env->non_local_exit_data)); + xsignal (env->non_local_exit_symbol, env->non_local_exit_data); case emacs_funcall_exit_throw: - Fthrow (value_to_lisp (&env->non_local_exit_symbol), - value_to_lisp (&env->non_local_exit_data)); + Fthrow (env->non_local_exit_symbol, env->non_local_exit_data); default: eassume (false); } @@ -786,12 +777,17 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist) record_unwind_protect_ptr (finalize_environment_unwind, env); USE_SAFE_ALLOCA; - emacs_value *args = nargs > 0 ? SAFE_ALLOCA (nargs * sizeof *args) : NULL; - for (ptrdiff_t i = 0; i < nargs; ++i) + ATTRIBUTE_MAY_ALIAS emacs_value *args; + if (plain_values && ! module_assertions) + /* FIXME: The cast below is incorrect because the argument array + is not declared as const, so module functions can modify it. + Either declare it as const, or remove this branch. */ + args = (emacs_value *) arglist; + else { - args[i] = lisp_to_value (env, arglist[i]); - if (! args[i]) - memory_full (sizeof *args[i]); + args = SAFE_ALLOCA (nargs * sizeof *args); + for (ptrdiff_t i = 0; i < nargs; i++) + args[i] = lisp_to_value (env, arglist[i]); } emacs_value ret = func->subr (env, nargs, args, func->data); @@ -871,8 +867,8 @@ module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym, if (p->pending_non_local_exit == emacs_funcall_exit_return) { p->pending_non_local_exit = emacs_funcall_exit_signal; - p->non_local_exit_symbol.v = sym; - p->non_local_exit_data.v = data; + p->non_local_exit_symbol = sym; + p->non_local_exit_data = data; } } @@ -884,8 +880,8 @@ module_non_local_exit_throw_1 (emacs_env *env, Lisp_Object tag, if (p->pending_non_local_exit == emacs_funcall_exit_return) { p->pending_non_local_exit = emacs_funcall_exit_throw; - p->non_local_exit_symbol.v = tag; - p->non_local_exit_data.v = value; + p->non_local_exit_symbol = tag; + p->non_local_exit_data = value; } } @@ -902,8 +898,54 @@ module_out_of_memory (emacs_env *env) /* Value conversion. */ -/* Convert an `emacs_value' to the corresponding internal object. - Never fails. */ +/* We represent Lisp objects differently depending on whether the user + gave -module-assertions. If assertions are disabled, emacs_value + objects are Lisp_Objects cast to emacs_value. If assertions are + enabled, emacs_value objects are pointers to Lisp_Object objects + allocated from the free store; they are never freed, which ensures + that their addresses are unique and can be used for liveness + checking. */ + +/* Unique Lisp_Object used to mark those emacs_values which are really + just containers holding a Lisp_Object that does not fit as an emacs_value, + either because it is an integer out of range, or is not properly aligned. + Used only if !plain_values. */ +static Lisp_Object ltv_mark; + +/* Convert V to the corresponding internal object O, such that + V == lisp_to_value_bits (O). Never fails. */ +static Lisp_Object +value_to_lisp_bits (emacs_value v) +{ + if (plain_values || USE_LSB_TAG) + return XPL (v); + + /* With wide EMACS_INT and when tag bits are the most significant, + reassembling integers differs from reassembling pointers in two + ways. First, save and restore the least-significant bits of the + integer, not the most-significant bits. Second, sign-extend the + integer when restoring, but zero-extend pointers because that + makes TAG_PTR faster. */ + + intptr_t i = (intptr_t) v; + EMACS_UINT tag = i & ((1 << GCTYPEBITS) - 1); + EMACS_UINT untagged = i - tag; + switch (tag) + { + case_Lisp_Int: + { + bool negative = tag & 1; + EMACS_UINT sign_extension + = negative ? VALMASK & ~(INTPTR_MAX >> INTTYPEBITS): 0; + uintptr_t u = i; + intptr_t all_but_sign = u >> GCTYPEBITS; + untagged = sign_extension + all_but_sign; + break; + } + } + + return XIL ((tag << VALBITS) + untagged); +} /* If V was computed from lisp_to_value (O), then return O. Exits non-locally only if the stack overflows. */ @@ -914,134 +956,91 @@ value_to_lisp (emacs_value v) { /* Check the liveness of the value by iterating over all live environments. */ + void *vptr = v; + ATTRIBUTE_MAY_ALIAS Lisp_Object *optr = vptr; 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; - for (struct emacs_value_frame *frame = &priv->storage.initial; - frame != NULL; frame = frame->next) + for (Lisp_Object values = env->private_members->values; + CONSP (values); values = XCDR (values)) { - for (int i = 0; i < frame->offset; ++i) - { - if (&frame->objects[i] == v) - goto ok; - ++num_values; - } - } - ++num_environments; - } - /* Also check global values. */ - for (struct emacs_value_frame *frame = &global_storage.initial; - frame != NULL; frame = frame->next) - { - for (int i = 0; i < frame->offset; ++i) - { - if (&frame->objects[i] == v) - goto ok; + Lisp_Object *p = xmint_pointer (XCAR (values)); + if (p == optr) + return *p; ++num_values; } + ++num_environments; } module_abort (("Emacs value not found in %"pD"d values " "of %"pD"d environments"), num_values, num_environments); } - ok: return v->v; + Lisp_Object o = value_to_lisp_bits (v); + if (! plain_values && CONSP (o) && EQ (XCDR (o), ltv_mark)) + o = XCAR (o); + return o; } -/* Convert an internal object to an `emacs_value'. Allocate storage - from the environment; return NULL if allocation fails. */ +/* Attempt to convert O to an emacs_value. Do not do any checking + or allocate any storage; the caller should prevent or detect + any resulting bit pattern that is not a valid emacs_value. */ static emacs_value -lisp_to_value (emacs_env *env, Lisp_Object o) +lisp_to_value_bits (Lisp_Object o) { - struct emacs_env_private *p = env->private_members; - if (p->pending_non_local_exit != emacs_funcall_exit_return) - return NULL; - return allocate_emacs_value (env, &p->storage, o); -} + if (plain_values || USE_LSB_TAG) + return XLP (o); -/* Must be called for each frame before it can be used for allocation. */ -static void -initialize_frame (struct emacs_value_frame *frame) -{ - frame->offset = 0; - frame->next = NULL; -} - -/* Must be called for any storage object before it can be used for - allocation. */ -static void -initialize_storage (struct emacs_value_storage *storage) -{ - initialize_frame (&storage->initial); - storage->current = &storage->initial; -} - -/* Must be called for any initialized storage object before its - lifetime ends. Free all dynamically-allocated frames. */ -static void -finalize_storage (struct emacs_value_storage *storage) -{ - struct emacs_value_frame *next = storage->initial.next; - while (next != NULL) + /* Compress O into the space of a pointer, possibly losing information. */ + EMACS_UINT u = XLI (o); + if (FIXNUMP (o)) { - struct emacs_value_frame *current = next; - next = current->next; - free (current); + uintptr_t i = (u << VALBITS) + XTYPE (o); + return (emacs_value) i; + } + else + { + char *p = XLP (o); + void *v = p - (u & ~VALMASK) + XTYPE (o); + return v; } } -/* Allocate a new value from STORAGE and stores OBJ in it. Return - NULL if allocation fails and use ENV for non local exit reporting. */ +/* Convert O to an emacs_value. Allocate storage if needed; this can + signal if memory is exhausted. Must be an injective function. */ static emacs_value -allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage, - Lisp_Object obj) +lisp_to_value (emacs_env *env, Lisp_Object o) { - eassert (storage->current); - eassert (storage->current->offset < value_frame_size); - eassert (! storage->current->next); - if (storage->current->offset == value_frame_size - 1) + if (module_assertions) { - storage->current->next = malloc (sizeof *storage->current->next); - if (! storage->current->next) - { - module_out_of_memory (env); - return NULL; - } - initialize_frame (storage->current->next); - storage->current = storage->current->next; + /* Add the new value to the list of values allocated from this + environment. The value is actually a pointer to the + Lisp_Object cast to emacs_value. We make a copy of the + object on the free store to guarantee unique addresses. */ + ATTRIBUTE_MAY_ALIAS Lisp_Object *optr = xmalloc (sizeof o); + *optr = o; + void *vptr = optr; + ATTRIBUTE_MAY_ALIAS emacs_value ret = vptr; + struct emacs_env_private *priv = env->private_members; + priv->values = Fcons (make_mint_ptr (ret), priv->values); + return ret; } - emacs_value value = storage->current->objects + storage->current->offset; - value->v = obj; - ++storage->current->offset; - return value; -} -/* Mark all objects allocated from local environments so that they - don't get garbage-collected. */ -void -mark_modules (void) -{ - for (Lisp_Object tem = Vmodule_environments; CONSP (tem); tem = XCDR (tem)) + emacs_value v = lisp_to_value_bits (o); + + if (! EQ (o, value_to_lisp_bits (v))) { - 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); + /* Package the incompressible object pointer inside a pair + that is compressible. */ + Lisp_Object pair = Fcons (o, ltv_mark); + v = (emacs_value) ((intptr_t) XCONS (pair) + Lisp_Cons); } + + eassert (EQ (o, value_to_lisp (v))); + return v; } @@ -1060,7 +1059,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) env = xmalloc (sizeof *env); priv->pending_non_local_exit = emacs_funcall_exit_return; - initialize_storage (&priv->storage); + priv->values = priv->non_local_exit_symbol = priv->non_local_exit_data = Qnil; env->size = sizeof *env; env->private_members = priv; env->make_global_ref = module_make_global_ref; @@ -1101,9 +1100,11 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) 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); + if (module_assertions) + /* There is always at least the global environment. */ + eassert (CONSP (Vmodule_environments)); } static void @@ -1121,6 +1122,20 @@ finalize_runtime_unwind (void *raw_ert) finalize_environment (ert->private_members->env); } +void +mark_modules (void) +{ + for (Lisp_Object tail = Vmodule_environments; CONSP (tail); + tail = XCDR (tail)) + { + emacs_env *env = xmint_pointer (XCAR (tail)); + struct emacs_env_private *priv = env->private_members; + mark_object (priv->non_local_exit_symbol); + mark_object (priv->non_local_exit_data); + mark_object (priv->values); + } +} + /* Non-local exit handling. */ @@ -1160,7 +1175,8 @@ init_module_assertions (bool enable) /* If enabling module assertions, use a hidden environment for storing the globals. This environment is never freed. */ module_assertions = enable; - initialize_storage (&global_storage); + if (enable) + global_env = initialize_environment (NULL, &global_env_private); } static _Noreturn void @@ -1183,6 +1199,13 @@ module_abort (const char *format, ...) void syms_of_module (void) { + if (!plain_values) + { + ltv_mark = Fcons (Qnil, Qnil); + staticpro (<v_mark); + } + eassert (NILP (value_to_lisp (module_nil))); + DEFSYM (Qmodule_refs_hash, "module-refs-hash"); DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash, doc: /* Module global reference table. */); diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c index a39e41afee6..47ea159d0e7 100644 --- a/test/data/emacs-module/mod-test.c +++ b/test/data/emacs-module/mod-test.c @@ -94,7 +94,7 @@ Fmod_test_signal (emacs_env *env, ptrdiff_t nargs, emacs_value args[], assert (env->non_local_exit_check (env) == emacs_funcall_exit_return); env->non_local_exit_signal (env, env->intern (env, "error"), env->make_integer (env, 56)); - return NULL; + return env->intern (env, "nil"); } @@ -106,7 +106,7 @@ Fmod_test_throw (emacs_env *env, ptrdiff_t nargs, emacs_value args[], assert (env->non_local_exit_check (env) == emacs_funcall_exit_return); env->non_local_exit_throw (env, env->intern (env, "tag"), env->make_integer (env, 65)); - return NULL; + return env->intern (env, "nil"); } @@ -304,7 +304,7 @@ Fmod_test_invalid_finalizer (emacs_env *env, ptrdiff_t nargs, emacs_value *args, { current_env = env; env->make_user_ptr (env, invalid_finalizer, NULL); - return env->intern (env, "nil"); + return env->funcall (env, env->intern (env, "garbage-collect"), 0, NULL); } static void diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 35aaaa64b65..e30980b5993 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -265,8 +265,7 @@ during garbage collection." (skip-unless (file-executable-p mod-test-emacs)) (module--test-assertion (rx "Module function called during garbage collection\n") - (mod-test-invalid-finalizer) - (garbage-collect))) + (mod-test-invalid-finalizer))) (ert-deftest module/describe-function-1 () "Check that Bug#30163 is fixed." -- 2.39.5