diff options
| -rw-r--r-- | configure.ac | 49 | ||||
| -rw-r--r-- | m4/ax_gcc_var_attribute.m4 | 141 | ||||
| -rw-r--r-- | src/Makefile.in | 9 | ||||
| -rw-r--r-- | src/alloc.c | 4 | ||||
| -rw-r--r-- | src/emacs.c | 9 | ||||
| -rw-r--r-- | src/emacs_module.h | 230 | ||||
| -rw-r--r-- | src/lisp.h | 4 | ||||
| -rw-r--r-- | src/module.c | 1185 |
8 files changed, 1628 insertions, 3 deletions
diff --git a/configure.ac b/configure.ac index cfd591c7b86..ec1f35391f5 100644 --- a/configure.ac +++ b/configure.ac @@ -353,6 +353,7 @@ OPTION_DEFAULT_ON([gsettings],[don't compile with GSettings support]) OPTION_DEFAULT_ON([selinux],[don't compile with SELinux support]) OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support]) OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support]) +OPTION_DEFAULT_OFF([modules],[compile with dynamic modules support]) AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB], [use a file notification library (LIB one of: yes, gfile, inotify, w32, no)])], @@ -2191,6 +2192,9 @@ LIBS="$LIBS_SYSTEM $LIBS" dnl FIXME replace main with a function we actually want from this library. AC_CHECK_LIB(Xbsd, main, LD_SWITCH_X_SITE="$LD_SWITCH_X_SITE -lXbsd") +dnl Check for C11 threads. +AC_CHECK_HEADERS_ONCE(threads.h) + dnl Check for the POSIX thread library. LIB_PTHREAD= AC_CHECK_HEADERS_ONCE(pthread.h) @@ -3285,6 +3289,48 @@ if test "${HAVE_ZLIB}" = "yes"; then fi AC_SUBST(LIBZ) +### Dynamic modules support +LIBMODULES= +HAVE_MODULES=no +MODULES_OBJ= +MODULES_SUFFIX= +if test "${with_modules}" != "no"; then + if test "$opsys" = "gnu-linux"; then + LIBMODULES="-ldl" + MODULES_SUFFIX=".so" + HAVE_MODULES=yes + elif test "$opsys" = "cygwin"; then + # XXX: not tested + LIBMODULES="-lcygwin" + MODULES_SUFFIX=".dll" + HAVE_MODULES=yes + elif test "$opsys" = "darwin"; then + MODULES_SUFFIX=".so" + HAVE_MODULES=yes + elif test "$opsys" = "mingw32"; then + MODULES_SUFFIX=".dll" + HAVE_MODULES=yes + else + # BSD system have dlopen in the libc + AC_CHECK_FUNC(dlopen, [MODULES_SUFFIX=".so"] + [HAVE_MODULES=yes], []) + fi + + if test "${HAVE_MODULES}" = no; then + AC_MSG_ERROR([Dynamic modules are not supported on your system]) + fi +fi + +if test "${HAVE_MODULES}" = yes; then + MODULES_OBJ="dynlib.o module.o" + AC_DEFINE(HAVE_MODULES, 1, [Define to 1 if dynamic modules are enabled]) + AC_DEFINE_UNQUOTED(MODULES_SUFFIX, "$MODULES_SUFFIX", [System extension for dynamic libraries]) +fi +AC_SUBST(MODULES_OBJ) +AC_SUBST(LIBMODULES) +AX_GCC_VAR_ATTRIBUTE(cleanup) +AC_CHECK_FUNCS(dladdr) + ### Use -lpng if available, unless '--with-png=no'. HAVE_PNG=no LIBPNG= @@ -5175,7 +5221,7 @@ optsep= emacs_config_features= for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \ - LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT X11 NS; do + LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT X11 NS MODULES; do case $opt in NOTIFY|ACL) eval val=\${${opt}_SUMMARY} ;; @@ -5223,6 +5269,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs use -lotf? ${HAVE_LIBOTF} Does Emacs use -lxft? ${HAVE_XFT} Does Emacs directly use zlib? ${HAVE_ZLIB} + Does Emacs has dynamic modules support? ${HAVE_MODULES} Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS} "]) diff --git a/m4/ax_gcc_var_attribute.m4 b/m4/ax_gcc_var_attribute.m4 new file mode 100644 index 00000000000..247cc4ab3eb --- /dev/null +++ b/m4/ax_gcc_var_attribute.m4 @@ -0,0 +1,141 @@ +# =========================================================================== +# http://www.gnu.org/software/autoconf-archive/ax_gcc_var_attribute.html +# =========================================================================== +# +# SYNOPSIS +# +# AX_GCC_VAR_ATTRIBUTE(ATTRIBUTE) +# +# DESCRIPTION +# +# This macro checks if the compiler supports one of GCC's variable +# attributes; many other compilers also provide variable attributes with +# the same syntax. Compiler warnings are used to detect supported +# attributes as unsupported ones are ignored by default so quieting +# warnings when using this macro will yield false positives. +# +# The ATTRIBUTE parameter holds the name of the attribute to be checked. +# +# If ATTRIBUTE is supported define HAVE_VAR_ATTRIBUTE_<ATTRIBUTE>. +# +# The macro caches its result in the ax_cv_have_var_attribute_<attribute> +# variable. +# +# The macro currently supports the following variable attributes: +# +# aligned +# cleanup +# common +# nocommon +# deprecated +# mode +# packed +# tls_model +# unused +# used +# vector_size +# weak +# dllimport +# dllexport +# init_priority +# +# Unsuppored variable attributes will be tested against a global integer +# variable and without any arguments given to the attribute itself; the +# result of this check might be wrong or meaningless so use with care. +# +# LICENSE +# +# Copyright (c) 2013 Gabriele Svelto <gabriele.svelto@gmail.com> +# +# Copying and distribution of this file, with or without modification, are +# permitted in any medium without royalty provided the copyright notice +# and this notice are preserved. This file is offered as-is, without any +# warranty. + +#serial 3 + +AC_DEFUN([AX_GCC_VAR_ATTRIBUTE], [ + AS_VAR_PUSHDEF([ac_var], [ax_cv_have_var_attribute_$1]) + + AC_CACHE_CHECK([for __attribute__(($1))], [ac_var], [ + AC_LINK_IFELSE([AC_LANG_PROGRAM([ + m4_case([$1], + [aligned], [ + int foo __attribute__(($1(32))); + ], + [cleanup], [ + int bar(int *t) { return *t; }; + ], + [common], [ + int foo __attribute__(($1)); + ], + [nocommon], [ + int foo __attribute__(($1)); + ], + [deprecated], [ + int foo __attribute__(($1)) = 0; + ], + [mode], [ + long foo __attribute__(($1(word))); + ], + [packed], [ + struct bar { + int baz __attribute__(($1)); + }; + ], + [tls_model], [ + __thread int bar1 __attribute__(($1("global-dynamic"))); + __thread int bar2 __attribute__(($1("local-dynamic"))); + __thread int bar3 __attribute__(($1("initial-exec"))); + __thread int bar4 __attribute__(($1("local-exec"))); + ], + [unused], [ + int foo __attribute__(($1)); + ], + [used], [ + int foo __attribute__(($1)); + ], + [vector_size], [ + int foo __attribute__(($1(16))); + ], + [weak], [ + int foo __attribute__(($1)); + ], + [dllimport], [ + int foo __attribute__(($1)); + ], + [dllexport], [ + int foo __attribute__(($1)); + ], + [init_priority], [ + struct bar { bar() {} ~bar() {} }; + bar b __attribute__(($1(65535/2))); + ], + [ + m4_warn([syntax], [Unsupported attribute $1, the test may fail]) + int foo __attribute__(($1)); + ] + )], [ + m4_case([$1], + [cleanup], [ + int foo __attribute__(($1(bar))) = 0; + foo = foo + 1; + ], + [] + )]) + ], + dnl GCC doesn't exit with an error if an unknown attribute is + dnl provided but only outputs a warning, so accept the attribute + dnl only if no warning were issued. + [AS_IF([test -s conftest.err], + [AS_VAR_SET([ac_var], [no])], + [AS_VAR_SET([ac_var], [yes])])], + [AS_VAR_SET([ac_var], [no])]) + ]) + + AS_IF([test yes = AS_VAR_GET([ac_var])], + [AC_DEFINE_UNQUOTED(AS_TR_CPP(HAVE_VAR_ATTRIBUTE_$1), 1, + [Define to 1 if the system has the `$1' variable attribute])], []) + + AS_VAR_POPDEF([ac_var]) +]) diff --git a/src/Makefile.in b/src/Makefile.in index d667c55ee33..15171d43668 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -230,6 +230,11 @@ LIBXML2_CFLAGS = @LIBXML2_CFLAGS@ LIBZ = @LIBZ@ +## system-specific libs for dynamic modules, else empty +LIBMODULES = @LIBMODULES@ +## dynlib.o module.o if modules enabled, else empty +MODULES_OBJ = @MODULES_OBJ@ + XRANDR_LIBS = @XRANDR_LIBS@ XRANDR_CFLAGS = @XRANDR_CFLAGS@ @@ -377,7 +382,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ minibuf.o fileio.o dired.o \ cmds.o casetab.o casefiddle.o indent.o search.o regex.o undo.o \ alloc.o data.o doc.o editfns.o callint.o \ - eval.o floatfns.o fns.o font.o print.o lread.o \ + eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ syntax.o $(UNEXEC_OBJ) bytecode.o \ process.o gnutls.o callproc.o \ region-cache.o sound.o atimer.o \ @@ -468,7 +473,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) \ - $(GFILENOTIFY_LIBS) $(LIB_MATH) $(LIBZ) + $(GFILENOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(leimdir)/leim-list.el: bootstrap-emacs$(EXEEXT) $(MAKE) -C ../leim leim-list.el EMACS="$(bootstrap_exe)" diff --git a/src/alloc.c b/src/alloc.c index 48ce3f120f5..53f974533a8 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -5574,6 +5574,10 @@ garbage_collect_1 (void *end) mark_fringe_data (); #endif +#ifdef HAVE_MODULES + mark_modules (); +#endif + /* Everything is now marked, except for the data in font caches, undo lists, and finalizers. The first two are compacted by removing an items which aren't reachable otherwise. */ diff --git a/src/emacs.c b/src/emacs.c index b4052b851d7..ba71ceb84ce 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -776,6 +776,10 @@ main (int argc, char **argv) atexit (close_output_streams); +#ifdef HAVE_MODULES + module_init (); +#endif + sort_args (argc, argv); argc = 0; while (argv[argc]) argc++; @@ -1450,6 +1454,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_terminal (); syms_of_term (); syms_of_undo (); + +#ifdef HAVE_MODULES + syms_of_module (); +#endif + #ifdef HAVE_SOUND syms_of_sound (); #endif diff --git a/src/emacs_module.h b/src/emacs_module.h new file mode 100644 index 00000000000..4b774fe6584 --- /dev/null +++ b/src/emacs_module.h @@ -0,0 +1,230 @@ +/* + emacs_module.h - Module API + 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/>. +*/ + +#ifndef EMACS_MODULE_H +#define EMACS_MODULE_H + +#include <stdint.h> +#include <stdlib.h> +#include <stdbool.h> + +#ifdef __cplusplus +#define EMACS_EXTERN_C_BEGIN extern "C" { +#define EMACS_EXTERN_C_END } +#else +#define EMACS_EXTERN_C_BEGIN +#define EMACS_EXTERN_C_END +#endif + +#if defined(__cplusplus) && __cplusplus >= 201103L +#define EMACS_NOEXCEPT noexcept +#else +#define EMACS_NOEXCEPT +#endif + +EMACS_EXTERN_C_BEGIN + +/* Current environement */ +typedef struct emacs_env_25 emacs_env; + +/* Opaque structure pointer representing an Emacs Lisp value */ +typedef struct emacs_value_tag* emacs_value; + +enum emacs_arity { + emacs_variadic_function = -2 +}; + +/* Struct passed to a module init function (emacs_module_init) */ +struct emacs_runtime { + /* Structure size (for version checking) */ + size_t size; + + /* Private data; users should not touch this */ + struct emacs_runtime_private *private_members; + + /* Returns an environment pointer. */ + emacs_env* (*get_environment)(struct emacs_runtime *ert); +}; + + +/* Function prototype for the module init function */ +typedef int (*emacs_init_function)(struct emacs_runtime *ert); + +/* Function prototype for the module Lisp functions */ +typedef emacs_value (*emacs_subr)(emacs_env *env, + int nargs, + emacs_value args[], + void *data); + +/* Function prototype for module user-pointer finalizers */ +typedef void (*emacs_finalizer_function)(void*); + +/* Possible Emacs function call outcomes. */ +enum emacs_funcall_exit { + /* Function has returned normally. */ + emacs_funcall_exit_return = 0, + /* Function has signaled an error using `signal'. */ + emacs_funcall_exit_signal = 1, + /* Function has exit using `throw'. */ + emacs_funcall_exit_throw = 2, +}; + +struct emacs_env_25 { + /* + * Structure size (for version checking) + */ + + size_t size; + + /* Private data; users should not touch this */ + struct emacs_env_private *private_members; + + /* + * Memory management + */ + + + emacs_value (*make_global_ref)(emacs_env *env, + emacs_value any_reference); + + void (*free_global_ref)(emacs_env *env, + emacs_value global_reference); + + /* + * Non-local exit handling + */ + + enum emacs_funcall_exit (*non_local_exit_check)(emacs_env *env); + + void (*non_local_exit_clear)(emacs_env *env); + + enum emacs_funcall_exit (*non_local_exit_get)(emacs_env *env, + emacs_value *non_local_exit_symbol_out, + emacs_value *non_local_exit_data_out); + + void (*non_local_exit_signal)(emacs_env *env, + emacs_value non_local_exit_symbol, + emacs_value non_local_exit_data); + + void (*non_local_exit_throw)(emacs_env *env, + emacs_value tag, + emacs_value value); + + /* + * Function registration + */ + + emacs_value (*make_function)(emacs_env *env, + int min_arity, + int max_arity, + emacs_value (*function)(emacs_env*, int, emacs_value*, void*) EMACS_NOEXCEPT, + const char *documentation, + void *data); + + emacs_value (*funcall)(emacs_env *env, + emacs_value function, + int nargs, + emacs_value args[]); + + emacs_value (*intern)(emacs_env *env, + const char *symbol_name); + + /* + * Type conversion + */ + + emacs_value (*type_of)(emacs_env *env, + emacs_value value); + + bool (*is_not_nil)(emacs_env *env, emacs_value value); + + bool (*eq)(emacs_env *env, emacs_value a, emacs_value b); + + int64_t (*extract_integer)(emacs_env *env, + emacs_value value); + + emacs_value (*make_integer)(emacs_env *env, + int64_t value); + + double (*extract_float)(emacs_env *env, + emacs_value value); + + emacs_value (*make_float)(emacs_env *env, + double value); + + /* + * Copy the content of the lisp string VALUE to BUFFER as an utf8 + * null-terminated string. + * + * SIZE must point to the total size of the buffer. If BUFFER is + * NULL or if SIZE is not big enough, write the required buffer size + * to SIZE and return false. + * + * Note that SIZE must include the last null byte (e.g. "abc" needs + * a buffer of size 4). + * + * Returns true if the string was successfully copied. + */ + + bool (*copy_string_contents)(emacs_env *env, + emacs_value value, + char *buffer, + size_t *size_inout); + + /* + * Create a lisp string from a utf8 encoded string. + */ + emacs_value (*make_string)(emacs_env *env, + const char *contents, size_t length); + + /* + * Embedded pointer type + */ + emacs_value (*make_user_ptr)(emacs_env *env, + void (*fin)(void *) EMACS_NOEXCEPT, + void *ptr); + + void* (*get_user_ptr)(emacs_env *env, emacs_value uptr); + void (*set_user_ptr)(emacs_env *env, emacs_value uptr, void *ptr); + + void (*(*get_user_finalizer)(emacs_env *env, emacs_value uptr))(void *) EMACS_NOEXCEPT; + void (*set_user_finalizer)(emacs_env *env, + emacs_value uptr, + void (*fin)(void *) EMACS_NOEXCEPT); + + /* + * Vector functions + */ + emacs_value (*vec_get) (emacs_env *env, + emacs_value vec, + size_t i); + + void (*vec_set) (emacs_env *env, + emacs_value vec, + size_t i, + emacs_value val); + + size_t (*vec_size) (emacs_env *env, + emacs_value vec); +}; + +EMACS_EXTERN_C_END + +#endif /* EMACS_MODULE_H */ diff --git a/src/lisp.h b/src/lisp.h index 02c19690adf..3b6ea76943d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3916,6 +3916,10 @@ extern bool let_shadows_global_binding_p (Lisp_Object symbol); /* Defined in alloc.c. */ extern Lisp_Object make_user_ptr (void (*finalizer) (void*), void *p); +/* Defined in module.c. */ +extern void module_init (void); +extern void mark_modules (void); +extern void syms_of_module (void); #endif /* Defined in editfns.c. */ diff --git a/src/module.c b/src/module.c new file mode 100644 index 00000000000..125fd7fed26 --- /dev/null +++ b/src/module.c @@ -0,0 +1,1185 @@ +/* + 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 <stdbool.h> +#include <stddef.h> +#include <stdint.h> +#include <stdio.h> + +#include <config.h> +#include "lisp.h" +#include "emacs_module.h" +#include "dynlib.h" +#include "coding.h" +#include "verify.h" + + +/* Feature tests */ + +enum { + /* 1 if we have __attribute__((cleanup(...))), 0 otherwise */ + module_has_cleanup = +#ifdef HAVE_VAR_ATTRIBUTE_CLEANUP + 1 +#else + 0 +#endif +}; + +/* Handle to the main thread. Used to verify that modules call us in + the right thread. */ +#if defined(HAVE_THREADS_H) +#include <threads.h> +static thrd_t main_thread; +#elif defined(HAVE_PTHREAD) +#include <pthread.h> +static pthread_t main_thread; +#elif defined(WINDOWSNT) +#include <windows.h> +/* On Windows, we store a handle to the main thread instead of the + thread ID because the latter can be reused when a thread terminates. */ +static HANDLE main_thread; +#endif + + +/* Implementation of runtime and environment functions */ + +static emacs_env* module_get_environment (struct emacs_runtime *ert); + +static emacs_value module_make_global_ref (emacs_env *env, + emacs_value ref); +static void module_free_global_ref (emacs_env *env, + emacs_value ref); +static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *env); +static void module_non_local_exit_clear (emacs_env *env); +static enum emacs_funcall_exit module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data); +static void module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data); +static void module_non_local_exit_throw (emacs_env *env, emacs_value tag, emacs_value value); +static emacs_value module_make_function (emacs_env *env, + int min_arity, + int max_arity, + emacs_subr subr, + const char *documentation, + void *data); +static emacs_value module_funcall (emacs_env *env, + emacs_value fun, + int nargs, + emacs_value args[]); +static emacs_value module_intern (emacs_env *env, const char *name); +static emacs_value module_type_of (emacs_env *env, emacs_value value); +static bool module_is_not_nil (emacs_env *env, emacs_value value); +static bool module_eq (emacs_env *env, emacs_value a, emacs_value b); +static int64_t module_extract_integer (emacs_env *env, emacs_value n); +static emacs_value module_make_integer (emacs_env *env, int64_t n); +static emacs_value module_make_float (emacs_env *env, double d); +static double module_extract_float (emacs_env *env, emacs_value f); +static bool module_copy_string_contents (emacs_env *env, + emacs_value value, + char *buffer, + size_t* length); +static emacs_value module_make_string (emacs_env *env, const char *str, size_t lenght); +static emacs_value module_make_user_ptr (emacs_env *env, + emacs_finalizer_function fin, + void *ptr); +static void* module_get_user_ptr (emacs_env *env, emacs_value uptr); +static void module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr); +static emacs_finalizer_function module_get_user_finalizer (emacs_env *env, emacs_value uptr); +static void module_set_user_finalizer (emacs_env *env, + emacs_value uptr, + emacs_finalizer_function fin); + + +/* Helper functions */ + +/* If checking is enabled, abort if the current thread is not the + Emacs main thread. */ +static void check_main_thread (void); + +/* Internal versions of `module_non_local_exit_signal' and `module_non_local_exit_throw'. */ +static void module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym, Lisp_Object data); +static void module_non_local_exit_throw_1 (emacs_env *env, Lisp_Object tag, Lisp_Object value); + +/* Module version of `wrong_type_argument'. */ +static void module_wrong_type (emacs_env *env, Lisp_Object predicate, Lisp_Object value); + +/* Signal an out-of-memory condition to the caller. */ +static void module_out_of_memory (emacs_env *env); + +/* Signal arguments are out of range. */ +static void module_args_out_of_range (emacs_env *env, Lisp_Object a1, Lisp_Object a2); + + +/* Value conversion */ + +/* Converts an `emacs_value' to the corresponding internal object. + Never fails. */ +static Lisp_Object value_to_lisp (emacs_value v); + +/* Converts an internal object to an `emacs_value'. Allocates storage + from the environment; returns NULL if allocation fails. */ +static emacs_value lisp_to_value (emacs_env *env, Lisp_Object o); + + +/* 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. We 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' */ + size_t offset; + + /* Pointer to next frame, if any */ + struct emacs_value_frame *next; +}; + +/* Must be called for each frame before it can be used for + allocation. */ +static void initialize_frame (struct emacs_value_frame *frame); + +/* 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; + +/* Must be called for any storage object before it can be used for + allocation. */ +static void initialize_storage (struct emacs_value_storage *storage); + +/* Must be called for any initialized storage object before its + lifetime ends. Frees all dynamically-allocated frames. */ +static void finalize_storage (struct emacs_value_storage *storage); + +/* Allocates a new value from STORAGE and stores OBJ in it. Returns + NULL if allocations fails and uses ENV for non local exit reporting. */ +static emacs_value allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage, + Lisp_Object obj); + + +/* 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 we always + have storage 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; +}; + +/* Combines 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; +}; + +/* Must be called before the environment can be used. */ +static void initialize_environment (struct env_storage *env); + +/* Must be called before the lifetime of the environment object + ends. */ +static void finalize_environment (struct env_storage *env); + +/* The private parts of an `emacs_runtime' object contain the initial + environment. */ +struct emacs_runtime_private { + struct env_storage environment; +}; + + +/* Convenience macros for non-local exit handling */ + +/* Emacs uses setjmp(3) and longjmp(3) for non-local exits, but we + can't allow module frames to 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 we 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. We use macros so that we don't have to + write lots of additional variants of `internal_condition_case' + etc. and don't have to worry about passing information to the + handler functions. */ + +/* Called on `signal'. ERR will be a cons cell (SYMBOL . DATA), which + gets stored in the environment. Sets the pending non-local exit flag. */ +static void module_handle_signal (emacs_env *env, Lisp_Object err); + +/* Called on `throw'. TAG_VAL will be a cons cell (TAG . VALUE), + which gets stored in the environment. Sets the pending non-local exit + flag. */ +static void module_handle_throw (emacs_env *env, Lisp_Object tag_val); + +/* 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); + +/* 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) + +#define MODULE_SETJMP(handlertype, handlerfunc, retval) \ + MODULE_SETJMP_1(handlertype, handlerfunc, retval, \ + internal_handler_##handlertype, \ + internal_cleanup_##handlertype) + +#define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \ + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); \ + struct handler *c; \ + /* It is very important that pushing the handler doesn't itself raise a \ + signal. */ \ + if (!push_handler_nosignal(&c, Qt, handlertype)) { \ + module_out_of_memory(env); \ + return retval; \ + } \ + verify(module_has_cleanup); \ + /* We can install the cleanup only after the handler has been pushed. Use \ + __attribute__((cleanup)) to avoid non-local-exit-prone manual cleanup. */ \ + const int dummy __attribute__((cleanup(module_reset_handlerlist))); \ + if (sys_setjmp(c->jmp)) { \ + (handlerfunc)(env, c->val); \ + return retval; \ + } \ + /* Force the macro to be followed by a semicolon. */ \ + do { \ + } while (0) + + +/* 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 + `module-call'. Its members correspond to the arguments given to + `module_make_function'. */ + +struct module_fun_env +{ + int min_arity, max_arity; + emacs_subr subr; + void *data; +}; + +/* Returns 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); + +/* Holds the function definition of `module-call'. `module-call' is + uninterned because user code couldn't meaningfully use it, so we + have to keep its definition around somewhere else. */ +static Lisp_Object module_call_func; + + +/* Implementation of runtime and environment functions */ + +/* We catch signals and throws only if the code can actually signal or + throw. */ + +static emacs_env* module_get_environment (struct emacs_runtime *ert) +{ + check_main_thread (); + return &ert->private_members->environment.pub; +} + +/* + * To make global refs (GC-protected global values) we keep a hash + * that maps global Lisp objects to reference counts. + */ + +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; + eassert (HASH_TABLE_P (Vmodule_refs_hash)); + 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); + eassert (NATNUMP (value)); + const EMACS_UINT refcount = XFASTINT (value); + if (refcount >= MOST_POSITIVE_FIXNUM) + { + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return NULL; + } + XSETFASTINT (value, refcount + 1); + set_hash_value_slot (h, i, value); + } + else + { + hash_put (h, new_obj, make_natnum (1), hashcode); + } + + return allocate_emacs_value (env, &global_storage, 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. */ + MODULE_HANDLE_SIGNALS_VOID; + eassert (HASH_TABLE_P (Vmodule_refs_hash)); + 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); + eassert (NATNUMP (value)); + const EMACS_UINT refcount = XFASTINT (value); + eassert (refcount > 0); + if (refcount > 1) + { + XSETFASTINT (value, refcount - 1); + 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 *const 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; + } + 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 (); + 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)); +} + +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)); +} + +/* + * 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. + * + * (function + * (lambda + * (&rest arglist) + * (module-call + * envobj + * arglist))) + * + */ +static emacs_value module_make_function (emacs_env *env, + int min_arity, + int max_arity, + emacs_subr subr, + const char *const documentation, + void *data) +{ + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + MODULE_HANDLE_SIGNALS; + + if (min_arity > MOST_POSITIVE_FIXNUM || max_arity > MOST_POSITIVE_FIXNUM) + xsignal0 (Qoverflow_error); + + if (min_arity < 0 || + (max_arity >= 0 && max_arity < min_arity) || + (max_arity < 0 && max_arity != emacs_variadic_function)) + xsignal2 (Qinvalid_arity, make_number (min_arity), make_number (max_arity)); + + Lisp_Object envobj; + + /* XXX: This should need to be freed when envobj is GC'd */ + struct module_fun_env *envptr = xzalloc (sizeof (*envptr)); + envptr->min_arity = min_arity; + envptr->max_arity = max_arity; + envptr->subr = subr; + envptr->data = data; + envobj = make_save_ptr (envptr); + + Lisp_Object ret = list4 (Qlambda, + list2 (Qand_rest, Qargs), + documentation ? build_string (documentation) : Qnil, + list3 (module_call_func, + envobj, + Qargs)); + + return lisp_to_value (env, ret); +} + +static emacs_value module_funcall (emacs_env *env, + emacs_value fun, + int nargs, + emacs_value args[]) +{ + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + MODULE_HANDLE_SIGNALS; + MODULE_HANDLE_THROW; + + /* + * Make a new Lisp_Object array starting with the function as the + * first arg, because that's what Ffuncall takes + */ + Lisp_Object newargs[nargs + 1]; + newargs[0] = value_to_lisp (fun); + for (int i = 0; i < nargs; i++) + newargs[1 + i] = value_to_lisp (args[i]); + return lisp_to_value (env, Ffuncall (nargs + 1, newargs)); +} + +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)); +} + +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))); +} + +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); + return ! NILP (value_to_lisp (value)); +} + +static bool 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); + return EQ (value_to_lisp (a), value_to_lisp (b)); +} + +static int64_t module_extract_integer (emacs_env *env, emacs_value n) +{ + verify (INT64_MIN <= MOST_NEGATIVE_FIXNUM); + verify (INT64_MAX >= MOST_POSITIVE_FIXNUM); + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + const 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, int64_t n) +{ + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + if (n < MOST_NEGATIVE_FIXNUM) + { + module_non_local_exit_signal_1 (env, Qunderflow_error, Qnil); + return NULL; + } + if (n > MOST_POSITIVE_FIXNUM) + { + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return NULL; + } + return lisp_to_value (env, 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); + const 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) +{ + 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)); +} + +static bool module_copy_string_contents (emacs_env *env, + emacs_value value, + char *buffer, + size_t* length) +{ + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + MODULE_HANDLE_SIGNALS; + Lisp_Object lisp_str = value_to_lisp (value); + if (! STRINGP (lisp_str)) + { + module_wrong_type (env, Qstringp, lisp_str); + return false; + } + + size_t raw_size = SBYTES (lisp_str); + + /* + * Emacs internal encoding is more-or-less UTF8, let's assume utf8 + * encoded emacs string are the same byte size. + */ + + if (!buffer || length == 0 || *length-1 < raw_size) + { + *length = raw_size + 1; + return false; + } + + Lisp_Object lisp_str_utf8 = ENCODE_UTF_8 (lisp_str); + eassert (raw_size == SBYTES (lisp_str_utf8)); + *length = raw_size + 1; + memcpy (buffer, SDATA (lisp_str_utf8), SBYTES (lisp_str_utf8)); + buffer[raw_size] = 0; + + return true; +} + +static emacs_value module_make_string (emacs_env *env, const char *str, size_t length) +{ + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + MODULE_HANDLE_SIGNALS; + if (length > PTRDIFF_MAX) + { + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return NULL; + } + /* Assume STR is utf8 encoded */ + return lisp_to_value (env, make_string (str, length)); +} + +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)); +} + +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); + const 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) +{ + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + const 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) +{ + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + const 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) +{ + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + const 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, + size_t i, + emacs_value val) +{ + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + if (i > MOST_POSITIVE_FIXNUM) + { + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return; + } + Lisp_Object lvec = value_to_lisp (vec); + if (! VECTORP (lvec)) + { + module_wrong_type (env, Qvectorp, lvec); + return; + } + if (i >= ASIZE (lvec)) + { + module_args_out_of_range (env, lvec, make_number (i)); + return; + } + ASET (lvec, i, value_to_lisp (val)); +} + +static emacs_value module_vec_get (emacs_env *env, + emacs_value vec, + size_t i) +{ + /* Type of ASIZE (lvec) is ptrdiff_t, make sure it fits */ + verify (PTRDIFF_MAX <= SIZE_MAX); + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + if (i > MOST_POSITIVE_FIXNUM) + { + module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil); + return NULL; + } + Lisp_Object lvec = value_to_lisp (vec); + if (! VECTORP (lvec)) + { + module_wrong_type (env, Qvectorp, lvec); + return NULL; + } + /* Prevent error-prone comparison between types of different signedness. */ + const size_t size = ASIZE (lvec); + eassert (size >= 0); + if (i >= size) + { + if (i > MOST_POSITIVE_FIXNUM) i = MOST_POSITIVE_FIXNUM; + module_args_out_of_range (env, lvec, make_number (i)); + return NULL; + } + return lisp_to_value (env, AREF (lvec, i)); +} + +static size_t module_vec_size (emacs_env *env, + emacs_value vec) +{ + /* Type of ASIZE (lvec) is ptrdiff_t, make sure it fits */ + verify (PTRDIFF_MAX <= SIZE_MAX); + check_main_thread (); + eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); + Lisp_Object lvec = value_to_lisp (vec); + if (! VECTORP (lvec)) + { + module_wrong_type (env, Qvectorp, lvec); + return 0; + } + eassert (ASIZE (lvec) >= 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; + Lisp_Object doc_name, args[2]; + + CHECK_STRING (file); + handle = dynlib_open (SDATA (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_sym (handle, "emacs_module_init"); + if (!module_init) + error ("Module %s does not have an init function.", SDATA (file)); + + struct { + struct emacs_runtime pub; + struct emacs_runtime_private priv; + } runtime = { + .pub = { + .size = sizeof runtime.pub, + .get_environment = module_get_environment, + .private_members = &runtime.priv + } + }; + initialize_environment (&runtime.priv.environment); + int r = module_init (&runtime.pub); + finalize_environment (&runtime.priv.environment); + + if (r != 0) + { + if (r < MOST_NEGATIVE_FIXNUM) + xsignal0 (Qunderflow_error); + if (r > MOST_POSITIVE_FIXNUM) + xsignal0 (Qoverflow_error); + xsignal2 (Qmodule_load_failed, file, make_number (r)); + } + + return Qt; +} + +DEFUN ("module-call", Fmodule_call, Smodule_call, 2, 2, 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) +{ + const struct module_fun_env *const envptr = + (const struct module_fun_env *) XSAVE_POINTER (envobj, 0); + const EMACS_INT len = XINT (Flength (arglist)); + eassert (len >= 0); + if (len > MOST_POSITIVE_FIXNUM) + xsignal0 (Qoverflow_error); + if (len > INT_MAX || len < envptr->min_arity || (envptr->max_arity >= 0 && len > 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 = xzalloc (len * sizeof (*args)); + int i; + + for (i = 0; i < len; i++) + { + args[i] = lisp_to_value (&env.pub, XCAR (arglist)); + if (! args[i]) memory_full (sizeof *args[i]); + arglist = XCDR (arglist); + } + + emacs_value ret = envptr->subr (&env.pub, len, args, envptr->data); + xfree (args); + + switch (env.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)); + return value_to_lisp (ret); + case emacs_funcall_exit_signal: + { + const Lisp_Object symbol = value_to_lisp (&env.priv.non_local_exit_symbol); + const Lisp_Object data = value_to_lisp (&env.priv.non_local_exit_data); + finalize_environment (&env); + xsignal (symbol, data); + } + case emacs_funcall_exit_throw: + { + const Lisp_Object tag = value_to_lisp (&env.priv.non_local_exit_symbol); + const Lisp_Object value = value_to_lisp (&env.priv.non_local_exit_data); + finalize_environment (&env); + Fthrow (tag, value); + } + } +} + + +/* Helper functions */ + +static void check_main_thread (void) +{ +#if defined(HAVE_THREADS_H) + eassert (thrd_equal (thdr_current (), main_thread); +#elif defined(HAVE_PTHREAD) + eassert (pthread_equal (pthread_self (), main_thread)); +#elif defined(WINDOWSNT) + /* CompareObjectHandles would be perfect, but is only available in + Windows 10. Also check whether the thread is still running to + protect against thread identifier reuse. */ + eassert (GetCurrentThreadID () == GetThreadID (main_thread) && + WaitForSingleObject (main_thread, 0) == WAIT_TIMEOUT); +#endif +} + +static void module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym, Lisp_Object data) +{ + struct emacs_env_private *const 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; +} + +static void module_non_local_exit_throw_1 (emacs_env *env, Lisp_Object tag, Lisp_Object value) +{ + struct emacs_env_private *const 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; +} + +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)); +} + +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)); +} + +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 */ + +static Lisp_Object value_to_lisp (emacs_value v) +{ + return v->v; +} + +static emacs_value lisp_to_value (emacs_env *env, Lisp_Object o) +{ + struct emacs_env_private *const p = env->private_members; + if (p->pending_non_local_exit != emacs_funcall_exit_return) return NULL; + return allocate_emacs_value (env, &p->storage, o); +} + + +/* Memory management */ + +static void initialize_frame (struct emacs_value_frame *frame) +{ + frame->offset = 0; + frame->next = NULL; +} + +static void initialize_storage (struct emacs_value_storage *storage) +{ + initialize_frame (&storage->initial); + storage->current = &storage->initial; +} + +static void finalize_storage (struct emacs_value_storage *storage) +{ + struct emacs_value_frame *next = storage->initial.next; + while (next != NULL) + { + struct emacs_value_frame *const current = next; + next = current->next; + free (current); + } +} + +static emacs_value allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage, + Lisp_Object obj) +{ + 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; + } + const 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)) + { + const struct env_storage *const env = XSAVE_POINTER (tem, 0); + for (const struct emacs_value_frame *frame = &env->priv.storage.initial; frame != NULL; frame = frame->next) + for (size_t i = 0; i < frame->offset; ++i) + mark_object (frame->objects[i].v); + } +} + + +/* Environment lifetime management */ + +static void initialize_environment (struct env_storage *env) +{ + 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; + Vmodule_environments = Fcons (make_save_ptr (env), Vmodule_environments); +} + +static void finalize_environment (struct env_storage *env) +{ + finalize_storage (&env->priv.storage); + Vmodule_environments = XCDR (Vmodule_environments); +} + + +/* Non-local exit handling */ + +static void module_reset_handlerlist(const int *dummy) +{ + handlerlist = handlerlist->next; +} + +static void module_handle_signal (emacs_env *const env, const Lisp_Object err) +{ + module_non_local_exit_signal_1 (env, XCAR (err), XCDR (err)); +} + +static void module_handle_throw (emacs_env *const env, const Lisp_Object tag_val) +{ + module_non_local_exit_throw_1 (env, XCAR (tag_val), XCDR (tag_val)); +} + + +/* Function environments */ + +static Lisp_Object module_format_fun_env (const struct module_fun_env *const env) +{ + /* Try to print a function name if possible. */ + const char *path, *sym; + if (dynlib_addr (env->subr, &path, &sym)) + { + const char *const format = "#<module function %s from %s>"; + const int size = snprintf (NULL, 0, format, sym, path); + eassert (size > 0); + char buffer[size + 1]; + snprintf (buffer, sizeof buffer, format, sym, path); + return make_unibyte_string (buffer, size); + } + else + { + const char *const format = "#<module function at %p>"; + const void *const subr = env->subr; + const int size = snprintf (NULL, 0, format, subr); + eassert (size > 0); + char buffer[size + 1]; + snprintf (buffer, sizeof buffer, format, subr); + return make_unibyte_string (buffer, size); + } +} + + +/* Segment initializer */ + +void syms_of_module (void) +{ + DEFSYM (Qmodule_refs_hash, "module-refs-hash"); + DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash, + doc: /* Module global referrence 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")); + + 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); + + 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); +} + +/* 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 we detect the main thread here. */ +#if defined(HAVE_THREADS_H) + main_thread = thrd_current (); +#elif defined(HAVE_PTHREAD) + main_thread = pthread_self (); +#elif defined(WINDOWSNT) + /* GetCurrentProcess returns a pseudohandle, which we have to duplicate. */ + if (! DuplicateHandle (GetCurrentProcess(), GetCurrentThread(), + GetCurrentProcess(), &main_thread, + SYNCHRONIZE | THREAD_QUERY_LIMITED_INFORMATION, + FALSE, 0)) + emacs_abort (); +#endif +} |