/* emacs-module.c - Module loading and runtime implementation
-Copyright (C) 2015 Free Software Foundation, Inc.
+Copyright (C) 2015-2016 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.
+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
\f
/* Feature tests. */
-/* True if __attribute__ ((cleanup (...))) works, false otherwise. */
-#ifdef HAVE_VAR_ATTRIBUTE_CLEANUP
+#if __has_attribute (cleanup)
enum { module_has_cleanup = true };
#else
enum { module_has_cleanup = false };
/* Handle to the main thread. Used to verify that modules call us in
the right thread. */
-#ifdef HAVE_THREADS_H
-# include <threads.h>
-static thrd_t main_thread;
-#elif defined HAVE_PTHREAD
+#ifdef HAVE_PTHREAD
# include <pthread.h>
static pthread_t main_thread;
#elif defined WINDOWSNT
static DWORD main_thread;
#endif
-\f
-/* 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;
+/* 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 module user-pointer finalizers. These
+ should not throw C++ exceptions, so emacs-module.h declares the
+ corresponding interfaces with EMACS_NOEXCEPT. There is only C code
+ in this module, though, so this constraint is not enforced here. */
+typedef void (*emacs_finalizer_function) (void *);
\f
/* Private runtime and environment members. */
/* 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;
-
- struct emacs_value_storage storage;
-};
-
-/* Combine public and private parts in one structure. This structure
- is used whenever an environment is created. */
-struct env_storage
-{
- emacs_env pub;
- struct emacs_env_private priv;
+ 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
{
- struct env_storage environment;
+ /* 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;
};
-
\f
/* Forward declarations. */
static Lisp_Object module_format_fun_env (const struct module_fun_env *);
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 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 env_storage *);
-static void initialize_environment (struct env_storage *);
+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_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;
\f
/* 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
passing information to the handler functions. */
/* Place this macro at the beginning of a function returning a number
- or a pointer to handle signals. The function must have an ENV
- parameter. The function will return 0 (or NULL) if a signal is
- caught. */
-#define MODULE_HANDLE_SIGNALS MODULE_HANDLE_SIGNALS_RETURN (0)
-
-/* Place this macro at the beginning of a function returning void to
- handle signals. The function must have an ENV parameter. */
-#define MODULE_HANDLE_SIGNALS_VOID MODULE_HANDLE_SIGNALS_RETURN ()
-
-#define MODULE_HANDLE_SIGNALS_RETURN(retval) \
- MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval)
-
-/* Place this macro at the beginning of a function returning a pointer
- to handle non-local exits via `throw'. The function must have an
- ENV parameter. The function will return NULL if a `throw' is
- caught. */
-#define MODULE_HANDLE_THROW \
- MODULE_SETJMP (CATCHER_ALL, module_handle_throw, NULL)
+ 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, \
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) \
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); \
+ if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
+ return retval; \
struct handler *c = push_handler_nosignal (Qt, handlertype); \
if (!c) \
{ \
/* 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
- `module-call'. Its members correspond to the arguments given to
- `module_make_function'. */
+ `internal--module-call'. Its members correspond to the arguments
+ given to `module_make_function'. */
struct module_fun_env
{
void *data;
};
-/* The function definition of `module-call'. `module-call' is
- uninterned because user code couldn't meaningfully use it, so keep
- its definition around somewhere else. */
-static Lisp_Object module_call_func;
-
\f
-/* Implementation of runtime and environment functions. */
+/* 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
module_get_environment (struct emacs_runtime *ert)
{
check_main_thread ();
- return &ert->private_members->environment.pub;
+ return &ert->private_members->pub;
}
/* To make global refs (GC-protected global values) keep a hash that
static emacs_value
module_make_global_ref (emacs_env *env, emacs_value ref)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
- MODULE_HANDLE_SIGNALS;
+ 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;
if (refcount > MOST_POSITIVE_FIXNUM)
{
module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
- return NULL;
+ return module_nil;
}
value = make_natnum (refcount);
set_hash_value_slot (h, i, value);
hash_put (h, new_obj, make_natnum (1), hashcode);
}
- return allocate_emacs_value (env, &global_storage, new_obj);
+ return lisp_to_value (new_obj);
}
static void
module_free_global_ref (emacs_env *env, emacs_value ref)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
/* TODO: This probably never signals. */
/* FIXME: Wait a minute. Shouldn't this function report an error if
the hash lookup fails? */
- MODULE_HANDLE_SIGNALS_VOID;
+ MODULE_FUNCTION_BEGIN ();
struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
Lisp_Object obj = value_to_lisp (ref);
EMACS_UINT hashcode;
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 (p->non_local_exit_symbol);
+ *data = lisp_to_value (p->non_local_exit_data);
}
return p->pending_non_local_exit;
}
module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data)
{
check_main_thread ();
- eassert (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));
+ 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 ();
- eassert (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));
+ 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 `module-call',
- passing the function pointer of the module function along with the
- module emacs_env pointer as arguments.
+/* 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)
- (module-call envobj 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)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
- MODULE_HANDLE_SIGNALS;
+ MODULE_FUNCTION_BEGIN (module_nil);
if (! (0 <= min_arity
&& (max_arity < 0
? 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,
- list3 (module_call_func,
+ list4 (Qapply,
+ list2 (Qfunction, Qinternal_module_call),
envobj,
Qargs));
- return lisp_to_value (env, ret);
+ return lisp_to_value (ret);
}
static emacs_value
module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs,
emacs_value args[])
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
- MODULE_HANDLE_SIGNALS;
- MODULE_HANDLE_THROW;
+ 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. */
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 (env, Ffuncall (nargs + 1, newargs));
+ 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)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
- MODULE_HANDLE_SIGNALS;
- return lisp_to_value (env, intern (name));
+ MODULE_FUNCTION_BEGIN (module_nil);
+ return lisp_to_value (intern (name));
}
static emacs_value
module_type_of (emacs_env *env, emacs_value value)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
- return lisp_to_value (env, Ftype_of (value_to_lisp (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 ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ if (module_non_local_exit_check (env) != emacs_funcall_exit_return)
+ return false;
return ! NILP (value_to_lisp (value));
}
module_eq (emacs_env *env, emacs_value a, emacs_value b)
{
check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ 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)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ MODULE_FUNCTION_BEGIN (0);
Lisp_Object l = value_to_lisp (n);
if (! INTEGERP (l))
{
static emacs_value
module_make_integer (emacs_env *env, intmax_t n)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ 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 NULL;
+ return module_nil;
}
- return lisp_to_value (env, make_number (n));
+ return lisp_to_value (make_number (n));
}
static double
module_extract_float (emacs_env *env, emacs_value f)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ MODULE_FUNCTION_BEGIN (0);
Lisp_Object lisp = value_to_lisp (f);
if (! FLOATP (lisp))
{
static emacs_value
module_make_float (emacs_env *env, double d)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
- MODULE_HANDLE_SIGNALS;
- return lisp_to_value (env, make_float (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)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
- MODULE_HANDLE_SIGNALS;
+ MODULE_FUNCTION_BEGIN (false);
Lisp_Object lisp_str = value_to_lisp (value);
if (! STRINGP (lisp_str))
{
static emacs_value
module_make_string (emacs_env *env, const char *str, ptrdiff_t length)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
- MODULE_HANDLE_SIGNALS;
+ MODULE_FUNCTION_BEGIN (module_nil);
if (length > STRING_BYTES_BOUND)
{
module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
- return NULL;
+ return module_nil;
}
Lisp_Object lstr = make_unibyte_string (str, length);
- return lisp_to_value (env,
- code_convert_string_norecord (lstr, Qutf_8, false));
+ 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)
{
- check_main_thread ();
- return lisp_to_value (env, make_user_ptr (fin, 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)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ MODULE_FUNCTION_BEGIN (NULL);
Lisp_Object lisp = value_to_lisp (uptr);
if (! USER_PTRP (lisp))
{
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 ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ 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);
static emacs_finalizer_function
module_get_user_finalizer (emacs_env *env, emacs_value uptr)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ MODULE_FUNCTION_BEGIN (NULL);
Lisp_Object lisp = value_to_lisp (uptr);
if (! USER_PTRP (lisp))
{
module_set_user_finalizer (emacs_env *env, emacs_value uptr,
emacs_finalizer_function fin)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ /* 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);
static void
module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ /* FIXME: This function should return bool because it can fail. */
+ MODULE_FUNCTION_BEGIN ();
Lisp_Object lvec = value_to_lisp (vec);
if (! VECTORP (lvec))
{
static emacs_value
module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ MODULE_FUNCTION_BEGIN (module_nil);
Lisp_Object lvec = value_to_lisp (vec);
if (! VECTORP (lvec))
{
module_wrong_type (env, Qvectorp, lvec);
- return NULL;
+ return module_nil;
}
if (! (0 <= i && i < ASIZE (lvec)))
{
module_args_out_of_range (env, lvec, make_number (i));
else
module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
- return NULL;
+ return module_nil;
}
- return lisp_to_value (env, AREF (lvec, i));
+ return lisp_to_value (AREF (lvec, i));
}
static ptrdiff_t
module_vec_size (emacs_env *env, emacs_value vec)
{
- check_main_thread ();
- eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return);
+ /* FIXME: Return a sentinel value (e.g., -1) on error. */
+ MODULE_FUNCTION_BEGIN (0);
Lisp_Object lvec = value_to_lisp (vec);
if (! VECTORP (lvec))
{
if (!module_init)
error ("Module %s does not have an init function.", SDATA (file));
- struct emacs_runtime_private priv;
+ 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 = &priv,
+ .private_members = &rt,
.get_environment = module_get_environment
};
- initialize_environment (&priv.environment);
int r = module_init (&pub);
- finalize_environment (&priv.environment);
+ finalize_environment (&priv);
if (r != 0)
{
return Qt;
}
-DEFUN ("module-call", Fmodule_call, Smodule_call, 2, 2, 0,
+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. */)
- (Lisp_Object envobj, Lisp_Object arglist)
+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 = XFASTINT (Flength (arglist));
+ 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));
- struct env_storage env;
- initialize_environment (&env);
-
- emacs_value *args = xnmalloc (len, sizeof *args);
+ emacs_env pub;
+ struct emacs_env_private priv;
+ initialize_environment (&pub, &priv);
- for (ptrdiff_t i = 0; i < len; i++)
+ USE_SAFE_ALLOCA;
+ emacs_value *args;
+ if (plain_values)
+ args = (emacs_value *) arglist + 1;
+ else
{
- args[i] = lisp_to_value (&env.pub, XCAR (arglist));
- if (! args[i])
- memory_full (sizeof *args[i]);
- arglist = XCDR (arglist);
+ 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 (&env.pub, len, args, envptr->data);
- xfree (args);
+ emacs_value ret = envptr->subr (&pub, len, args, envptr->data);
+ SAFE_FREE ();
+
+ eassert (&priv == pub.private_members);
- switch (env.priv.pending_non_local_exit)
+ switch (priv.pending_non_local_exit)
{
case emacs_funcall_exit_return:
- finalize_environment (&env);
- if (ret == NULL)
- xsignal1 (Qinvalid_module_call, module_format_fun_env (envptr));
+ finalize_environment (&priv);
return value_to_lisp (ret);
case emacs_funcall_exit_signal:
{
- Lisp_Object symbol = value_to_lisp (&env.priv.non_local_exit_symbol);
- Lisp_Object data = value_to_lisp (&env.priv.non_local_exit_data);
- finalize_environment (&env);
+ 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 = value_to_lisp (&env.priv.non_local_exit_symbol);
- Lisp_Object value = value_to_lisp (&env.priv.non_local_exit_data);
- finalize_environment (&env);
+ Lisp_Object tag = priv.non_local_exit_symbol;
+ Lisp_Object value = priv.non_local_exit_data;
+ finalize_environment (&priv);
Fthrow (tag, value);
}
default:
static void
check_main_thread (void)
{
-#ifdef HAVE_THREADS_H
- eassert (thrd_equal (thdr_current (), main_thread));
-#elif defined HAVE_PTHREAD
+#ifdef HAVE_PTHREAD
eassert (pthread_equal (pthread_self (), main_thread));
#elif defined WINDOWSNT
eassert (GetCurrentThreadId () == main_thread);
Lisp_Object data)
{
struct emacs_env_private *p = env->private_members;
- eassert (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;
+ 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
Lisp_Object value)
{
struct emacs_env_private *p = env->private_members;
- eassert (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;
+ 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'. */
\f
/* Value conversion. */
-/* Convert an `emacs_value' to the corresponding internal object.
- Never fails. */
+/* 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 (emacs_value v)
+value_to_lisp_bits (emacs_value v)
{
- return v->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;
+ }
+ }
-/* Convert an internal object to an `emacs_value'. Allocate storage
- from the environment; return NULL if allocation fails. */
-static emacs_value
-lisp_to_value (emacs_env *env, 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);
+ return XIL ((tag << VALBITS) + untagged);
}
-\f
-/* Memory management. */
-
-/* Must be called for each frame before it can be used for allocation. */
-static void
-initialize_frame (struct emacs_value_frame *frame)
+/* 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)
{
- frame->offset = 0;
- frame->next = NULL;
+ Lisp_Object o = value_to_lisp_bits (v);
+ if (! plain_values && CONSP (o) && EQ (XCDR (o), ltv_mark))
+ o = XCAR (o);
+ return o;
}
-/* Must be called for any storage object before it can be used for
- allocation. */
-static void
-initialize_storage (struct emacs_value_storage *storage)
+/* 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)
{
- initialize_frame (&storage->initial);
- storage->current = &storage->initial;
-}
+ EMACS_UINT u = XLI (o);
-/* 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)
- {
- struct emacs_value_frame *current = next;
- next = current->next;
- free (current);
- }
+ /* 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;
}
-/* Allocate a new value from STORAGE and stores OBJ in it. Return
- NULL if allocation fails and use ENV for non local exit reporting. */
+#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
-allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage,
- Lisp_Object obj)
+lisp_to_value (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)
- {
- 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;
- }
- emacs_value value = storage->current->objects + storage->current->offset;
- value->v = obj;
- ++storage->current->offset;
- return value;
-}
+ emacs_value v = lisp_to_value_bits (o);
-/* 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))
+ if (! EQ (o, value_to_lisp_bits (v)))
{
- struct env_storage *env = XSAVE_POINTER (tem, 0);
- for (struct emacs_value_frame *frame = &env->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);
+
+ 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;
}
\f
/* Must be called before the environment can be used. */
static void
-initialize_environment (struct env_storage *env)
+initialize_environment (emacs_env *env, struct emacs_env_private *priv)
{
- env->priv.pending_non_local_exit = emacs_funcall_exit_return;
- initialize_storage (&env->priv.storage);
- env->pub.size = sizeof env->pub;
- env->pub.private_members = &env->priv;
- env->pub.make_global_ref = module_make_global_ref;
- env->pub.free_global_ref = module_free_global_ref;
- env->pub.non_local_exit_check = module_non_local_exit_check;
- env->pub.non_local_exit_clear = module_non_local_exit_clear;
- env->pub.non_local_exit_get = module_non_local_exit_get;
- env->pub.non_local_exit_signal = module_non_local_exit_signal;
- env->pub.non_local_exit_throw = module_non_local_exit_throw;
- env->pub.make_function = module_make_function;
- env->pub.funcall = module_funcall;
- env->pub.intern = module_intern;
- env->pub.type_of = module_type_of;
- env->pub.is_not_nil = module_is_not_nil;
- env->pub.eq = module_eq;
- env->pub.extract_integer = module_extract_integer;
- env->pub.make_integer = module_make_integer;
- env->pub.extract_float = module_extract_float;
- env->pub.make_float = module_make_float;
- env->pub.copy_string_contents = module_copy_string_contents;
- env->pub.make_string = module_make_string;
- env->pub.make_user_ptr = module_make_user_ptr;
- env->pub.get_user_ptr = module_get_user_ptr;
- env->pub.set_user_ptr = module_set_user_ptr;
- env->pub.get_user_finalizer = module_get_user_finalizer;
- env->pub.set_user_finalizer = module_set_user_finalizer;
- env->pub.vec_set = module_vec_set;
- env->pub.vec_get = module_vec_get;
- env->pub.vec_size = module_vec_size;
+ 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 env_storage *env)
+finalize_environment (struct emacs_env_private *env)
{
- finalize_storage (&env->priv.storage);
Vmodule_environments = XCDR (Vmodule_environments);
}
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 referrence table. */);
+ doc: /* Module global reference table. */);
Vmodule_refs_hash
= make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE),
Fput (Qinvalid_arity, Qerror_message,
build_pure_c_string ("Invalid function arity"));
- initialize_storage (&global_storage);
-
/* 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);
- /* Don't call defsubr on `module-call' because that would intern it,
- but `module-call' is an internal function that users cannot
- meaningfully use. Instead, assign its definition to a private
- variable. */
- XSETPVECTYPE (&Smodule_call, PVEC_SUBR);
- XSETSUBR (module_call_func, &Smodule_call);
+ DEFSYM (Qinternal_module_call, "internal--module-call");
+ defsubr (&Sinternal_module_call);
}
/* Unlike syms_of_module, this initializer is called even from an
{
/* It is not guaranteed that dynamic initializers run in the main thread,
therefore detect the main thread here. */
-#ifdef HAVE_THREADS_H
- main_thread = thrd_current ();
-#elif defined HAVE_PTHREAD
+#ifdef HAVE_PTHREAD
main_thread = pthread_self ();
#elif defined WINDOWSNT
/* The 'main' function already recorded the main thread's thread ID,