diff options
Diffstat (limited to 'src/emacs-module.c')
| -rw-r--r-- | src/emacs-module.c | 1134 |
1 files changed, 1134 insertions, 0 deletions
diff --git a/src/emacs-module.c b/src/emacs-module.c new file mode 100644 index 00000000000..881ee3119de --- /dev/null +++ b/src/emacs-module.c @@ -0,0 +1,1134 @@ +/* emacs-module.c - Module loading and runtime implementation + +Copyright (C) 2015 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include "emacs-module.h" + +#include <stdbool.h> +#include <stddef.h> +#include <stdint.h> +#include <stdio.h> +#include <string.h> + +#include "lisp.h" +#include "dynlib.h" +#include "coding.h" +#include "verify.h" + + +/* Feature tests. */ + +/* True if __attribute__ ((cleanup (...))) works, false otherwise. */ +#ifdef HAVE_VAR_ATTRIBUTE_CLEANUP +enum { module_has_cleanup = true }; +#else +enum { module_has_cleanup = false }; +#endif + +/* Handle to the main thread. Used to verify that modules call us in + the right thread. */ +#ifdef HAVE_PTHREAD +# include <pthread.h> +static pthread_t main_thread; +#elif defined WINDOWSNT +#include <windows.h> +#include "w32term.h" +static DWORD main_thread; +#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) + }; + + +/* Private runtime and environment members. */ + +/* The private part of an environment stores the current non local exit state + and holds the `emacs_value' objects allocated during the lifetime + of the environment. */ +struct emacs_env_private +{ + enum emacs_funcall_exit pending_non_local_exit; + + /* Dedicated storage for non-local exit symbol and data so that + storage is always available for them, even in an out-of-memory + situation. */ + Lisp_Object non_local_exit_symbol, non_local_exit_data; +}; + +/* The private parts of an `emacs_runtime' object contain the initial + environment. */ +struct emacs_runtime_private +{ + /* FIXME: Ideally, we would just define "struct emacs_runtime_private" + as a synonym of "emacs_env", but I don't know how to do that in C. */ + emacs_env pub; +}; + + +/* Forward declarations. */ + +struct module_fun_env; + +static Lisp_Object module_format_fun_env (const struct module_fun_env *); +static Lisp_Object value_to_lisp (emacs_value); +static emacs_value lisp_to_value (Lisp_Object); +static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *); +static void check_main_thread (void); +static void finalize_environment (struct emacs_env_private *); +static void initialize_environment (emacs_env *, struct emacs_env_private *priv); +static void module_args_out_of_range (emacs_env *, Lisp_Object, Lisp_Object); +static void module_handle_signal (emacs_env *, Lisp_Object); +static void module_handle_throw (emacs_env *, Lisp_Object); +static void module_non_local_exit_signal_1 (emacs_env *, Lisp_Object, Lisp_Object); +static void module_non_local_exit_throw_1 (emacs_env *, Lisp_Object, Lisp_Object); +static void module_out_of_memory (emacs_env *); +static void module_reset_handlerlist (const int *); +static void module_wrong_type (emacs_env *, Lisp_Object, Lisp_Object); + +/* 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; + +/* Convenience macros for non-local exit handling. */ + +/* FIXME: The following implementation for non-local exit handling + does not support recovery from stack overflow, see sysdep.c. */ + +/* Emacs uses setjmp and longjmp for non-local exits, but + module frames cannot be skipped because they are in general + not prepared for long jumps (e.g., the behavior in C++ is undefined + if objects with nontrivial destructors would be skipped). + Therefore, catch all non-local exits. There are two kinds of + non-local exits: `signal' and `throw'. The macros in this section + can be used to catch both. Use macros to avoid additional variants + of `internal_condition_case' etc., and to avoid worrying about + passing information to the handler functions. */ + +/* Place this macro at the beginning of a function returning a number + or a pointer to handle non-local exits. The function must have an + ENV parameter. The function will return the specified value if a + signal or throw is caught. */ +// TODO: Have Fsignal check for CATCHER_ALL so we only have to install +// one handler. +#define MODULE_HANDLE_NONLOCAL_EXIT(retval) \ + MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval); \ + MODULE_SETJMP (CATCHER_ALL, module_handle_throw, retval) + +#define MODULE_SETJMP(handlertype, handlerfunc, retval) \ + MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \ + internal_handler_##handlertype, \ + internal_cleanup_##handlertype) + +/* It is very important that pushing the handler doesn't itself raise + a signal. Install the cleanup only after the handler has been + pushed. Use __attribute__ ((cleanup)) to avoid + non-local-exit-prone manual cleanup. + + The do-while forces uses of the macro to be followed by a semicolon. + This macro cannot enclose its entire body inside a do-while, as the + code after the macro may longjmp back into the macro, which means + its local variable C must stay live in later code. */ + +// TODO: Make backtraces work if this macros is used. + +#define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \ + if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \ + return retval; \ + struct handler *c = push_handler_nosignal (Qt, handlertype); \ + if (!c) \ + { \ + module_out_of_memory (env); \ + return retval; \ + } \ + verify (module_has_cleanup); \ + int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \ + if (sys_setjmp (c->jmp)) \ + { \ + (handlerfunc) (env, c->val); \ + return retval; \ + } \ + do { } while (false) + + +/* Function environments. */ + +/* A function environment is an auxiliary structure used by + `module_make_function' to store information about a module + function. It is stored in a save pointer and retrieved by + `internal--module-call'. Its members correspond to the arguments + given to `module_make_function'. */ + +struct module_fun_env +{ + ptrdiff_t min_arity, max_arity; + emacs_subr subr; + void *data; +}; + + +/* Implementation of runtime and environment functions. + + These should abide by the following rules: + + 1. The first argument should always be a pointer to emacs_env. + + 2. Each function should first call check_main_thread. Note that + this function is a no-op unless Emacs was built with + --enable-checking. + + 3. The very next thing each function should do is check that the + emacs_env object does not have a non-local exit indication set, + by calling module_non_local_exit_check. If that returns + anything but emacs_funcall_exit_return, the function should do + nothing and return immediately with an error indication, without + clobbering the existing error indication in emacs_env. This is + needed for correct reporting of Lisp errors to the Emacs Lisp + interpreter. + + 4. Any function that needs to call Emacs facilities, such as + encoding or decoding functions, or 'intern', or 'make_string', + should protect itself from signals and 'throw' in the called + Emacs functions, by placing the macro + MODULE_HANDLE_NONLOCAL_EXIT right after the above 2 tests. + + 5. Do NOT use 'eassert' for checking validity of user code in the + module. Instead, make those checks part of the code, and if the + check fails, call 'module_non_local_exit_signal_1' or + 'module_non_local_exit_throw_1' to report the error. This is + because using 'eassert' in these situations will abort Emacs + instead of reporting the error back to Lisp, and also because + 'eassert' is compiled to nothing in the release version. */ + +/* Use MODULE_FUNCTION_BEGIN to implement steps 2 through 4 for most + environment functions. On error it will return its argument, which + should be a sentinel value. */ + +#define MODULE_FUNCTION_BEGIN(error_retval) \ + check_main_thread (); \ + if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \ + return error_retval; \ + MODULE_HANDLE_NONLOCAL_EXIT (error_retval) + +/* Catch signals and throws only if the code can actually signal or + throw. If checking is enabled, abort if the current thread is not + the Emacs main thread. */ + +static emacs_env * +module_get_environment (struct emacs_runtime *ert) +{ + check_main_thread (); + return &ert->private_members->pub; +} + +/* To make global refs (GC-protected global values) keep a hash that + maps global Lisp objects to reference counts. */ + +static emacs_value +module_make_global_ref (emacs_env *env, emacs_value ref) +{ + 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; + ptrdiff_t i = hash_lookup (h, new_obj, &hashcode); + + if (i >= 0) + { + Lisp_Object value = HASH_VALUE (h, i); + EMACS_INT refcount = XFASTINT (value) + 1; + if (refcount > MOST_POSITIVE_FIXNUM) + { + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return module_nil; + } + value = make_natnum (refcount); + set_hash_value_slot (h, i, value); + } + else + { + hash_put (h, new_obj, make_natnum (1), hashcode); + } + + return lisp_to_value (new_obj); +} + +static void +module_free_global_ref (emacs_env *env, emacs_value ref) +{ + /* TODO: This probably never signals. */ + /* FIXME: Wait a minute. Shouldn't this function report an error if + the hash lookup fails? */ + MODULE_FUNCTION_BEGIN (); + struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); + Lisp_Object obj = value_to_lisp (ref); + EMACS_UINT hashcode; + ptrdiff_t i = hash_lookup (h, obj, &hashcode); + + if (i >= 0) + { + Lisp_Object value = HASH_VALUE (h, i); + EMACS_INT refcount = XFASTINT (value) - 1; + if (refcount > 0) + { + value = make_natnum (refcount); + set_hash_value_slot (h, i, value); + } + else + hash_remove_from_table (h, value); + } +} + +static enum emacs_funcall_exit +module_non_local_exit_check (emacs_env *env) +{ + check_main_thread (); + return env->private_members->pending_non_local_exit; +} + +static void +module_non_local_exit_clear (emacs_env *env) +{ + check_main_thread (); + env->private_members->pending_non_local_exit = emacs_funcall_exit_return; +} + +static enum emacs_funcall_exit +module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) +{ + check_main_thread (); + struct emacs_env_private *p = env->private_members; + if (p->pending_non_local_exit != emacs_funcall_exit_return) + { + /* FIXME: lisp_to_value can exit non-locally. */ + *sym = lisp_to_value (p->non_local_exit_symbol); + *data = lisp_to_value (p->non_local_exit_data); + } + return p->pending_non_local_exit; +} + +/* Like for `signal', DATA must be a list. */ +static void +module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data) +{ + check_main_thread (); + if (module_non_local_exit_check (env) == emacs_funcall_exit_return) + module_non_local_exit_signal_1 (env, value_to_lisp (sym), + value_to_lisp (data)); +} + +static void +module_non_local_exit_throw (emacs_env *env, emacs_value tag, emacs_value value) +{ + check_main_thread (); + if (module_non_local_exit_check (env) == emacs_funcall_exit_return) + module_non_local_exit_throw_1 (env, value_to_lisp (tag), + value_to_lisp (value)); +} + +/* A module function is lambda function that calls + `internal--module-call', passing the function pointer of the module + function along with the module emacs_env pointer as arguments. + + (function (lambda (&rest arglist) + (internal--module-call envobj arglist))) */ + +static emacs_value +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 (module_nil); + + if (! (0 <= min_arity + && (max_arity < 0 + ? max_arity == emacs_variadic_function + : min_arity <= max_arity))) + xsignal2 (Qinvalid_arity, make_number (min_arity), make_number (max_arity)); + + /* FIXME: This should be freed when envobj is GC'd. */ + struct module_fun_env *envptr = xmalloc (sizeof *envptr); + envptr->min_arity = min_arity; + envptr->max_arity = max_arity; + envptr->subr = subr; + envptr->data = data; + + Lisp_Object envobj = make_save_ptr (envptr); + Lisp_Object doc + = (documentation + ? code_convert_string_norecord (build_unibyte_string (documentation), + Qutf_8, false) + : Qnil); + /* FIXME: Use a bytecompiled object, or even better a subr. */ + Lisp_Object ret = list4 (Qlambda, + list2 (Qand_rest, Qargs), + doc, + list4 (Qapply, + list2 (Qfunction, Qinternal_module_call), + envobj, + Qargs)); + + return lisp_to_value (ret); +} + +static emacs_value +module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, + emacs_value args[]) +{ + 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. */ + Lisp_Object *newargs; + USE_SAFE_ALLOCA; + SAFE_ALLOCA_LISP (newargs, nargs + 1); + newargs[0] = value_to_lisp (fun); + for (ptrdiff_t i = 0; i < nargs; i++) + newargs[1 + i] = value_to_lisp (args[i]); + emacs_value result = lisp_to_value (Ffuncall (nargs + 1, newargs)); + SAFE_FREE (); + return result; +} + +static emacs_value +module_intern (emacs_env *env, const char *name) +{ + MODULE_FUNCTION_BEGIN (module_nil); + return lisp_to_value (intern (name)); +} + +static emacs_value +module_type_of (emacs_env *env, emacs_value value) +{ + MODULE_FUNCTION_BEGIN (module_nil); + return lisp_to_value (Ftype_of (value_to_lisp (value))); +} + +static bool +module_is_not_nil (emacs_env *env, emacs_value value) +{ + check_main_thread (); + if (module_non_local_exit_check (env) != emacs_funcall_exit_return) + return false; + return ! NILP (value_to_lisp (value)); +} + +static bool +module_eq (emacs_env *env, emacs_value a, emacs_value b) +{ + check_main_thread (); + if (module_non_local_exit_check (env) != emacs_funcall_exit_return) + return false; + return EQ (value_to_lisp (a), value_to_lisp (b)); +} + +static intmax_t +module_extract_integer (emacs_env *env, emacs_value n) +{ + MODULE_FUNCTION_BEGIN (0); + Lisp_Object l = value_to_lisp (n); + if (! INTEGERP (l)) + { + module_wrong_type (env, Qintegerp, l); + return 0; + } + return XINT (l); +} + +static emacs_value +module_make_integer (emacs_env *env, intmax_t n) +{ + MODULE_FUNCTION_BEGIN (module_nil); + if (! (MOST_NEGATIVE_FIXNUM <= n && n <= MOST_POSITIVE_FIXNUM)) + { + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return module_nil; + } + return lisp_to_value (make_number (n)); +} + +static double +module_extract_float (emacs_env *env, emacs_value f) +{ + MODULE_FUNCTION_BEGIN (0); + Lisp_Object lisp = value_to_lisp (f); + if (! FLOATP (lisp)) + { + module_wrong_type (env, Qfloatp, lisp); + return 0; + } + return XFLOAT_DATA (lisp); +} + +static emacs_value +module_make_float (emacs_env *env, double d) +{ + MODULE_FUNCTION_BEGIN (module_nil); + return lisp_to_value (make_float (d)); +} + +static bool +module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, + ptrdiff_t *length) +{ + MODULE_FUNCTION_BEGIN (false); + Lisp_Object lisp_str = value_to_lisp (value); + if (! STRINGP (lisp_str)) + { + module_wrong_type (env, Qstringp, lisp_str); + return false; + } + + Lisp_Object lisp_str_utf8 = ENCODE_UTF_8 (lisp_str); + ptrdiff_t raw_size = SBYTES (lisp_str_utf8); + if (raw_size == PTRDIFF_MAX) + { + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return false; + } + ptrdiff_t required_buf_size = raw_size + 1; + + eassert (length != NULL); + + if (buffer == NULL) + { + *length = required_buf_size; + return true; + } + + eassert (*length >= 0); + + if (*length < required_buf_size) + { + *length = required_buf_size; + module_non_local_exit_signal_1 (env, Qargs_out_of_range, Qnil); + return false; + } + + *length = required_buf_size; + memcpy (buffer, SDATA (lisp_str_utf8), raw_size + 1); + + return true; +} + +static emacs_value +module_make_string (emacs_env *env, const char *str, ptrdiff_t length) +{ + MODULE_FUNCTION_BEGIN (module_nil); + if (length > STRING_BYTES_BOUND) + { + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return module_nil; + } + Lisp_Object lstr = make_unibyte_string (str, length); + return lisp_to_value (code_convert_string_norecord (lstr, Qutf_8, false)); +} + +static emacs_value +module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) +{ + MODULE_FUNCTION_BEGIN (module_nil); + return lisp_to_value (make_user_ptr (fin, ptr)); +} + +static void * +module_get_user_ptr (emacs_env *env, emacs_value uptr) +{ + MODULE_FUNCTION_BEGIN (NULL); + Lisp_Object lisp = value_to_lisp (uptr); + if (! USER_PTRP (lisp)) + { + module_wrong_type (env, Quser_ptr, lisp); + return NULL; + } + return XUSER_PTR (lisp)->p; +} + +static void +module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr) +{ + /* FIXME: This function should return bool because it can fail. */ + MODULE_FUNCTION_BEGIN (); + check_main_thread (); + if (module_non_local_exit_check (env) != emacs_funcall_exit_return) + return; + Lisp_Object lisp = value_to_lisp (uptr); + if (! USER_PTRP (lisp)) + module_wrong_type (env, Quser_ptr, lisp); + XUSER_PTR (lisp)->p = ptr; +} + +static emacs_finalizer_function +module_get_user_finalizer (emacs_env *env, emacs_value uptr) +{ + MODULE_FUNCTION_BEGIN (NULL); + Lisp_Object lisp = value_to_lisp (uptr); + if (! USER_PTRP (lisp)) + { + module_wrong_type (env, Quser_ptr, lisp); + return NULL; + } + return XUSER_PTR (lisp)->finalizer; +} + +static void +module_set_user_finalizer (emacs_env *env, emacs_value uptr, + emacs_finalizer_function fin) +{ + /* FIXME: This function should return bool because it can fail. */ + MODULE_FUNCTION_BEGIN (); + Lisp_Object lisp = value_to_lisp (uptr); + if (! USER_PTRP (lisp)) + module_wrong_type (env, Quser_ptr, lisp); + XUSER_PTR (lisp)->finalizer = fin; +} + +static void +module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) +{ + /* FIXME: This function should return bool because it can fail. */ + MODULE_FUNCTION_BEGIN (); + Lisp_Object lvec = value_to_lisp (vec); + if (! VECTORP (lvec)) + { + module_wrong_type (env, Qvectorp, lvec); + return; + } + if (! (0 <= i && i < ASIZE (lvec))) + { + if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM) + module_args_out_of_range (env, lvec, make_number (i)); + else + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return; + } + ASET (lvec, i, value_to_lisp (val)); +} + +static emacs_value +module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) +{ + MODULE_FUNCTION_BEGIN (module_nil); + Lisp_Object lvec = value_to_lisp (vec); + if (! VECTORP (lvec)) + { + module_wrong_type (env, Qvectorp, lvec); + return module_nil; + } + if (! (0 <= i && i < ASIZE (lvec))) + { + if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM) + module_args_out_of_range (env, lvec, make_number (i)); + else + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return module_nil; + } + return lisp_to_value (AREF (lvec, i)); +} + +static ptrdiff_t +module_vec_size (emacs_env *env, emacs_value vec) +{ + /* FIXME: Return a sentinel value (e.g., -1) on error. */ + MODULE_FUNCTION_BEGIN (0); + Lisp_Object lvec = value_to_lisp (vec); + if (! VECTORP (lvec)) + { + module_wrong_type (env, Qvectorp, lvec); + return 0; + } + return ASIZE (lvec); +} + + +/* Subroutines. */ + +DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, + doc: /* Load module FILE. */) + (Lisp_Object file) +{ + dynlib_handle_ptr handle; + emacs_init_function module_init; + void *gpl_sym; + + CHECK_STRING (file); + handle = dynlib_open (SSDATA (file)); + if (!handle) + error ("Cannot load file %s: %s", SDATA (file), dynlib_error ()); + + gpl_sym = dynlib_sym (handle, "plugin_is_GPL_compatible"); + if (!gpl_sym) + error ("Module %s is not GPL compatible", SDATA (file)); + + module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init"); + if (!module_init) + error ("Module %s does not have an init function.", SDATA (file)); + + struct emacs_runtime_private rt; /* Includes the public emacs_env. */ + struct emacs_env_private priv; + initialize_environment (&rt.pub, &priv); + struct emacs_runtime pub = + { + .size = sizeof pub, + .private_members = &rt, + .get_environment = module_get_environment + }; + int r = module_init (&pub); + finalize_environment (&priv); + + if (r != 0) + { + if (! (MOST_NEGATIVE_FIXNUM <= r && r <= MOST_POSITIVE_FIXNUM)) + xsignal0 (Qoverflow_error); + xsignal2 (Qmodule_load_failed, file, make_number (r)); + } + + return Qt; +} + +DEFUN ("internal--module-call", Finternal_module_call, Sinternal_module_call, 1, MANY, 0, + doc: /* Internal function to call a module function. +ENVOBJ is a save pointer to a module_fun_env structure. +ARGLIST is a list of arguments passed to SUBRPTR. +usage: (module-call ENVOBJ &rest ARGLIST) */) + (ptrdiff_t nargs, Lisp_Object *arglist) +{ + Lisp_Object envobj = arglist[0]; + /* FIXME: Rather than use a save_value, we should create a new object type. + Making save_value visible to Lisp is wrong. */ + CHECK_TYPE (SAVE_VALUEP (envobj), Qsave_value_p, envobj); + struct Lisp_Save_Value *save_value = XSAVE_VALUE (envobj); + CHECK_TYPE (save_type (save_value, 0) == SAVE_POINTER, Qsave_pointer_p, envobj); + /* FIXME: We have no reason to believe that XSAVE_POINTER (envobj, 0) + is a module_fun_env pointer. If some other part of Emacs also + exports save_value objects to Elisp, than we may be getting here this + other kind of save_value which will likely hold something completely + different in this field. */ + struct module_fun_env *envptr = XSAVE_POINTER (envobj, 0); + EMACS_INT len = nargs - 1; + eassume (0 <= envptr->min_arity); + if (! (envptr->min_arity <= len + && len <= (envptr->max_arity < 0 ? PTRDIFF_MAX : envptr->max_arity))) + xsignal2 (Qwrong_number_of_arguments, module_format_fun_env (envptr), + make_number (len)); + + emacs_env pub; + struct emacs_env_private priv; + initialize_environment (&pub, &priv); + + USE_SAFE_ALLOCA; + emacs_value *args; + if (plain_values) + args = (emacs_value *) arglist + 1; + else + { + args = SAFE_ALLOCA (len * sizeof *args); + for (ptrdiff_t i = 0; i < len; i++) + args[i] = lisp_to_value (arglist[i + 1]); + } + + emacs_value ret = envptr->subr (&pub, len, args, envptr->data); + SAFE_FREE (); + + eassert (&priv == pub.private_members); + + switch (priv.pending_non_local_exit) + { + case emacs_funcall_exit_return: + finalize_environment (&priv); + return value_to_lisp (ret); + case emacs_funcall_exit_signal: + { + Lisp_Object symbol = priv.non_local_exit_symbol; + Lisp_Object data = priv.non_local_exit_data; + finalize_environment (&priv); + xsignal (symbol, data); + } + case emacs_funcall_exit_throw: + { + Lisp_Object tag = priv.non_local_exit_symbol; + Lisp_Object value = priv.non_local_exit_data; + finalize_environment (&priv); + Fthrow (tag, value); + } + default: + eassume (false); + } +} + + +/* Helper functions. */ + +static void +check_main_thread (void) +{ +#ifdef HAVE_PTHREAD + eassert (pthread_equal (pthread_self (), main_thread)); +#elif defined WINDOWSNT + eassert (GetCurrentThreadId () == main_thread); +#endif +} + +static void +module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym, + Lisp_Object data) +{ + struct emacs_env_private *p = env->private_members; + if (p->pending_non_local_exit == emacs_funcall_exit_return) + { + p->pending_non_local_exit = emacs_funcall_exit_signal; + p->non_local_exit_symbol = sym; + p->non_local_exit_data = data; + } +} + +static void +module_non_local_exit_throw_1 (emacs_env *env, Lisp_Object tag, + Lisp_Object value) +{ + struct emacs_env_private *p = env->private_members; + if (p->pending_non_local_exit == emacs_funcall_exit_return) + { + p->pending_non_local_exit = emacs_funcall_exit_throw; + p->non_local_exit_symbol = tag; + p->non_local_exit_data = value; + } +} + +/* Module version of `wrong_type_argument'. */ +static void +module_wrong_type (emacs_env *env, Lisp_Object predicate, Lisp_Object value) +{ + module_non_local_exit_signal_1 (env, Qwrong_type_argument, + list2 (predicate, value)); +} + +/* Signal an out-of-memory condition to the caller. */ +static void +module_out_of_memory (emacs_env *env) +{ + /* TODO: Reimplement this so it works even if memory-signal-data has + been modified. */ + module_non_local_exit_signal_1 (env, XCAR (Vmemory_signal_data), + XCDR (Vmemory_signal_data)); +} + +/* Signal arguments are out of range. */ +static void +module_args_out_of_range (emacs_env *env, Lisp_Object a1, Lisp_Object a2) +{ + module_non_local_exit_signal_1 (env, Qargs_out_of_range, list2 (a1, a2)); +} + + +/* Value conversion. */ + +/* 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) +{ + intptr_t i = (intptr_t) v; + if (plain_values || USE_LSB_TAG) + return XIL (i); + + /* 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. */ + + EMACS_UINT tag = i & (GCALIGNMENT - 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. */ +static Lisp_Object +value_to_lisp (emacs_value v) +{ + Lisp_Object o = value_to_lisp_bits (v); + if (! plain_values && CONSP (o) && EQ (XCDR (o), ltv_mark)) + o = XCAR (o); + return o; +} + +/* Attempt to convert O to an emacs_value. Do not do any checking or + 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_bits (Lisp_Object o) +{ + EMACS_UINT u = XLI (o); + + /* Compress U into the space of a pointer, possibly losing information. */ + uintptr_t p = (plain_values || USE_LSB_TAG + ? u + : (INTEGERP (o) ? u << VALBITS : u & VALMASK) + XTYPE (o)); + return (emacs_value) p; +} + +#ifndef HAVE_STRUCT_ATTRIBUTE_ALIGNED +enum { HAVE_STRUCT_ATTRIBUTE_ALIGNED = 0 }; +#endif + +/* 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 +lisp_to_value (Lisp_Object o) +{ + emacs_value v = lisp_to_value_bits (o); + + if (! EQ (o, value_to_lisp_bits (v))) + { + /* Package the incompressible object pointer inside a pair + that is compressible. */ + Lisp_Object pair = Fcons (o, ltv_mark); + + if (! HAVE_STRUCT_ATTRIBUTE_ALIGNED) + { + /* Keep calling Fcons until it returns a compressible pair. + This shouldn't take long. */ + while ((intptr_t) XCONS (pair) & (GCALIGNMENT - 1)) + pair = Fcons (o, pair); + + /* Plant the mark. The garbage collector will eventually + reclaim any just-allocated incompressible pairs. */ + XSETCDR (pair, ltv_mark); + } + + v = (emacs_value) ((intptr_t) XCONS (pair) + Lisp_Cons); + } + + eassert (EQ (o, value_to_lisp (v))); + return v; +} + + +/* Environment lifetime management. */ + +/* Must be called before the environment can be used. */ +static void +initialize_environment (emacs_env *env, struct emacs_env_private *priv) +{ + priv->pending_non_local_exit = emacs_funcall_exit_return; + env->size = sizeof *env; + env->private_members = priv; + env->make_global_ref = module_make_global_ref; + env->free_global_ref = module_free_global_ref; + env->non_local_exit_check = module_non_local_exit_check; + env->non_local_exit_clear = module_non_local_exit_clear; + env->non_local_exit_get = module_non_local_exit_get; + env->non_local_exit_signal = module_non_local_exit_signal; + env->non_local_exit_throw = module_non_local_exit_throw; + env->make_function = module_make_function; + env->funcall = module_funcall; + env->intern = module_intern; + env->type_of = module_type_of; + env->is_not_nil = module_is_not_nil; + env->eq = module_eq; + env->extract_integer = module_extract_integer; + env->make_integer = module_make_integer; + env->extract_float = module_extract_float; + env->make_float = module_make_float; + env->copy_string_contents = module_copy_string_contents; + env->make_string = module_make_string; + env->make_user_ptr = module_make_user_ptr; + env->get_user_ptr = module_get_user_ptr; + env->set_user_ptr = module_set_user_ptr; + env->get_user_finalizer = module_get_user_finalizer; + env->set_user_finalizer = module_set_user_finalizer; + env->vec_set = module_vec_set; + env->vec_get = module_vec_get; + env->vec_size = module_vec_size; + Vmodule_environments = Fcons (make_save_ptr (env), Vmodule_environments); +} + +/* Must be called before the lifetime of the environment object + ends. */ +static void +finalize_environment (struct emacs_env_private *env) +{ + Vmodule_environments = XCDR (Vmodule_environments); +} + + +/* Non-local exit handling. */ + +/* Must be called after setting up a handler immediately before + returning from the function. See the comments in lisp.h and the + code in eval.c for details. The macros below arrange for this + function to be called automatically. DUMMY is ignored. */ +static void +module_reset_handlerlist (const int *dummy) +{ + handlerlist = handlerlist->next; +} + +/* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets + stored in the environment. Set the pending non-local exit flag. */ +static void +module_handle_signal (emacs_env *env, Lisp_Object err) +{ + module_non_local_exit_signal_1 (env, XCAR (err), XCDR (err)); +} + +/* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets + stored in the environment. Set the pending non-local exit flag. */ +static void +module_handle_throw (emacs_env *env, Lisp_Object tag_val) +{ + module_non_local_exit_throw_1 (env, XCAR (tag_val), XCDR (tag_val)); +} + + +/* Function environments. */ + +/* Return a string object that contains a user-friendly + representation of the function environment. */ +static Lisp_Object +module_format_fun_env (const struct module_fun_env *env) +{ + /* Try to print a function name if possible. */ + const char *path, *sym; + static char const noaddr_format[] = "#<module function at %p>"; + char buffer[sizeof noaddr_format + INT_STRLEN_BOUND (intptr_t) + 256]; + char *buf = buffer; + ptrdiff_t bufsize = sizeof buffer; + ptrdiff_t size + = (dynlib_addr (env->subr, &path, &sym) + ? exprintf (&buf, &bufsize, buffer, -1, + "#<module function %s from %s>", sym, path) + : sprintf (buffer, noaddr_format, env->subr)); + Lisp_Object unibyte_result = make_unibyte_string (buffer, size); + if (buf != buffer) + xfree (buf); + return code_convert_string_norecord (unibyte_result, Qutf_8, false); +} + + +/* Segment initializer. */ + +void +syms_of_module (void) +{ + if (!plain_values) + ltv_mark = Fcons (Qnil, Qnil); + 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. */); + + Vmodule_refs_hash + = make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE), + make_float (DEFAULT_REHASH_SIZE), + make_float (DEFAULT_REHASH_THRESHOLD), + Qnil); + Funintern (Qmodule_refs_hash, Qnil); + + DEFSYM (Qmodule_environments, "module-environments"); + DEFVAR_LISP ("module-environments", Vmodule_environments, + doc: /* List of active module environments. */); + Vmodule_environments = Qnil; + /* Unintern `module-environments' because it is only used + internally. */ + Funintern (Qmodule_environments, Qnil); + + DEFSYM (Qmodule_load_failed, "module-load-failed"); + Fput (Qmodule_load_failed, Qerror_conditions, + listn (CONSTYPE_PURE, 2, Qmodule_load_failed, Qerror)); + Fput (Qmodule_load_failed, Qerror_message, + build_pure_c_string ("Module load failed")); + + DEFSYM (Qinvalid_module_call, "invalid-module-call"); + Fput (Qinvalid_module_call, Qerror_conditions, + listn (CONSTYPE_PURE, 2, Qinvalid_module_call, Qerror)); + Fput (Qinvalid_module_call, Qerror_message, + build_pure_c_string ("Invalid module call")); + + DEFSYM (Qinvalid_arity, "invalid-arity"); + Fput (Qinvalid_arity, Qerror_conditions, + listn (CONSTYPE_PURE, 2, Qinvalid_arity, Qerror)); + Fput (Qinvalid_arity, Qerror_message, + build_pure_c_string ("Invalid function arity")); + + /* Unintern `module-refs-hash' because it is internal-only and Lisp + code or modules should not access it. */ + Funintern (Qmodule_refs_hash, Qnil); + + DEFSYM (Qsave_value_p, "save-value-p"); + DEFSYM (Qsave_pointer_p, "save-pointer-p"); + + defsubr (&Smodule_load); + + DEFSYM (Qinternal_module_call, "internal--module-call"); + defsubr (&Sinternal_module_call); +} + +/* Unlike syms_of_module, this initializer is called even from an + initialized (dumped) Emacs. */ + +void +module_init (void) +{ + /* It is not guaranteed that dynamic initializers run in the main thread, + therefore detect the main thread here. */ +#ifdef HAVE_PTHREAD + main_thread = pthread_self (); +#elif defined WINDOWSNT + /* The 'main' function already recorded the main thread's thread ID, + so we need just to use it . */ + main_thread = dwMainThreadId; +#endif +} |