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

DEFINITIONS
