src/emacs-module.c

/* [<][>][^][v][top][bottom][index][help] */
This source file includes following definitions.
module_decode_utf_8
CHECK_MODULE_FUNCTION
CHECK_USER_PTR
module_get_environment
XMODULE_GLOBAL_REFERENCE
module_global_reference_p
module_make_global_ref
module_free_global_ref
module_non_local_exit_check
module_non_local_exit_clear
module_non_local_exit_get
module_non_local_exit_signal
module_non_local_exit_throw
allocate_module_function
module_make_function
module_get_function_finalizer
module_set_function_finalizer
module_finalize_function
module_make_interactive
module_function_interactive_form
module_function_command_modes
module_funcall
module_intern
module_type_of
module_is_not_nil
module_eq
module_extract_integer
module_make_integer
module_extract_float
module_make_float
module_copy_string_contents
module_make_string
module_make_unibyte_string
module_make_user_ptr
module_get_user_ptr
module_set_user_ptr
module_get_user_finalizer
module_set_user_finalizer
check_vec_index
module_vec_set
module_vec_get
module_vec_size
module_should_quit
module_process_input
module_extract_time
module_make_time
module_extract_big_integer
module_make_big_integer
module_open_channel
module_signal_or_throw
DEFUN
funcall_module
module_function_arity
module_function_documentation
module_function_address
module_function_data
module_assert_thread
module_assert_runtime
module_assert_env
module_non_local_exit_signal_1
module_non_local_exit_throw_1
module_out_of_memory
value_to_lisp
lisp_to_value
initialize_frame
initialize_storage
finalize_storage
allocate_emacs_value
mark_module_environment
initialize_environment
finalize_environment
finalize_environment_unwind
finalize_runtime_unwind
module_reset_handlerlist
module_handle_nonlocal_exit
init_module_assertions
value_storage_contains_p
ATTRIBUTE_FORMAT_PRINTF
syms_of_module
     1 /* emacs-module.c - Module loading and runtime implementation
     2 
     3 Copyright (C) 2015-2023 Free Software Foundation, Inc.
     4 
     5 This file is part of GNU Emacs.
     6 
     7 GNU Emacs is free software: you can redistribute it and/or modify
     8 it under the terms of the GNU General Public License as published by
     9 the Free Software Foundation, either version 3 of the License, or (at
    10 your option) any later version.
    11 
    12 GNU Emacs is distributed in the hope that it will be useful,
    13 but WITHOUT ANY WARRANTY; without even the implied warranty of
    14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    15 GNU General Public License for more details.
    16 
    17 You should have received a copy of the GNU General Public License
    18 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    19 
    20 /*
    21 The public module API is defined in the header emacs-module.h.  The
    22 configure script generates emacs-module.h from emacs-module.h.in and
    23 the version-specific environment fragments in module-env-*.h.
    24 
    25 If you want to change the module API, please abide to the following
    26 rules:
    27 
    28 - Don't remove publicly documented declarations from the headers.
    29 
    30 - Don't remove, reorder, or rename structure fields, as such changes
    31   break ABI compatibility.
    32 
    33 - Don't change the types of structure fields.
    34 
    35 - Likewise, the presence, order, and type of structure fields may not
    36   depend on preprocessor macros.
    37 
    38 - Add structure fields only at the end of structures.
    39 
    40 - For every Emacs major version there is a new fragment file
    41   module-env-VER.h.  Add functions solely at the end of the fragment
    42   file for the next (not yet released) major version of Emacs.  For
    43   example, if the current Emacs release is 26.2, add functions only to
    44   module-env-27.h.
    45 
    46 - emacs-module.h should only depend on standard C headers.  In
    47   particular, don't include config.h or lisp.h from emacs-module.h.
    48 
    49 - The contents of emacs-module.h should be the same on all platforms
    50   and architectures.
    51 
    52 - emacs-module.h may not depend on Emacs configuration options.
    53 
    54 - Prefix all names in emacs-module.h with "emacs_" or "EMACS_".
    55 
    56 To add a new module function, proceed as follows:
    57 
    58 1. Add a new function pointer field at the end of the module-env-*.h
    59    file for the next major version of Emacs.
    60 
    61 2. Run config.status or configure to regenerate emacs-module.h.
    62 
    63 3. Create a corresponding implementation function in this file.  See
    64    "Implementation of runtime and environment functions" below for
    65    further rules.
    66 
    67 4. Assign the new field in the initialize_environment function.
    68 
    69 5. Add a test function that calls your new function to
    70    test/data/emacs-module/mod-test.c.  Add a unit test that invokes
    71    your new test function to test/src/emacs-module-tests.el.
    72 
    73 6. Document your new function in the manual and in etc/NEWS.
    74 */
    75 
    76 #include <config.h>
    77 
    78 #include "emacs-module.h"
    79 
    80 #include <stdarg.h>
    81 #include <stddef.h>
    82 #include <stdint.h>
    83 #include <stdlib.h>
    84 #include <time.h>
    85 
    86 #include "lisp.h"
    87 #include "bignum.h"
    88 #include "dynlib.h"
    89 #include "coding.h"
    90 #include "keyboard.h"
    91 #include "process.h"
    92 #include "syssignal.h"
    93 #include "sysstdio.h"
    94 #include "thread.h"
    95 
    96 #include <intprops.h>
    97 #include <verify.h>
    98 
    99 /* Work around GCC bug 83162.  */
   100 #if GNUC_PREREQ (4, 3, 0)
   101 # pragma GCC diagnostic ignored "-Wclobbered"
   102 #endif
   103 
   104 /* We use different strategies for allocating the user-visible objects
   105    (struct emacs_runtime, emacs_env, emacs_value), depending on
   106    whether the user supplied the -module-assertions flag.  If
   107    assertions are disabled, all objects are allocated from the stack.
   108    If assertions are enabled, all objects are allocated from the free
   109    store, and objects are never freed; this guarantees that they all
   110    have different addresses.  We use that for checking which objects
   111    are live.  Without unique addresses, we might consider some dead
   112    objects live because their addresses would have been reused in the
   113    meantime.  */
   114 
   115 
   116 /* Feature tests.  */
   117 
   118 #ifdef WINDOWSNT
   119 #include <windows.h>
   120 #include "w32term.h"
   121 #endif
   122 
   123 /* Function prototype for the module init function.  */
   124 typedef int (*emacs_init_function) (struct emacs_runtime *);
   125 
   126 
   127 /* Memory management.  */
   128 
   129 /* An `emacs_value' is just a pointer to a structure holding an
   130    internal Lisp object.  */
   131 struct emacs_value_tag { Lisp_Object v; };
   132 
   133 /* Local value objects use a simple fixed-sized block allocation
   134    scheme without explicit deallocation.  All local values are
   135    deallocated when the lifetime of their environment ends.  Keep
   136    track of a current frame from which new values are allocated,
   137    appending further dynamically-allocated frames if necessary.  */
   138 
   139 enum { value_frame_size = 512 };
   140 
   141 /* A block from which `emacs_value' object can be allocated.  */
   142 struct emacs_value_frame
   143 {
   144   /* Storage for values.  */
   145   struct emacs_value_tag objects[value_frame_size];
   146 
   147   /* Index of the next free value in `objects'.  */
   148   int offset;
   149 
   150   /* Pointer to next frame, if any.  */
   151   struct emacs_value_frame *next;
   152 };
   153 
   154 /* A structure that holds an initial frame (so that the first local
   155    values require no dynamic allocation) and keeps track of the
   156    current frame.  */
   157 struct emacs_value_storage
   158 {
   159   struct emacs_value_frame initial;
   160   struct emacs_value_frame *current;
   161 };
   162 
   163 
   164 /* Private runtime and environment members.  */
   165 
   166 /* The private part of an environment stores the current non local exit state
   167    and holds the `emacs_value' objects allocated during the lifetime
   168    of the environment.  */
   169 struct emacs_env_private
   170 {
   171   enum emacs_funcall_exit pending_non_local_exit;
   172 
   173   /* Dedicated storage for non-local exit symbol and data so that
   174      storage is always available for them, even in an out-of-memory
   175      situation.  */
   176   struct emacs_value_tag non_local_exit_symbol, non_local_exit_data;
   177 
   178   struct emacs_value_storage storage;
   179 };
   180 
   181 /* The private parts of an `emacs_runtime' object contain the initial
   182    environment.  */
   183 struct emacs_runtime_private
   184 {
   185   emacs_env *env;
   186 };
   187 
   188 
   189 /* Forward declarations.  */
   190 
   191 static Lisp_Object value_to_lisp (emacs_value);
   192 static emacs_value allocate_emacs_value (emacs_env *, Lisp_Object);
   193 static emacs_value lisp_to_value (emacs_env *, Lisp_Object);
   194 static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *);
   195 static void module_assert_thread (void);
   196 static void module_assert_runtime (struct emacs_runtime *);
   197 static void module_assert_env (emacs_env *);
   198 static AVOID module_abort (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
   199 static emacs_env *initialize_environment (emacs_env *,
   200                                           struct emacs_env_private *);
   201 static void finalize_environment (emacs_env *);
   202 static void module_handle_nonlocal_exit (emacs_env *, enum nonlocal_exit,
   203                                          Lisp_Object);
   204 static void module_non_local_exit_signal_1 (emacs_env *,
   205                                             Lisp_Object, Lisp_Object);
   206 static void module_non_local_exit_throw_1 (emacs_env *,
   207                                            Lisp_Object, Lisp_Object);
   208 static void module_out_of_memory (emacs_env *);
   209 static void module_reset_handlerlist (struct handler *);
   210 static bool value_storage_contains_p (const struct emacs_value_storage *,
   211                                       emacs_value, ptrdiff_t *);
   212 
   213 static bool module_assertions = false;
   214 
   215 
   216 /* Small helper functions.  */
   217 
   218 /* Interprets the string at STR with length LEN as UTF-8 string.
   219    Signals an error if it's not a valid UTF-8 string.  */
   220 
   221 static Lisp_Object
   222 module_decode_utf_8 (const char *str, ptrdiff_t len)
   223 {
   224   /* We set HANDLE-8-BIT and HANDLE-OVER-UNI to nil to signal an error
   225      if the argument is not a valid UTF-8 string.  While it isn't
   226      documented how make_string and make_function behave in this case,
   227      signaling an error is the most defensive and obvious reaction. */
   228   Lisp_Object s = decode_string_utf_8 (Qnil, str, len, Qnil, false, Qnil, Qnil);
   229   CHECK_TYPE (!NILP (s), Qutf_8_string_p, make_string_from_utf8 (str, len));
   230   return s;
   231 }
   232 
   233 
   234 /* Convenience macros for non-local exit handling.  */
   235 
   236 /* FIXME: The following implementation for non-local exit handling
   237    does not support recovery from stack overflow, see sysdep.c.  */
   238 
   239 /* Emacs uses setjmp and longjmp for non-local exits, but
   240    module frames cannot be skipped because they are in general
   241    not prepared for long jumps (e.g., the behavior in C++ is undefined
   242    if objects with nontrivial destructors would be skipped).
   243    Therefore, catch all non-local exits.  There are two kinds of
   244    non-local exits: `signal' and `throw'.  The macro in this section
   245    can be used to catch both.  Use a macro to avoid additional variants
   246    of `internal_condition_case' etc., and to avoid worrying about
   247    passing information to the handler functions.  */
   248 
   249 /* Place this macro at the beginning of a function returning a number
   250    or a pointer to handle non-local exits.  The function must have an
   251    ENV parameter.  The function will return the specified value if a
   252    signal or throw is caught.  */
   253 
   254 /* It is very important that pushing the handler doesn't itself raise
   255    a signal.  Install the cleanup only after the handler has been
   256    pushed.  All code following this point should use
   257    MODULE_INTERNAL_CLEANUP before each return.
   258 
   259    The do-while forces uses of the macro to be followed by a semicolon.
   260    This macro cannot enclose its entire body inside a do-while, as the
   261    code after the macro may longjmp back into the macro, which means
   262    its local variable INTERNAL_CLEANUP must stay live in later code.  */
   263 
   264 /* TODO: Make backtraces work if this macro is used.  */
   265 
   266 #define MODULE_HANDLE_NONLOCAL_EXIT(retval)                             \
   267   if (module_non_local_exit_check (env) != emacs_funcall_exit_return)   \
   268     return retval;                                                      \
   269   struct handler *internal_handler =                                    \
   270     push_handler_nosignal (Qt, CATCHER_ALL);                            \
   271   if (!internal_handler)                                                \
   272     {                                                                   \
   273       module_out_of_memory (env);                                       \
   274       return retval;                                                    \
   275     }                                                                   \
   276   struct handler *internal_cleanup                                      \
   277     = internal_handler;                                                 \
   278   if (sys_setjmp (internal_cleanup->jmp))                               \
   279     {                                                                   \
   280       module_handle_nonlocal_exit (env,                                 \
   281                                    internal_cleanup->nonlocal_exit,     \
   282                                    internal_cleanup->val);              \
   283       module_reset_handlerlist (internal_cleanup);                      \
   284       return retval;                                                    \
   285     }                                                                   \
   286   do { } while (false)
   287 
   288 #define MODULE_INTERNAL_CLEANUP()               \
   289   module_reset_handlerlist (internal_cleanup)
   290 
   291 
   292 /* Implementation of runtime and environment functions.
   293 
   294    These should abide by the following rules:
   295 
   296    1. The first argument should always be a pointer to emacs_env.
   297 
   298    2. Each function should first call check_thread.  Note that
   299       this function is a no-op unless Emacs was built with
   300       --enable-checking.
   301 
   302    3. The very next thing each function should do is check that the
   303       emacs_env object does not have a non-local exit indication set,
   304       by calling module_non_local_exit_check.  If that returns
   305       anything but emacs_funcall_exit_return, the function should do
   306       nothing and return immediately with an error indication, without
   307       clobbering the existing error indication in emacs_env.  This is
   308       needed for correct reporting of Lisp errors to the Emacs Lisp
   309       interpreter.
   310 
   311    4. Any function that needs to call Emacs facilities, such as
   312       encoding or decoding functions, or 'intern', or 'make_string',
   313       should protect itself from signals and 'throw' in the called
   314       Emacs functions, by placing the macro
   315       MODULE_HANDLE_NONLOCAL_EXIT right after the above 2 tests.
   316 
   317    5. Finally, any code which expands MODULE_HANDLE_NONLOCAL_EXIT
   318       should use MODULE_INTERNAL_CLEANUP prior to returning.
   319 
   320    6. Do NOT use 'eassert' for checking validity of user code in the
   321       module.  Instead, make those checks part of the code, and if the
   322       check fails, call 'module_non_local_exit_signal_1' or
   323       'module_non_local_exit_throw_1' to report the error.  This is
   324       because using 'eassert' in these situations will abort Emacs
   325       instead of reporting the error back to Lisp, and also because
   326       'eassert' is compiled to nothing in the release version.  */
   327 
   328 /* Use MODULE_FUNCTION_BEGIN_NO_CATCH to implement steps 2 and 3 for
   329    environment functions that are known to never exit non-locally.  On
   330    error it will return its argument, which can be a sentinel
   331    value.  */
   332 
   333 #define MODULE_FUNCTION_BEGIN_NO_CATCH(error_retval)                    \
   334   do {                                                                  \
   335     module_assert_thread ();                                            \
   336     module_assert_env (env);                                            \
   337     if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
   338       return error_retval;                                              \
   339   } while (false)
   340 
   341 /* Use MODULE_FUNCTION_BEGIN to implement steps 2 through 4 for most
   342    environment functions.  On error it will return its argument, which
   343    can be a sentinel value.  */
   344 
   345 #define MODULE_FUNCTION_BEGIN(error_retval)      \
   346   MODULE_FUNCTION_BEGIN_NO_CATCH (error_retval); \
   347   MODULE_HANDLE_NONLOCAL_EXIT (error_retval)
   348 
   349 static void
   350 CHECK_MODULE_FUNCTION (Lisp_Object obj)
   351 {
   352   CHECK_TYPE (MODULE_FUNCTIONP (obj), Qmodule_function_p, obj);
   353 }
   354 
   355 static void
   356 CHECK_USER_PTR (Lisp_Object obj)
   357 {
   358   CHECK_TYPE (USER_PTRP (obj), Quser_ptrp, obj);
   359 }
   360 
   361 /* Catch signals and throws only if the code can actually signal or
   362    throw.  If checking is enabled, abort if the current thread is not
   363    the Emacs main thread.  */
   364 
   365 static emacs_env *
   366 module_get_environment (struct emacs_runtime *runtime)
   367 {
   368   module_assert_thread ();
   369   module_assert_runtime (runtime);
   370   return runtime->private_members->env;
   371 }
   372 
   373 /* To make global refs (GC-protected global values) keep a hash that
   374    maps global Lisp objects to 'struct module_global_reference'
   375    objects.  We store the 'emacs_value' in the hash table so that it
   376    is automatically garbage-collected (Bug#42482).  */
   377 
   378 static Lisp_Object Vmodule_refs_hash;
   379 
   380 /* Pseudovector type for global references.  The pseudovector tag is
   381    PVEC_OTHER since these values are never printed and don't need to
   382    be special-cased for garbage collection.  */
   383 
   384 struct module_global_reference {
   385   /* Pseudovector header, must come first. */
   386   union vectorlike_header header;
   387 
   388   /* Holds the emacs_value for the object.  The Lisp_Object stored
   389      therein must be the same as the hash key.  */
   390   struct emacs_value_tag value;
   391 
   392   /* Reference count, always positive.  */
   393   ptrdiff_t refcount;
   394 };
   395 
   396 static struct module_global_reference *
   397 XMODULE_GLOBAL_REFERENCE (Lisp_Object o)
   398 {
   399   eassert (PSEUDOVECTORP (o, PVEC_OTHER));
   400   return XUNTAG (o, Lisp_Vectorlike, struct module_global_reference);
   401 }
   402 
   403 /* Returns whether V is a global reference.  Only used to check module
   404    assertions.  If V is not a global reference, increment *N by the
   405    number of global references (for debugging output).  */
   406 
   407 static bool
   408 module_global_reference_p (emacs_value v, ptrdiff_t *n)
   409 {
   410   struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
   411   /* Note that we can't use `hash_lookup' because V might be a local
   412      reference that's identical to some global reference.  */
   413   for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
   414     {
   415       if (!BASE_EQ (HASH_KEY (h, i), Qunbound)
   416           && &XMODULE_GLOBAL_REFERENCE (HASH_VALUE (h, i))->value == v)
   417         return true;
   418     }
   419   /* Only used for debugging, so we don't care about overflow, just
   420      make sure the operation is defined.  */
   421   ckd_add (n, *n, h->count);
   422   return false;
   423 }
   424 
   425 static emacs_value
   426 module_make_global_ref (emacs_env *env, emacs_value value)
   427 {
   428   MODULE_FUNCTION_BEGIN (NULL);
   429   struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
   430   Lisp_Object new_obj = value_to_lisp (value), hashcode;
   431   ptrdiff_t i = hash_lookup (h, new_obj, &hashcode);
   432 
   433   /* Note: This approach requires the garbage collector to never move
   434      objects.  */
   435 
   436   if (i >= 0)
   437     {
   438       Lisp_Object value = HASH_VALUE (h, i);
   439       struct module_global_reference *ref = XMODULE_GLOBAL_REFERENCE (value);
   440       bool overflow = ckd_add (&ref->refcount, ref->refcount, 1);
   441       if (overflow)
   442         overflow_error ();
   443       MODULE_INTERNAL_CLEANUP ();
   444       return &ref->value;
   445     }
   446   else
   447     {
   448       struct module_global_reference *ref
   449         = ALLOCATE_PLAIN_PSEUDOVECTOR (struct module_global_reference,
   450                                        PVEC_OTHER);
   451       ref->value.v = new_obj;
   452       ref->refcount = 1;
   453       Lisp_Object value;
   454       XSETPSEUDOVECTOR (value, ref, PVEC_OTHER);
   455       hash_put (h, new_obj, value, hashcode);
   456       MODULE_INTERNAL_CLEANUP ();
   457       return &ref->value;
   458     }
   459 }
   460 
   461 static void
   462 module_free_global_ref (emacs_env *env, emacs_value global_value)
   463 {
   464   /* TODO: This probably never signals.  */
   465   /* FIXME: Wait a minute.  Shouldn't this function report an error if
   466      the hash lookup fails?  */
   467   MODULE_FUNCTION_BEGIN ();
   468   struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
   469   Lisp_Object obj = value_to_lisp (global_value);
   470   ptrdiff_t i = hash_lookup (h, obj, NULL);
   471 
   472   if (module_assertions)
   473     {
   474       ptrdiff_t n = 0;
   475       if (! module_global_reference_p (global_value, &n))
   476         module_abort ("Global value was not found in list of %"pD"d globals",
   477                       n);
   478     }
   479 
   480   if (i >= 0)
   481     {
   482       Lisp_Object value = HASH_VALUE (h, i);
   483       struct module_global_reference *ref = XMODULE_GLOBAL_REFERENCE (value);
   484       eassert (0 < ref->refcount);
   485       if (--ref->refcount == 0)
   486         hash_remove_from_table (h, obj);
   487     }
   488 
   489   MODULE_INTERNAL_CLEANUP ();
   490 }
   491 
   492 static enum emacs_funcall_exit
   493 module_non_local_exit_check (emacs_env *env)
   494 {
   495   module_assert_thread ();
   496   module_assert_env (env);
   497   return env->private_members->pending_non_local_exit;
   498 }
   499 
   500 static void
   501 module_non_local_exit_clear (emacs_env *env)
   502 {
   503   module_assert_thread ();
   504   module_assert_env (env);
   505   env->private_members->pending_non_local_exit = emacs_funcall_exit_return;
   506 }
   507 
   508 static enum emacs_funcall_exit
   509 module_non_local_exit_get (emacs_env *env,
   510                            emacs_value *symbol, emacs_value *data)
   511 {
   512   module_assert_thread ();
   513   module_assert_env (env);
   514   struct emacs_env_private *p = env->private_members;
   515   if (p->pending_non_local_exit != emacs_funcall_exit_return)
   516     {
   517       *symbol = &p->non_local_exit_symbol;
   518       *data = &p->non_local_exit_data;
   519     }
   520   return p->pending_non_local_exit;
   521 }
   522 
   523 /* Like for `signal', DATA must be a list.  */
   524 static void
   525 module_non_local_exit_signal (emacs_env *env,
   526                               emacs_value symbol, emacs_value data)
   527 {
   528   module_assert_thread ();
   529   module_assert_env (env);
   530   if (module_non_local_exit_check (env) == emacs_funcall_exit_return)
   531     module_non_local_exit_signal_1 (env, value_to_lisp (symbol),
   532                                     value_to_lisp (data));
   533 }
   534 
   535 static void
   536 module_non_local_exit_throw (emacs_env *env, emacs_value tag, emacs_value value)
   537 {
   538   module_assert_thread ();
   539   module_assert_env (env);
   540   if (module_non_local_exit_check (env) == emacs_funcall_exit_return)
   541     module_non_local_exit_throw_1 (env, value_to_lisp (tag),
   542                                    value_to_lisp (value));
   543 }
   544 
   545 /* Module function.  */
   546 
   547 /* A function environment is an auxiliary structure returned by
   548    `module_make_function' to store information about a module
   549    function.  It is stored in a pseudovector.  Its members correspond
   550    to the arguments given to `module_make_function'.  */
   551 
   552 struct Lisp_Module_Function
   553 {
   554   union vectorlike_header header;
   555 
   556   /* Fields traced by GC; these must come first.  */
   557   Lisp_Object documentation, interactive_form, command_modes;
   558 
   559   /* Fields ignored by GC.  */
   560   ptrdiff_t min_arity, max_arity;
   561   emacs_function subr;
   562   void *data;
   563   emacs_finalizer finalizer;
   564 } GCALIGNED_STRUCT;
   565 
   566 static struct Lisp_Module_Function *
   567 allocate_module_function (void)
   568 {
   569   return ALLOCATE_PSEUDOVECTOR (struct Lisp_Module_Function,
   570                                 command_modes, PVEC_MODULE_FUNCTION);
   571 }
   572 
   573 #define XSET_MODULE_FUNCTION(var, ptr) \
   574   XSETPSEUDOVECTOR (var, ptr, PVEC_MODULE_FUNCTION)
   575 
   576 /* A module function is a pseudovector of subtype
   577    PVEC_MODULE_FUNCTION; see lisp.h for the definition.  */
   578 
   579 static emacs_value
   580 module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity,
   581                       emacs_function func, const char *docstring, void *data)
   582 {
   583   emacs_value value;
   584 
   585   MODULE_FUNCTION_BEGIN (NULL);
   586 
   587   if (! (0 <= min_arity
   588          && (max_arity < 0
   589              ? (min_arity <= MOST_POSITIVE_FIXNUM
   590                 && max_arity == emacs_variadic_function)
   591              : min_arity <= max_arity && max_arity <= MOST_POSITIVE_FIXNUM)))
   592     xsignal2 (Qinvalid_arity, make_fixnum (min_arity), make_fixnum (max_arity));
   593 
   594   struct Lisp_Module_Function *function = allocate_module_function ();
   595   function->min_arity = min_arity;
   596   function->max_arity = max_arity;
   597   function->subr = func;
   598   function->data = data;
   599   function->finalizer = NULL;
   600 
   601   if (docstring)
   602     function->documentation
   603       = module_decode_utf_8 (docstring, strlen (docstring));
   604 
   605   Lisp_Object result;
   606   XSET_MODULE_FUNCTION (result, function);
   607   eassert (MODULE_FUNCTIONP (result));
   608 
   609   value = lisp_to_value (env, result);
   610   MODULE_INTERNAL_CLEANUP ();
   611   return value;
   612 }
   613 
   614 static emacs_finalizer
   615 module_get_function_finalizer (emacs_env *env, emacs_value arg)
   616 {
   617   MODULE_FUNCTION_BEGIN (NULL);
   618   Lisp_Object lisp = value_to_lisp (arg);
   619   CHECK_MODULE_FUNCTION (lisp);
   620   MODULE_INTERNAL_CLEANUP ();
   621   return XMODULE_FUNCTION (lisp)->finalizer;
   622 }
   623 
   624 static void
   625 module_set_function_finalizer (emacs_env *env, emacs_value arg,
   626                                emacs_finalizer fin)
   627 {
   628   MODULE_FUNCTION_BEGIN ();
   629   Lisp_Object lisp = value_to_lisp (arg);
   630   CHECK_MODULE_FUNCTION (lisp);
   631   XMODULE_FUNCTION (lisp)->finalizer = fin;
   632   MODULE_INTERNAL_CLEANUP ();
   633 }
   634 
   635 void
   636 module_finalize_function (const struct Lisp_Module_Function *func)
   637 {
   638   if (func->finalizer != NULL)
   639     func->finalizer (func->data);
   640 }
   641 
   642 static void
   643 module_make_interactive (emacs_env *env, emacs_value function, emacs_value spec)
   644 {
   645   MODULE_FUNCTION_BEGIN ();
   646   Lisp_Object lisp_fun = value_to_lisp (function);
   647   CHECK_MODULE_FUNCTION (lisp_fun);
   648   Lisp_Object lisp_spec = value_to_lisp (spec);
   649   /* Normalize (interactive nil) to (interactive). */
   650   XMODULE_FUNCTION (lisp_fun)->interactive_form
   651     = NILP (lisp_spec) ? list1 (Qinteractive) : list2 (Qinteractive, lisp_spec);
   652   MODULE_INTERNAL_CLEANUP ();
   653 }
   654 
   655 Lisp_Object
   656 module_function_interactive_form (const struct Lisp_Module_Function *fun)
   657 {
   658   return fun->interactive_form;
   659 }
   660 
   661 Lisp_Object
   662 module_function_command_modes (const struct Lisp_Module_Function *fun)
   663 {
   664   return fun->command_modes;
   665 }
   666 
   667 static emacs_value
   668 module_funcall (emacs_env *env, emacs_value func, ptrdiff_t nargs,
   669                 emacs_value *args)
   670 {
   671   MODULE_FUNCTION_BEGIN (NULL);
   672 
   673   /* Make a new Lisp_Object array starting with the function as the
   674      first arg, because that's what Ffuncall takes.  */
   675   Lisp_Object *newargs;
   676   USE_SAFE_ALLOCA;
   677   ptrdiff_t nargs1;
   678   if (ckd_add (&nargs1, nargs, 1))
   679     overflow_error ();
   680   SAFE_ALLOCA_LISP (newargs, nargs1);
   681   newargs[0] = value_to_lisp (func);
   682   for (ptrdiff_t i = 0; i < nargs; i++)
   683     newargs[1 + i] = value_to_lisp (args[i]);
   684   emacs_value result = lisp_to_value (env, Ffuncall (nargs1, newargs));
   685   SAFE_FREE ();
   686   MODULE_INTERNAL_CLEANUP ();
   687   return result;
   688 }
   689 
   690 static emacs_value
   691 module_intern (emacs_env *env, const char *name)
   692 {
   693   emacs_value tem;
   694 
   695   MODULE_FUNCTION_BEGIN (NULL);
   696   tem = lisp_to_value (env, intern (name));
   697   MODULE_INTERNAL_CLEANUP ();
   698   return tem;
   699 }
   700 
   701 static emacs_value
   702 module_type_of (emacs_env *env, emacs_value arg)
   703 {
   704   emacs_value tem;
   705 
   706   MODULE_FUNCTION_BEGIN (NULL);
   707   tem = lisp_to_value (env, Ftype_of (value_to_lisp (arg)));
   708   MODULE_INTERNAL_CLEANUP ();
   709   return tem;
   710 }
   711 
   712 static bool
   713 module_is_not_nil (emacs_env *env, emacs_value arg)
   714 {
   715   MODULE_FUNCTION_BEGIN_NO_CATCH (false);
   716   return ! NILP (value_to_lisp (arg));
   717 }
   718 
   719 static bool
   720 module_eq (emacs_env *env, emacs_value a, emacs_value b)
   721 {
   722   MODULE_FUNCTION_BEGIN_NO_CATCH (false);
   723   return EQ (value_to_lisp (a), value_to_lisp (b));
   724 }
   725 
   726 static intmax_t
   727 module_extract_integer (emacs_env *env, emacs_value arg)
   728 {
   729   MODULE_FUNCTION_BEGIN (0);
   730   Lisp_Object lisp = value_to_lisp (arg);
   731   CHECK_INTEGER (lisp);
   732   intmax_t i;
   733   if (! integer_to_intmax (lisp, &i))
   734     xsignal1 (Qoverflow_error, lisp);
   735   MODULE_INTERNAL_CLEANUP ();
   736   return i;
   737 }
   738 
   739 static emacs_value
   740 module_make_integer (emacs_env *env, intmax_t n)
   741 {
   742   emacs_value value;
   743 
   744   MODULE_FUNCTION_BEGIN (NULL);
   745   value = lisp_to_value (env, make_int (n));
   746   MODULE_INTERNAL_CLEANUP ();
   747 
   748   return value;
   749 }
   750 
   751 static double
   752 module_extract_float (emacs_env *env, emacs_value arg)
   753 {
   754   MODULE_FUNCTION_BEGIN (0);
   755   Lisp_Object lisp = value_to_lisp (arg);
   756   CHECK_TYPE (FLOATP (lisp), Qfloatp, lisp);
   757   MODULE_INTERNAL_CLEANUP ();
   758 
   759   return XFLOAT_DATA (lisp);
   760 }
   761 
   762 static emacs_value
   763 module_make_float (emacs_env *env, double d)
   764 {
   765   emacs_value value;
   766 
   767   MODULE_FUNCTION_BEGIN (NULL);
   768   value = lisp_to_value (env, make_float (d));
   769   MODULE_INTERNAL_CLEANUP ();
   770 
   771   return value;
   772 }
   773 
   774 static bool
   775 module_copy_string_contents (emacs_env *env, emacs_value value, char *buf,
   776                              ptrdiff_t *len)
   777 {
   778   MODULE_FUNCTION_BEGIN (false);
   779   Lisp_Object lisp_str = value_to_lisp (value);
   780   CHECK_STRING (lisp_str);
   781 
   782   /* We can set NOCOPY to true here because we only use the byte
   783      sequence starting at SDATA and don't modify the original string
   784      before copying out the data.
   785 
   786      We set HANDLE-8-BIT and HANDLE-OVER-UNI to nil to signal an error
   787      if the argument is not a valid Unicode string.  While it isn't
   788      documented how copy_string_contents behaves in this case,
   789      signaling an error is the most defensive and obvious reaction. */
   790   Lisp_Object lisp_str_utf8
   791     = encode_string_utf_8 (lisp_str, Qnil, true, Qnil, Qnil);
   792 
   793   /* Since we set HANDLE-8-BIT and HANDLE-OVER-UNI to nil, the return
   794      value can be nil, and we have to check for that. */
   795   CHECK_TYPE (!NILP (lisp_str_utf8), Qunicode_string_p, lisp_str);
   796 
   797   ptrdiff_t raw_size = SBYTES (lisp_str_utf8);
   798   ptrdiff_t required_buf_size = raw_size + 1;
   799 
   800   if (buf == NULL)
   801     {
   802       *len = required_buf_size;
   803       MODULE_INTERNAL_CLEANUP ();
   804       return true;
   805     }
   806 
   807   if (*len < required_buf_size)
   808     {
   809       ptrdiff_t actual = *len;
   810       *len = required_buf_size;
   811       args_out_of_range_3 (INT_TO_INTEGER (actual),
   812                            INT_TO_INTEGER (required_buf_size),
   813                            INT_TO_INTEGER (PTRDIFF_MAX));
   814     }
   815 
   816   *len = required_buf_size;
   817   memcpy (buf, SDATA (lisp_str_utf8), raw_size + 1);
   818 
   819   MODULE_INTERNAL_CLEANUP ();
   820   return true;
   821 }
   822 
   823 static emacs_value
   824 module_make_string (emacs_env *env, const char *str, ptrdiff_t len)
   825 {
   826   emacs_value value;
   827 
   828   MODULE_FUNCTION_BEGIN (NULL);
   829   if (! (0 <= len && len <= STRING_BYTES_BOUND))
   830     overflow_error ();
   831   Lisp_Object lstr
   832     = len == 0 ? empty_multibyte_string : module_decode_utf_8 (str, len);
   833   value = lisp_to_value (env, lstr);
   834   MODULE_INTERNAL_CLEANUP ();
   835   return value;
   836 }
   837 
   838 static emacs_value
   839 module_make_unibyte_string (emacs_env *env, const char *str, ptrdiff_t length)
   840 {
   841   emacs_value value;
   842 
   843   MODULE_FUNCTION_BEGIN (NULL);
   844   if (! (0 <= length && length <= STRING_BYTES_BOUND))
   845     overflow_error ();
   846   Lisp_Object lstr
   847     = length == 0 ? empty_unibyte_string : make_unibyte_string (str, length);
   848   value = lisp_to_value (env, lstr);
   849   MODULE_INTERNAL_CLEANUP ();
   850 
   851   return value;
   852 }
   853 
   854 static emacs_value
   855 module_make_user_ptr (emacs_env *env, emacs_finalizer fin, void *ptr)
   856 {
   857   emacs_value value;
   858 
   859   MODULE_FUNCTION_BEGIN (NULL);
   860   value = lisp_to_value (env, make_user_ptr (fin, ptr));
   861   MODULE_INTERNAL_CLEANUP ();
   862 
   863   return value;
   864 }
   865 
   866 static void *
   867 module_get_user_ptr (emacs_env *env, emacs_value arg)
   868 {
   869   MODULE_FUNCTION_BEGIN (NULL);
   870   Lisp_Object lisp = value_to_lisp (arg);
   871   CHECK_USER_PTR (lisp);
   872   MODULE_INTERNAL_CLEANUP ();
   873 
   874   return XUSER_PTR (lisp)->p;
   875 }
   876 
   877 static void
   878 module_set_user_ptr (emacs_env *env, emacs_value arg, void *ptr)
   879 {
   880   MODULE_FUNCTION_BEGIN ();
   881   Lisp_Object lisp = value_to_lisp (arg);
   882   CHECK_USER_PTR (lisp);
   883   XUSER_PTR (lisp)->p = ptr;
   884   MODULE_INTERNAL_CLEANUP ();
   885 }
   886 
   887 static emacs_finalizer
   888 module_get_user_finalizer (emacs_env *env, emacs_value arg)
   889 {
   890   MODULE_FUNCTION_BEGIN (NULL);
   891   Lisp_Object lisp = value_to_lisp (arg);
   892   CHECK_USER_PTR (lisp);
   893   MODULE_INTERNAL_CLEANUP ();
   894   return XUSER_PTR (lisp)->finalizer;
   895 }
   896 
   897 static void
   898 module_set_user_finalizer (emacs_env *env, emacs_value arg,
   899                            emacs_finalizer fin)
   900 {
   901   MODULE_FUNCTION_BEGIN ();
   902   Lisp_Object lisp = value_to_lisp (arg);
   903   CHECK_USER_PTR (lisp);
   904   XUSER_PTR (lisp)->finalizer = fin;
   905   MODULE_INTERNAL_CLEANUP ();
   906 }
   907 
   908 static void
   909 check_vec_index (Lisp_Object lvec, ptrdiff_t i)
   910 {
   911   CHECK_VECTOR (lvec);
   912   if (! (0 <= i && i < ASIZE (lvec)))
   913     args_out_of_range_3 (INT_TO_INTEGER (i),
   914                          make_fixnum (0), make_fixnum (ASIZE (lvec) - 1));
   915 }
   916 
   917 static void
   918 module_vec_set (emacs_env *env, emacs_value vector, ptrdiff_t index,
   919                 emacs_value value)
   920 {
   921   MODULE_FUNCTION_BEGIN ();
   922   Lisp_Object lisp = value_to_lisp (vector);
   923   check_vec_index (lisp, index);
   924   ASET (lisp, index, value_to_lisp (value));
   925   MODULE_INTERNAL_CLEANUP ();
   926 }
   927 
   928 static emacs_value
   929 module_vec_get (emacs_env *env, emacs_value vector, ptrdiff_t index)
   930 {
   931   emacs_value value;
   932 
   933   MODULE_FUNCTION_BEGIN (NULL);
   934   Lisp_Object lisp = value_to_lisp (vector);
   935   check_vec_index (lisp, index);
   936   value = lisp_to_value (env, AREF (lisp, index));
   937   MODULE_INTERNAL_CLEANUP ();
   938 
   939   return value;
   940 }
   941 
   942 static ptrdiff_t
   943 module_vec_size (emacs_env *env, emacs_value vector)
   944 {
   945   MODULE_FUNCTION_BEGIN (0);
   946   Lisp_Object lisp = value_to_lisp (vector);
   947   CHECK_VECTOR (lisp);
   948   MODULE_INTERNAL_CLEANUP ();
   949 
   950   return ASIZE (lisp);
   951 }
   952 
   953 /* This function should return true if and only if maybe_quit would
   954    quit.  */
   955 static bool
   956 module_should_quit (emacs_env *env)
   957 {
   958   MODULE_FUNCTION_BEGIN_NO_CATCH (false);
   959   return QUITP;
   960 }
   961 
   962 static enum emacs_process_input_result
   963 module_process_input (emacs_env *env)
   964 {
   965   enum emacs_process_input_result rc;
   966 
   967   MODULE_FUNCTION_BEGIN (emacs_process_input_quit);
   968   maybe_quit ();
   969   rc = emacs_process_input_continue;
   970   MODULE_INTERNAL_CLEANUP ();
   971   return rc;
   972 }
   973 
   974 static struct timespec
   975 module_extract_time (emacs_env *env, emacs_value arg)
   976 {
   977   struct timespec value;
   978 
   979   MODULE_FUNCTION_BEGIN ((struct timespec) {0});
   980   value = lisp_time_argument (value_to_lisp (arg));
   981   MODULE_INTERNAL_CLEANUP ();
   982 
   983   return value;
   984 }
   985 
   986 static emacs_value
   987 module_make_time (emacs_env *env, struct timespec time)
   988 {
   989   emacs_value value;
   990 
   991   MODULE_FUNCTION_BEGIN (NULL);
   992   value = lisp_to_value (env, timespec_to_lisp (time));
   993   MODULE_INTERNAL_CLEANUP ();
   994 
   995   return value;
   996 }
   997 
   998 /*
   999 Big integer support.
  1000 
  1001 There are two possible ways to support big integers in the module API
  1002 that have been discussed:
  1003 
  1004 1. Exposing GMP numbers (mpz_t) directly in the API.
  1005 
  1006 2. Isolating the API from GMP by converting to/from a custom
  1007    sign-magnitude representation.
  1008 
  1009 Approach (1) has the advantage of being faster (no import/export
  1010 required) and requiring less code in Emacs and in modules that would
  1011 use GMP anyway.  However, (1) also couples big integer support
  1012 directly to the current implementation in Emacs (GMP).  Also (1)
  1013 requires each module author to ensure that their module is linked to
  1014 the same GMP library as Emacs itself; in particular, module authors
  1015 can't link GMP statically.  (1) also requires conditional compilation
  1016 and workarounds to ensure the module interface still works if GMP
  1017 isn't available while including emacs-module.h.  It also means that
  1018 modules written in languages such as Go and Java that support big
  1019 integers without GMP now have to carry an otherwise unnecessary GMP
  1020 dependency.  Approach (2), on the other hand, neatly decouples the
  1021 module interface from the GMP-based implementation.  It's not
  1022 significantly more complex than (1) either: the additional code is
  1023 mostly straightforward.  Over all, the benefits of (2) over (1) are
  1024 large enough to prefer it here.
  1025 
  1026 We use a simple sign-magnitude representation for the big integers.
  1027 For the magnitude we pick an array of an unsigned integer type similar
  1028 to mp_limb_t instead of e.g. unsigned char.  This matches in most
  1029 cases the representation of a GMP limb.  In such cases GMP picks an
  1030 optimized algorithm for mpz_import and mpz_export that boils down to a
  1031 single memcpy to convert the magnitude.  This way we largely avoid the
  1032 import/export overhead on most platforms.
  1033 */
  1034 
  1035 /* Documented maximum count of magnitude elements. */
  1036 #define module_bignum_count_max \
  1037   ((ptrdiff_t) min (SIZE_MAX, PTRDIFF_MAX) / sizeof (emacs_limb_t))
  1038 
  1039 /* Verify that emacs_limb_t indeed has unique object
  1040    representations.  */
  1041 verify (CHAR_BIT == 8);
  1042 verify ((sizeof (emacs_limb_t) == 4 && EMACS_LIMB_MAX == 0xFFFFFFFF)
  1043         || (sizeof (emacs_limb_t) == 8
  1044             && EMACS_LIMB_MAX == 0xFFFFFFFFFFFFFFFF));
  1045 
  1046 static bool
  1047 module_extract_big_integer (emacs_env *env, emacs_value arg, int *sign,
  1048                             ptrdiff_t *count, emacs_limb_t *magnitude)
  1049 {
  1050   MODULE_FUNCTION_BEGIN (false);
  1051   Lisp_Object o = value_to_lisp (arg);
  1052   CHECK_INTEGER (o);
  1053   int dummy;
  1054   if (sign == NULL)
  1055     sign = &dummy;
  1056   /* See
  1057      https://gmplib.org/manual/Integer-Import-and-Export.html#index-Export. */
  1058   enum
  1059   {
  1060     order = -1,
  1061     size = sizeof *magnitude,
  1062     bits = size * CHAR_BIT,
  1063     endian = 0,
  1064     nails = 0,
  1065     numb = 8 * size - nails
  1066   };
  1067   if (FIXNUMP (o))
  1068     {
  1069       EMACS_INT x = XFIXNUM (o);
  1070       *sign = (0 < x) - (x < 0);
  1071       if (x == 0 || count == NULL)
  1072         {
  1073           MODULE_INTERNAL_CLEANUP ();
  1074           return true;
  1075         }
  1076       /* As a simplification we don't check how many array elements
  1077          are exactly required, but use a reasonable static upper
  1078          bound.  For most architectures exactly one element should
  1079          suffice.  */
  1080       EMACS_UINT u;
  1081       enum { required = (sizeof u + size - 1) / size };
  1082       verify (0 < required && +required <= module_bignum_count_max);
  1083       if (magnitude == NULL)
  1084         {
  1085           *count = required;
  1086           MODULE_INTERNAL_CLEANUP ();
  1087           return true;
  1088         }
  1089       if (*count < required)
  1090         {
  1091           ptrdiff_t actual = *count;
  1092           *count = required;
  1093           args_out_of_range_3 (INT_TO_INTEGER (actual),
  1094                                INT_TO_INTEGER (required),
  1095                                INT_TO_INTEGER (module_bignum_count_max));
  1096         }
  1097       /* Set u = abs(x).  See https://stackoverflow.com/a/17313717. */
  1098       if (0 < x)
  1099         u = (EMACS_UINT) x;
  1100       else
  1101         u = -(EMACS_UINT) x;
  1102       verify (required * bits < PTRDIFF_MAX);
  1103       for (ptrdiff_t i = 0; i < required; ++i)
  1104         magnitude[i] = (emacs_limb_t) (u >> (i * bits));
  1105       MODULE_INTERNAL_CLEANUP ();
  1106       return true;
  1107     }
  1108   const mpz_t *x = xbignum_val (o);
  1109   *sign = mpz_sgn (*x);
  1110   if (count == NULL)
  1111     {
  1112       MODULE_INTERNAL_CLEANUP ();
  1113       return true;
  1114     }
  1115   size_t required_size = (mpz_sizeinbase (*x, 2) + numb - 1) / numb;
  1116   eassert (required_size <= PTRDIFF_MAX);
  1117   ptrdiff_t required = (ptrdiff_t) required_size;
  1118   eassert (required <= module_bignum_count_max);
  1119   if (magnitude == NULL)
  1120     {
  1121       *count = required;
  1122       MODULE_INTERNAL_CLEANUP ();
  1123       return true;
  1124     }
  1125   if (*count < required)
  1126     {
  1127       ptrdiff_t actual = *count;
  1128       *count = required;
  1129       args_out_of_range_3 (INT_TO_INTEGER (actual), INT_TO_INTEGER (required),
  1130                            INT_TO_INTEGER (module_bignum_count_max));
  1131     }
  1132   size_t written;
  1133   mpz_export (magnitude, &written, order, size, endian, nails, *x);
  1134   eassert (written == required_size);
  1135   MODULE_INTERNAL_CLEANUP ();
  1136   return true;
  1137 }
  1138 
  1139 static emacs_value
  1140 module_make_big_integer (emacs_env *env, int sign,
  1141                          ptrdiff_t count, const emacs_limb_t *magnitude)
  1142 {
  1143   emacs_value value;
  1144 
  1145   MODULE_FUNCTION_BEGIN (NULL);
  1146   if (sign == 0)
  1147     {
  1148       value = lisp_to_value (env, make_fixed_natnum (0));
  1149       MODULE_INTERNAL_CLEANUP ();
  1150       return value;
  1151     }
  1152   enum { order = -1, size = sizeof *magnitude, endian = 0, nails = 0 };
  1153   mpz_import (mpz[0], count, order, size, endian, nails, magnitude);
  1154   if (sign < 0)
  1155     mpz_neg (mpz[0], mpz[0]);
  1156   value = lisp_to_value (env, make_integer_mpz ());
  1157   MODULE_INTERNAL_CLEANUP ();
  1158   return value;
  1159 }
  1160 
  1161 static int
  1162 module_open_channel (emacs_env *env, emacs_value pipe_process)
  1163 {
  1164   int rc;
  1165 
  1166   MODULE_FUNCTION_BEGIN (-1);
  1167   rc = open_channel_for_module (value_to_lisp (pipe_process));
  1168   MODULE_INTERNAL_CLEANUP ();
  1169 
  1170   return rc;
  1171 }
  1172 
  1173 
  1174 /* Subroutines.  */
  1175 
  1176 static void
  1177 module_signal_or_throw (struct emacs_env_private *env)
  1178 {
  1179   switch (env->pending_non_local_exit)
  1180     {
  1181     case emacs_funcall_exit_return:
  1182       return;
  1183     case emacs_funcall_exit_signal:
  1184       xsignal (value_to_lisp (&env->non_local_exit_symbol),
  1185                value_to_lisp (&env->non_local_exit_data));
  1186     case emacs_funcall_exit_throw:
  1187       Fthrow (value_to_lisp (&env->non_local_exit_symbol),
  1188               value_to_lisp (&env->non_local_exit_data));
  1189     default:
  1190       eassume (false);
  1191     }
  1192 }
  1193 
  1194 DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
  1195        doc: /* Load module FILE.  */)
  1196   (Lisp_Object file)
  1197 {
  1198   dynlib_handle_ptr handle;
  1199   emacs_init_function module_init;
  1200   void *gpl_sym;
  1201 
  1202   CHECK_STRING (file);
  1203   handle = dynlib_open (SSDATA (file));
  1204   if (!handle)
  1205     xsignal2 (Qmodule_open_failed, file, build_string (dynlib_error ()));
  1206 
  1207   gpl_sym = dynlib_sym (handle, "plugin_is_GPL_compatible");
  1208   if (!gpl_sym)
  1209     xsignal1 (Qmodule_not_gpl_compatible, file);
  1210 
  1211   module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init");
  1212   if (!module_init)
  1213     xsignal1 (Qmissing_module_init_function, file);
  1214 
  1215   struct emacs_runtime rt_pub;
  1216   struct emacs_runtime_private rt_priv;
  1217   emacs_env env_pub;
  1218   struct emacs_env_private env_priv;
  1219   rt_priv.env = initialize_environment (&env_pub, &env_priv);
  1220 
  1221   /* If we should use module assertions, reallocate the runtime object
  1222      from the free store, but never free it.  That way the addresses
  1223      for two different runtime objects are guaranteed to be distinct,
  1224      which we can use for checking the liveness of runtime
  1225      pointers.  */
  1226   struct emacs_runtime *rt;
  1227   if (module_assertions)
  1228     {
  1229       rt = xmalloc (sizeof *rt);
  1230       __lsan_ignore_object (rt);
  1231     }
  1232   else
  1233     rt = &rt_pub;
  1234   rt->size = sizeof *rt;
  1235   rt->private_members = &rt_priv;
  1236   rt->get_environment = module_get_environment;
  1237 
  1238   specpdl_ref count = SPECPDL_INDEX ();
  1239   record_unwind_protect_module (SPECPDL_MODULE_RUNTIME, rt);
  1240   record_unwind_protect_module (SPECPDL_MODULE_ENVIRONMENT, rt_priv.env);
  1241 
  1242   int r = module_init (rt);
  1243 
  1244   /* Process the quit flag first, so that quitting doesn't get
  1245      overridden by other non-local exits.  */
  1246   maybe_quit ();
  1247 
  1248   if (r != 0)
  1249     xsignal2 (Qmodule_init_failed, file, INT_TO_INTEGER (r));
  1250 
  1251   module_signal_or_throw (&env_priv);
  1252   return unbind_to (count, Qt);
  1253 }
  1254 
  1255 Lisp_Object
  1256 funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist)
  1257 {
  1258   const struct Lisp_Module_Function *func = XMODULE_FUNCTION (function);
  1259   eassume (0 <= func->min_arity);
  1260   if (! (func->min_arity <= nargs
  1261          && (func->max_arity < 0 || nargs <= func->max_arity)))
  1262     xsignal2 (Qwrong_number_of_arguments, function, make_fixnum (nargs));
  1263 
  1264   emacs_env pub;
  1265   struct emacs_env_private priv;
  1266   emacs_env *env = initialize_environment (&pub, &priv);
  1267   specpdl_ref count = SPECPDL_INDEX ();
  1268   record_unwind_protect_module (SPECPDL_MODULE_ENVIRONMENT, env);
  1269 
  1270   USE_SAFE_ALLOCA;
  1271   emacs_value *args = nargs > 0 ? SAFE_ALLOCA (nargs * sizeof *args) : NULL;
  1272   for (ptrdiff_t i = 0; i < nargs; ++i)
  1273     {
  1274       args[i] = lisp_to_value (env, arglist[i]);
  1275       if (! args[i])
  1276         memory_full (sizeof *args[i]);
  1277     }
  1278 
  1279   /* The only possibility of getting an error until here is failure to
  1280      allocate memory for the arguments, but then we already should
  1281      have signaled an error before.  */
  1282   eassert (priv.pending_non_local_exit == emacs_funcall_exit_return);
  1283 
  1284   emacs_value ret = func->subr (env, nargs, args, func->data);
  1285 
  1286   eassert (&priv == env->private_members);
  1287 
  1288   /* Process the quit flag first, so that quitting doesn't get
  1289      overridden by other non-local exits.  */
  1290   maybe_quit ();
  1291 
  1292   module_signal_or_throw (&priv);
  1293   return SAFE_FREE_UNBIND_TO (count, value_to_lisp (ret));
  1294 }
  1295 
  1296 Lisp_Object
  1297 module_function_arity (const struct Lisp_Module_Function *const function)
  1298 {
  1299   ptrdiff_t minargs = function->min_arity;
  1300   ptrdiff_t maxargs = function->max_arity;
  1301   return Fcons (make_fixnum (minargs),
  1302                 maxargs == MANY ? Qmany : make_fixnum (maxargs));
  1303 }
  1304 
  1305 Lisp_Object
  1306 module_function_documentation (const struct Lisp_Module_Function *function)
  1307 {
  1308   return function->documentation;
  1309 }
  1310 
  1311 module_funcptr
  1312 module_function_address (const struct Lisp_Module_Function *function)
  1313 {
  1314   return (module_funcptr) function->subr;
  1315 }
  1316 
  1317 void *
  1318 module_function_data (const struct Lisp_Module_Function *function)
  1319 {
  1320   return function->data;
  1321 }
  1322 
  1323 
  1324 /* Helper functions.  */
  1325 
  1326 static void
  1327 module_assert_thread (void)
  1328 {
  1329   if (!module_assertions)
  1330     return;
  1331   if (!in_current_thread ())
  1332     module_abort ("Module function called from outside "
  1333                   "the current Lisp thread");
  1334   if (gc_in_progress)
  1335     module_abort ("Module function called during garbage collection");
  1336 }
  1337 
  1338 static void
  1339 module_assert_runtime (struct emacs_runtime *runtime)
  1340 {
  1341   if (! module_assertions)
  1342     return;
  1343   ptrdiff_t count = 0;
  1344   for (const union specbinding *pdl = specpdl; pdl != specpdl_ptr; ++pdl)
  1345     if (pdl->kind == SPECPDL_MODULE_RUNTIME)
  1346       {
  1347         if (pdl->unwind_ptr.arg == runtime)
  1348           return;
  1349         ++count;
  1350       }
  1351   module_abort ("Runtime pointer not found in list of %"pD"d runtimes",
  1352                 count);
  1353 }
  1354 
  1355 static void
  1356 module_assert_env (emacs_env *env)
  1357 {
  1358   if (! module_assertions)
  1359     return;
  1360   ptrdiff_t count = 0;
  1361   for (const union specbinding *pdl = specpdl; pdl != specpdl_ptr; ++pdl)
  1362     if (pdl->kind == SPECPDL_MODULE_ENVIRONMENT)
  1363       {
  1364         if (pdl->unwind_ptr.arg == env)
  1365           return;
  1366         ++count;
  1367       }
  1368   module_abort ("Environment pointer not found in list of %"pD"d environments",
  1369                 count);
  1370 }
  1371 
  1372 static void
  1373 module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym,
  1374                                 Lisp_Object data)
  1375 {
  1376   struct emacs_env_private *p = env->private_members;
  1377   if (p->pending_non_local_exit == emacs_funcall_exit_return)
  1378     {
  1379       p->pending_non_local_exit = emacs_funcall_exit_signal;
  1380       p->non_local_exit_symbol.v = sym;
  1381       p->non_local_exit_data.v = data;
  1382     }
  1383 }
  1384 
  1385 static void
  1386 module_non_local_exit_throw_1 (emacs_env *env, Lisp_Object tag,
  1387                                Lisp_Object value)
  1388 {
  1389   struct emacs_env_private *p = env->private_members;
  1390   if (p->pending_non_local_exit == emacs_funcall_exit_return)
  1391     {
  1392       p->pending_non_local_exit = emacs_funcall_exit_throw;
  1393       p->non_local_exit_symbol.v = tag;
  1394       p->non_local_exit_data.v = value;
  1395     }
  1396 }
  1397 
  1398 /* Signal an out-of-memory condition to the caller.  */
  1399 static void
  1400 module_out_of_memory (emacs_env *env)
  1401 {
  1402   /* TODO: Reimplement this so it works even if memory-signal-data has
  1403      been modified.  */
  1404   module_non_local_exit_signal_1 (env, XCAR (Vmemory_signal_data),
  1405                                   XCDR (Vmemory_signal_data));
  1406 }
  1407 
  1408 
  1409 /* Value conversion.  */
  1410 
  1411 /* Convert an `emacs_value' to the corresponding internal object.
  1412    Never fails.  */
  1413 
  1414 /* If V was computed from lisp_to_value (O), then return O.
  1415    Exits non-locally only if the stack overflows.  */
  1416 static Lisp_Object
  1417 value_to_lisp (emacs_value v)
  1418 {
  1419   if (module_assertions)
  1420     {
  1421       /* Check the liveness of the value by iterating over all live
  1422          environments.  */
  1423       ptrdiff_t num_environments = 0;
  1424       ptrdiff_t num_values = 0;
  1425       for (const union specbinding *pdl = specpdl; pdl != specpdl_ptr; ++pdl)
  1426         if (pdl->kind == SPECPDL_MODULE_ENVIRONMENT)
  1427           {
  1428             const emacs_env *env = pdl->unwind_ptr.arg;
  1429             struct emacs_env_private *priv = env->private_members;
  1430             /* The value might be one of the nonlocal exit values.  Note
  1431                that we don't check whether a nonlocal exit is currently
  1432                pending, because the module might have cleared the flag
  1433                in the meantime.  */
  1434             if (&priv->non_local_exit_symbol == v
  1435                 || &priv->non_local_exit_data == v)
  1436               goto ok;
  1437             if (value_storage_contains_p (&priv->storage, v, &num_values))
  1438               goto ok;
  1439             ++num_environments;
  1440           }
  1441       /* Also check global values.  */
  1442       if (module_global_reference_p (v, &num_values))
  1443         goto ok;
  1444       module_abort (("Emacs value not found in %"pD"d values "
  1445                      "of %"pD"d environments"),
  1446                     num_values, num_environments);
  1447     }
  1448 
  1449  ok: return v->v;
  1450 }
  1451 
  1452 /* Convert an internal object to an `emacs_value'.  Allocate storage
  1453    from the environment; return NULL if allocation fails.  */
  1454 static emacs_value
  1455 lisp_to_value (emacs_env *env, Lisp_Object o)
  1456 {
  1457   struct emacs_env_private *p = env->private_members;
  1458   if (p->pending_non_local_exit != emacs_funcall_exit_return)
  1459     return NULL;
  1460   return allocate_emacs_value (env, o);
  1461 }
  1462 
  1463 /* Must be called for each frame before it can be used for allocation.  */
  1464 static void
  1465 initialize_frame (struct emacs_value_frame *frame)
  1466 {
  1467   frame->offset = 0;
  1468   frame->next = NULL;
  1469 }
  1470 
  1471 /* Must be called for any storage object before it can be used for
  1472    allocation.  */
  1473 static void
  1474 initialize_storage (struct emacs_value_storage *storage)
  1475 {
  1476   initialize_frame (&storage->initial);
  1477   storage->current = &storage->initial;
  1478 }
  1479 
  1480 /* Must be called for any initialized storage object before its
  1481    lifetime ends.  Free all dynamically-allocated frames.  */
  1482 static void
  1483 finalize_storage (struct emacs_value_storage *storage)
  1484 {
  1485   struct emacs_value_frame *next = storage->initial.next;
  1486   while (next != NULL)
  1487     {
  1488       struct emacs_value_frame *current = next;
  1489       next = current->next;
  1490       free (current);
  1491     }
  1492 }
  1493 
  1494 /* Allocate a new value from STORAGE and stores OBJ in it.  Return
  1495    NULL if allocation fails and use ENV for non local exit reporting.  */
  1496 static emacs_value
  1497 allocate_emacs_value (emacs_env *env, Lisp_Object obj)
  1498 {
  1499   struct emacs_value_storage *storage = &env->private_members->storage;
  1500   eassert (storage->current);
  1501   eassert (storage->current->offset < value_frame_size);
  1502   eassert (! storage->current->next);
  1503   if (storage->current->offset == value_frame_size - 1)
  1504     {
  1505       storage->current->next = malloc (sizeof *storage->current->next);
  1506       if (! storage->current->next)
  1507         {
  1508           module_out_of_memory (env);
  1509           return NULL;
  1510         }
  1511       initialize_frame (storage->current->next);
  1512       storage->current = storage->current->next;
  1513     }
  1514   emacs_value value = storage->current->objects + storage->current->offset;
  1515   value->v = obj;
  1516   ++storage->current->offset;
  1517   return value;
  1518 }
  1519 
  1520 /* Mark all objects allocated from local environments so that they
  1521    don't get garbage-collected.  */
  1522 void
  1523 mark_module_environment (void *ptr)
  1524 {
  1525   emacs_env *env = ptr;
  1526   struct emacs_env_private *priv = env->private_members;
  1527   for (struct emacs_value_frame *frame = &priv->storage.initial; frame != NULL;
  1528        frame = frame->next)
  1529     for (int i = 0; i < frame->offset; ++i)
  1530       mark_object (frame->objects[i].v);
  1531 }
  1532 
  1533 
  1534 /* Environment lifetime management.  */
  1535 
  1536 /* Must be called before the environment can be used.  Returns another
  1537    pointer that callers should use instead of the ENV argument.  If
  1538    module assertions are disabled, the return value is ENV.  If module
  1539    assertions are enabled, the return value points to a heap-allocated
  1540    object.  That object is never freed to guarantee unique
  1541    addresses.  */
  1542 static emacs_env *
  1543 initialize_environment (emacs_env *env, struct emacs_env_private *priv)
  1544 {
  1545   if (module_assertions)
  1546     {
  1547       env = xmalloc (sizeof *env);
  1548       __lsan_ignore_object (env);
  1549     }
  1550 
  1551   priv->pending_non_local_exit = emacs_funcall_exit_return;
  1552   initialize_storage (&priv->storage);
  1553   env->size = sizeof *env;
  1554   env->private_members = priv;
  1555   env->make_global_ref = module_make_global_ref;
  1556   env->free_global_ref = module_free_global_ref;
  1557   env->non_local_exit_check = module_non_local_exit_check;
  1558   env->non_local_exit_clear = module_non_local_exit_clear;
  1559   env->non_local_exit_get = module_non_local_exit_get;
  1560   env->non_local_exit_signal = module_non_local_exit_signal;
  1561   env->non_local_exit_throw = module_non_local_exit_throw;
  1562   env->make_function = module_make_function;
  1563   env->funcall = module_funcall;
  1564   env->intern = module_intern;
  1565   env->type_of = module_type_of;
  1566   env->is_not_nil = module_is_not_nil;
  1567   env->eq = module_eq;
  1568   env->extract_integer = module_extract_integer;
  1569   env->make_integer = module_make_integer;
  1570   env->extract_float = module_extract_float;
  1571   env->make_float = module_make_float;
  1572   env->copy_string_contents = module_copy_string_contents;
  1573   env->make_string = module_make_string;
  1574   env->make_unibyte_string = module_make_unibyte_string;
  1575   env->make_user_ptr = module_make_user_ptr;
  1576   env->get_user_ptr = module_get_user_ptr;
  1577   env->set_user_ptr = module_set_user_ptr;
  1578   env->get_user_finalizer = module_get_user_finalizer;
  1579   env->set_user_finalizer = module_set_user_finalizer;
  1580   env->vec_set = module_vec_set;
  1581   env->vec_get = module_vec_get;
  1582   env->vec_size = module_vec_size;
  1583   env->should_quit = module_should_quit;
  1584   env->process_input = module_process_input;
  1585   env->extract_time = module_extract_time;
  1586   env->make_time = module_make_time;
  1587   env->extract_big_integer = module_extract_big_integer;
  1588   env->make_big_integer = module_make_big_integer;
  1589   env->get_function_finalizer = module_get_function_finalizer;
  1590   env->set_function_finalizer = module_set_function_finalizer;
  1591   env->open_channel = module_open_channel;
  1592   env->make_interactive = module_make_interactive;
  1593   return env;
  1594 }
  1595 
  1596 /* Must be called before the lifetime of the environment object
  1597    ends.  */
  1598 static void
  1599 finalize_environment (emacs_env *env)
  1600 {
  1601   finalize_storage (&env->private_members->storage);
  1602 }
  1603 
  1604 void
  1605 finalize_environment_unwind (void *env)
  1606 {
  1607   finalize_environment (env);
  1608 }
  1609 
  1610 void
  1611 finalize_runtime_unwind (void *raw_ert)
  1612 {
  1613   /* No further cleanup is required, as the initial environment is
  1614      unwound separately.  See the logic in Fmodule_load.  */
  1615 }
  1616 
  1617 
  1618 /* Non-local exit handling.  */
  1619 
  1620 /* Must be called after setting up a handler immediately before
  1621    returning from the function.  See the comments in lisp.h and the
  1622    code in eval.c for details.  The macros below arrange for this
  1623    function to be called automatically.  IHANDLERLIST points to the
  1624    handler list.  */
  1625 
  1626 static void
  1627 module_reset_handlerlist (struct handler *ihandlerlist)
  1628 {
  1629   eassert (handlerlist == ihandlerlist);
  1630   handlerlist = handlerlist->next;
  1631 }
  1632 
  1633 /* Called on `signal' and `throw'.  DATA is a pair
  1634    (ERROR-SYMBOL . ERROR-DATA) or (TAG . VALUE), which gets stored in
  1635    the environment.  Set the pending non-local exit flag.  */
  1636 static void
  1637 module_handle_nonlocal_exit (emacs_env *env, enum nonlocal_exit type,
  1638                              Lisp_Object data)
  1639 {
  1640   switch (type)
  1641     {
  1642     case NONLOCAL_EXIT_SIGNAL:
  1643       module_non_local_exit_signal_1 (env, XCAR (data), XCDR (data));
  1644       break;
  1645     case NONLOCAL_EXIT_THROW:
  1646       module_non_local_exit_throw_1 (env, XCAR (data), XCDR (data));
  1647       break;
  1648     }
  1649 }
  1650 
  1651 
  1652 /* Support for assertions.  */
  1653 void
  1654 init_module_assertions (bool enable)
  1655 {
  1656   module_assertions = enable;
  1657 }
  1658 
  1659 /* Return whether STORAGE contains VALUE.  Used to check module
  1660    assertions.  Increment *COUNT by the number of values searched.  */
  1661 
  1662 static bool
  1663 value_storage_contains_p (const struct emacs_value_storage *storage,
  1664                           emacs_value value, ptrdiff_t *count)
  1665 {
  1666   for (const struct emacs_value_frame *frame = &storage->initial; frame != NULL;
  1667        frame = frame->next)
  1668     {
  1669       for (int i = 0; i < frame->offset; ++i)
  1670         {
  1671           if (&frame->objects[i] == value)
  1672             return true;
  1673           ++*count;
  1674         }
  1675     }
  1676   return false;
  1677 }
  1678 
  1679 static AVOID ATTRIBUTE_FORMAT_PRINTF (1, 2)
  1680 module_abort (const char *format, ...)
  1681 {
  1682   fputs ("Emacs module assertion: ", stderr);
  1683   va_list args;
  1684   va_start (args, format);
  1685   vfprintf (stderr, format, args);
  1686   va_end (args);
  1687   putc ('\n', stderr);
  1688   fflush (NULL);
  1689   emacs_abort ();
  1690 }
  1691 
  1692 
  1693 /* Segment initializer.  */
  1694 
  1695 void
  1696 syms_of_module (void)
  1697 {
  1698   staticpro (&Vmodule_refs_hash);
  1699   Vmodule_refs_hash
  1700     = make_hash_table (hashtest_eq, DEFAULT_HASH_SIZE,
  1701                        DEFAULT_REHASH_SIZE, DEFAULT_REHASH_THRESHOLD,
  1702                        Qnil, false);
  1703 
  1704   DEFSYM (Qmodule_load_failed, "module-load-failed");
  1705   Fput (Qmodule_load_failed, Qerror_conditions,
  1706         pure_list (Qmodule_load_failed, Qerror));
  1707   Fput (Qmodule_load_failed, Qerror_message,
  1708         build_pure_c_string ("Module load failed"));
  1709 
  1710   DEFSYM (Qmodule_open_failed, "module-open-failed");
  1711   Fput (Qmodule_open_failed, Qerror_conditions,
  1712         pure_list (Qmodule_open_failed, Qmodule_load_failed, Qerror));
  1713   Fput (Qmodule_open_failed, Qerror_message,
  1714         build_pure_c_string ("Module could not be opened"));
  1715 
  1716   DEFSYM (Qmodule_not_gpl_compatible, "module-not-gpl-compatible");
  1717   Fput (Qmodule_not_gpl_compatible, Qerror_conditions,
  1718         pure_list (Qmodule_not_gpl_compatible, Qmodule_load_failed, Qerror));
  1719   Fput (Qmodule_not_gpl_compatible, Qerror_message,
  1720         build_pure_c_string ("Module is not GPL compatible"));
  1721 
  1722   DEFSYM (Qmissing_module_init_function, "missing-module-init-function");
  1723   Fput (Qmissing_module_init_function, Qerror_conditions,
  1724         pure_list (Qmissing_module_init_function, Qmodule_load_failed,
  1725                    Qerror));
  1726   Fput (Qmissing_module_init_function, Qerror_message,
  1727         build_pure_c_string ("Module does not export an "
  1728                              "initialization function"));
  1729 
  1730   DEFSYM (Qmodule_init_failed, "module-init-failed");
  1731   Fput (Qmodule_init_failed, Qerror_conditions,
  1732         pure_list (Qmodule_init_failed, Qmodule_load_failed, Qerror));
  1733   Fput (Qmodule_init_failed, Qerror_message,
  1734         build_pure_c_string ("Module initialization failed"));
  1735 
  1736   DEFSYM (Qinvalid_arity, "invalid-arity");
  1737   Fput (Qinvalid_arity, Qerror_conditions, pure_list (Qinvalid_arity, Qerror));
  1738   Fput (Qinvalid_arity, Qerror_message,
  1739         build_pure_c_string ("Invalid function arity"));
  1740 
  1741   DEFSYM (Qmodule_function_p, "module-function-p");
  1742   DEFSYM (Qunicode_string_p, "unicode-string-p");
  1743 
  1744   defsubr (&Smodule_load);
  1745 }
/* [<][>][^][v][top][bottom][index][help] */
root/src/emacs-module.c

DEFINITIONS
