1 /* module.c - Module loading and runtime implementation
3 Copyright (C) 2015 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
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
10 (at your option) any later version.
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.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
36 /* 1 if we have __attribute__((cleanup(...))), 0 otherwise */
38 #ifdef HAVE_VAR_ATTRIBUTE_CLEANUP
45 /* Handle to the main thread. Used to verify that modules call us in
47 #if defined(HAVE_THREADS_H)
49 static thrd_t main_thread
;
50 #elif defined(HAVE_PTHREAD)
52 static pthread_t main_thread
;
53 #elif defined(WINDOWSNT)
55 /* On Windows, we store both a handle to the main thread and the
56 thread ID because the latter can be reused when a thread
58 static HANDLE main_thread
;
59 static DWORD main_thread_id
;
63 /* Implementation of runtime and environment functions */
65 static emacs_env
* module_get_environment (struct emacs_runtime
*ert
);
67 static emacs_value
module_make_global_ref (emacs_env
*env
,
69 static void module_free_global_ref (emacs_env
*env
,
71 static enum emacs_funcall_exit
module_non_local_exit_check (emacs_env
*env
);
72 static void module_non_local_exit_clear (emacs_env
*env
);
73 static enum emacs_funcall_exit
module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
);
74 static void module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
);
75 static void module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
);
76 static emacs_value
module_make_function (emacs_env
*env
,
80 const char *documentation
,
82 static emacs_value
module_funcall (emacs_env
*env
,
86 static emacs_value
module_intern (emacs_env
*env
, const char *name
);
87 static emacs_value
module_type_of (emacs_env
*env
, emacs_value value
);
88 static bool module_is_not_nil (emacs_env
*env
, emacs_value value
);
89 static bool module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
);
90 static int64_t module_extract_integer (emacs_env
*env
, emacs_value n
);
91 static emacs_value
module_make_integer (emacs_env
*env
, int64_t n
);
92 static emacs_value
module_make_float (emacs_env
*env
, double d
);
93 static double module_extract_float (emacs_env
*env
, emacs_value f
);
94 static bool module_copy_string_contents (emacs_env
*env
,
98 static emacs_value
module_make_string (emacs_env
*env
, const char *str
, size_t lenght
);
99 static emacs_value
module_make_user_ptr (emacs_env
*env
,
100 emacs_finalizer_function fin
,
102 static void* module_get_user_ptr (emacs_env
*env
, emacs_value uptr
);
103 static void module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
);
104 static emacs_finalizer_function
module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
);
105 static void module_set_user_finalizer (emacs_env
*env
,
107 emacs_finalizer_function fin
);
110 /* Helper functions */
112 /* If checking is enabled, abort if the current thread is not the
113 Emacs main thread. */
114 static void check_main_thread (void);
116 /* Internal versions of `module_non_local_exit_signal' and `module_non_local_exit_throw'. */
117 static void module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
, Lisp_Object data
);
118 static void module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
, Lisp_Object value
);
120 /* Module version of `wrong_type_argument'. */
121 static void module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
);
123 /* Signal an out-of-memory condition to the caller. */
124 static void module_out_of_memory (emacs_env
*env
);
126 /* Signal arguments are out of range. */
127 static void module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
);
130 /* Value conversion */
132 /* Converts an `emacs_value' to the corresponding internal object.
134 static Lisp_Object
value_to_lisp (emacs_value v
);
136 /* Converts an internal object to an `emacs_value'. Allocates storage
137 from the environment; returns NULL if allocation fails. */
138 static emacs_value
lisp_to_value (emacs_env
*env
, Lisp_Object o
);
141 /* Memory management */
143 /* An `emacs_value' is just a pointer to a structure holding an
144 internal Lisp object. */
145 struct emacs_value_tag
{ Lisp_Object v
; };
147 /* Local value objects use a simple fixed-sized block allocation
148 scheme without explicit deallocation. All local values are
149 deallocated when the lifetime of their environment ends. We keep
150 track of a current frame from which new values are allocated,
151 appending further dynamically-allocated frames if necessary. */
153 enum { value_frame_size
= 512 };
155 /* A block from which `emacs_value' object can be allocated. */
156 struct emacs_value_frame
{
157 /* Storage for values */
158 struct emacs_value_tag objects
[value_frame_size
];
160 /* Index of the next free value in `objects' */
163 /* Pointer to next frame, if any */
164 struct emacs_value_frame
*next
;
167 /* Must be called for each frame before it can be used for
169 static void initialize_frame (struct emacs_value_frame
*frame
);
171 /* A structure that holds an initial frame (so that the first local
172 values require no dynamic allocation) and keeps track of the
174 static struct emacs_value_storage
{
175 struct emacs_value_frame initial
;
176 struct emacs_value_frame
*current
;
179 /* Must be called for any storage object before it can be used for
181 static void initialize_storage (struct emacs_value_storage
*storage
);
183 /* Must be called for any initialized storage object before its
184 lifetime ends. Frees all dynamically-allocated frames. */
185 static void finalize_storage (struct emacs_value_storage
*storage
);
187 /* Allocates a new value from STORAGE and stores OBJ in it. Returns
188 NULL if allocations fails and uses ENV for non local exit reporting. */
189 static emacs_value
allocate_emacs_value (emacs_env
*env
, struct emacs_value_storage
*storage
,
193 /* Private runtime and environment members */
195 /* The private part of an environment stores the current non local exit state
196 and holds the `emacs_value' objects allocated during the lifetime
197 of the environment. */
198 struct emacs_env_private
{
199 enum emacs_funcall_exit pending_non_local_exit
;
201 /* Dedicated storage for non-local exit symbol and data so that we always
202 have storage available for them, even in an out-of-memory
204 struct emacs_value_tag non_local_exit_symbol
, non_local_exit_data
;
206 struct emacs_value_storage storage
;
209 /* Combines public and private parts in one structure. This structure
210 is used whenever an environment is created. */
213 struct emacs_env_private priv
;
216 /* Must be called before the environment can be used. */
217 static void initialize_environment (struct env_storage
*env
);
219 /* Must be called before the lifetime of the environment object
221 static void finalize_environment (struct env_storage
*env
);
223 /* The private parts of an `emacs_runtime' object contain the initial
225 struct emacs_runtime_private
{
226 struct env_storage environment
;
230 /* Convenience macros for non-local exit handling */
232 /* Emacs uses setjmp(3) and longjmp(3) for non-local exits, but we
233 can't allow module frames to be skipped because they are in general
234 not prepared for long jumps (e.g. the behavior in C++ is undefined
235 if objects with nontrivial destructors would be skipped).
236 Therefore we catch all non-local exits. There are two kinds of
237 non-local exits: `signal' and `throw'. The macros in this section
238 can be used to catch both. We use macros so that we don't have to
239 write lots of additional variants of `internal_condition_case'
240 etc. and don't have to worry about passing information to the
241 handler functions. */
243 /* Called on `signal'. ERR will be a cons cell (SYMBOL . DATA), which
244 gets stored in the environment. Sets the pending non-local exit flag. */
245 static void module_handle_signal (emacs_env
*env
, Lisp_Object err
);
247 /* Called on `throw'. TAG_VAL will be a cons cell (TAG . VALUE),
248 which gets stored in the environment. Sets the pending non-local exit
250 static void module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
);
252 /* Must be called after setting up a handler immediately before
253 returning from the function. See the comments in lisp.h and the
254 code in eval.c for details. The macros below arrange for this
255 function to be called automatically. DUMMY is ignored. */
256 static void module_reset_handlerlist (const int *dummy
);
258 /* Place this macro at the beginning of a function returning a number
259 or a pointer to handle signals. The function must have an ENV
260 parameter. The function will return 0 (or NULL) if a signal is
262 #define MODULE_HANDLE_SIGNALS MODULE_HANDLE_SIGNALS_RETURN(0)
264 /* Place this macro at the beginning of a function returning void to
265 handle signals. The function must have an ENV parameter. */
266 #define MODULE_HANDLE_SIGNALS_VOID MODULE_HANDLE_SIGNALS_RETURN()
268 #define MODULE_HANDLE_SIGNALS_RETURN(retval) \
269 MODULE_SETJMP(CONDITION_CASE, module_handle_signal, retval)
271 /* Place this macro at the beginning of a function returning a pointer
272 to handle non-local exits via `throw'. The function must have an
273 ENV parameter. The function will return NULL if a `throw' is
275 #define MODULE_HANDLE_THROW \
276 MODULE_SETJMP(CATCHER_ALL, module_handle_throw, NULL)
278 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
279 MODULE_SETJMP_1(handlertype, handlerfunc, retval, \
280 internal_handler_##handlertype, \
281 internal_cleanup_##handlertype)
283 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
284 eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); \
286 /* It is very important that pushing the handler doesn't itself raise a \
288 if (!push_handler_nosignal(&c, Qt, handlertype)) { \
289 module_out_of_memory(env); \
292 verify(module_has_cleanup); \
293 /* We can install the cleanup only after the handler has been pushed. Use \
294 __attribute__((cleanup)) to avoid non-local-exit-prone manual cleanup. */ \
295 const int dummy __attribute__((cleanup(module_reset_handlerlist))); \
296 if (sys_setjmp(c->jmp)) { \
297 (handlerfunc)(env, c->val); \
300 /* Force the macro to be followed by a semicolon. */ \
305 /* Function environments */
307 /* A function environment is an auxiliary structure used by
308 `module_make_function' to store information about a module
309 function. It is stored in a save pointer and retrieved by
310 `module-call'. Its members correspond to the arguments given to
311 `module_make_function'. */
313 struct module_fun_env
315 int min_arity
, max_arity
;
320 /* Returns a string object that contains a user-friendly
321 representation of the function environment. */
322 static Lisp_Object
module_format_fun_env (const struct module_fun_env
*env
);
324 /* Holds the function definition of `module-call'. `module-call' is
325 uninterned because user code couldn't meaningfully use it, so we
326 have to keep its definition around somewhere else. */
327 static Lisp_Object module_call_func
;
330 /* Implementation of runtime and environment functions */
332 /* We catch signals and throws only if the code can actually signal or
335 static emacs_env
* module_get_environment (struct emacs_runtime
*ert
)
337 check_main_thread ();
338 return &ert
->private_members
->environment
.pub
;
342 * To make global refs (GC-protected global values) we keep a hash
343 * that maps global Lisp objects to reference counts.
346 static emacs_value
module_make_global_ref (emacs_env
*env
,
349 check_main_thread ();
350 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
351 MODULE_HANDLE_SIGNALS
;
352 eassert (HASH_TABLE_P (Vmodule_refs_hash
));
353 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
354 Lisp_Object new_obj
= value_to_lisp (ref
);
356 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
360 Lisp_Object value
= HASH_VALUE (h
, i
);
361 eassert (NATNUMP (value
));
362 const EMACS_UINT refcount
= XFASTINT (value
);
363 if (refcount
>= MOST_POSITIVE_FIXNUM
)
365 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
368 XSETFASTINT (value
, refcount
+ 1);
369 set_hash_value_slot (h
, i
, value
);
373 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
376 return allocate_emacs_value (env
, &global_storage
, new_obj
);
379 static void module_free_global_ref (emacs_env
*env
,
382 check_main_thread ();
383 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
384 /* TODO: This probably never signals. */
385 MODULE_HANDLE_SIGNALS_VOID
;
386 eassert (HASH_TABLE_P (Vmodule_refs_hash
));
387 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
388 Lisp_Object obj
= value_to_lisp (ref
);
390 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
394 Lisp_Object value
= HASH_VALUE (h
, i
);
395 eassert (NATNUMP (value
));
396 const EMACS_UINT refcount
= XFASTINT (value
);
397 eassert (refcount
> 0);
400 XSETFASTINT (value
, refcount
- 1);
401 set_hash_value_slot (h
, i
, value
);
405 hash_remove_from_table (h
, value
);
410 static enum emacs_funcall_exit
module_non_local_exit_check (emacs_env
*env
)
412 check_main_thread ();
413 return env
->private_members
->pending_non_local_exit
;
416 static void module_non_local_exit_clear (emacs_env
*env
)
418 check_main_thread ();
419 env
->private_members
->pending_non_local_exit
= emacs_funcall_exit_return
;
422 static enum emacs_funcall_exit
module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
)
424 check_main_thread ();
425 struct emacs_env_private
*const p
= env
->private_members
;
426 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
428 *sym
= &p
->non_local_exit_symbol
;
429 *data
= &p
->non_local_exit_data
;
431 return p
->pending_non_local_exit
;
435 * Like for `signal', DATA must be a list
437 static void module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
)
439 check_main_thread ();
440 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
441 module_non_local_exit_signal_1 (env
, value_to_lisp (sym
), value_to_lisp (data
));
444 static void module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
)
446 check_main_thread ();
447 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
448 module_non_local_exit_throw_1 (env
, value_to_lisp (tag
), value_to_lisp (value
));
452 * A module function is lambda function that calls `module-call',
453 * passing the function pointer of the module function along with the
454 * module emacs_env pointer as arguments.
464 static emacs_value
module_make_function (emacs_env
*env
,
468 const char *const documentation
,
471 check_main_thread ();
472 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
473 MODULE_HANDLE_SIGNALS
;
475 if (min_arity
> MOST_POSITIVE_FIXNUM
|| max_arity
> MOST_POSITIVE_FIXNUM
)
476 xsignal0 (Qoverflow_error
);
479 (max_arity
>= 0 && max_arity
< min_arity
) ||
480 (max_arity
< 0 && max_arity
!= emacs_variadic_function
))
481 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
485 /* XXX: This should need to be freed when envobj is GC'd */
486 struct module_fun_env
*envptr
= xzalloc (sizeof (*envptr
));
487 envptr
->min_arity
= min_arity
;
488 envptr
->max_arity
= max_arity
;
491 envobj
= make_save_ptr (envptr
);
493 Lisp_Object ret
= list4 (Qlambda
,
494 list2 (Qand_rest
, Qargs
),
495 documentation
? build_string (documentation
) : Qnil
,
496 list3 (module_call_func
,
500 return lisp_to_value (env
, ret
);
503 static emacs_value
module_funcall (emacs_env
*env
,
508 check_main_thread ();
509 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
510 MODULE_HANDLE_SIGNALS
;
514 * Make a new Lisp_Object array starting with the function as the
515 * first arg, because that's what Ffuncall takes
517 Lisp_Object newargs
[nargs
+ 1];
518 newargs
[0] = value_to_lisp (fun
);
519 for (int i
= 0; i
< nargs
; i
++)
520 newargs
[1 + i
] = value_to_lisp (args
[i
]);
521 return lisp_to_value (env
, Ffuncall (nargs
+ 1, newargs
));
524 static emacs_value
module_intern (emacs_env
*env
, const char *name
)
526 check_main_thread ();
527 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
528 MODULE_HANDLE_SIGNALS
;
529 return lisp_to_value (env
, intern (name
));
532 static emacs_value
module_type_of (emacs_env
*env
, emacs_value value
)
534 check_main_thread ();
535 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
536 return lisp_to_value (env
, Ftype_of (value_to_lisp (value
)));
539 static bool module_is_not_nil (emacs_env
*env
, emacs_value value
)
541 check_main_thread ();
542 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
543 return ! NILP (value_to_lisp (value
));
546 static bool module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
548 check_main_thread ();
549 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
550 return EQ (value_to_lisp (a
), value_to_lisp (b
));
553 static int64_t module_extract_integer (emacs_env
*env
, emacs_value n
)
555 verify (INT64_MIN
<= MOST_NEGATIVE_FIXNUM
);
556 verify (INT64_MAX
>= MOST_POSITIVE_FIXNUM
);
557 check_main_thread ();
558 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
559 const Lisp_Object l
= value_to_lisp (n
);
562 module_wrong_type (env
, Qintegerp
, l
);
568 static emacs_value
module_make_integer (emacs_env
*env
, int64_t n
)
570 check_main_thread ();
571 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
572 if (n
< MOST_NEGATIVE_FIXNUM
)
574 module_non_local_exit_signal_1 (env
, Qunderflow_error
, Qnil
);
577 if (n
> MOST_POSITIVE_FIXNUM
)
579 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
582 return lisp_to_value (env
, make_number (n
));
585 static double module_extract_float (emacs_env
*env
, emacs_value f
)
587 check_main_thread ();
588 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
589 const Lisp_Object lisp
= value_to_lisp (f
);
592 module_wrong_type (env
, Qfloatp
, lisp
);
595 return XFLOAT_DATA (lisp
);
598 static emacs_value
module_make_float (emacs_env
*env
, double d
)
600 check_main_thread ();
601 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
602 MODULE_HANDLE_SIGNALS
;
603 return lisp_to_value (env
, make_float (d
));
606 static bool module_copy_string_contents (emacs_env
*env
,
611 check_main_thread ();
612 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
613 MODULE_HANDLE_SIGNALS
;
614 Lisp_Object lisp_str
= value_to_lisp (value
);
615 if (! STRINGP (lisp_str
))
617 module_wrong_type (env
, Qstringp
, lisp_str
);
621 size_t raw_size
= SBYTES (lisp_str
);
624 * Emacs internal encoding is more-or-less UTF8, let's assume utf8
625 * encoded emacs string are the same byte size.
628 if (!buffer
|| length
== 0 || *length
-1 < raw_size
)
630 *length
= raw_size
+ 1;
634 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
635 eassert (raw_size
== SBYTES (lisp_str_utf8
));
636 *length
= raw_size
+ 1;
637 memcpy (buffer
, SDATA (lisp_str_utf8
), SBYTES (lisp_str_utf8
));
638 buffer
[raw_size
] = 0;
643 static emacs_value
module_make_string (emacs_env
*env
, const char *str
, size_t length
)
645 check_main_thread ();
646 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
647 MODULE_HANDLE_SIGNALS
;
648 if (length
> PTRDIFF_MAX
)
650 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
653 /* Assume STR is utf8 encoded */
654 return lisp_to_value (env
, make_string (str
, length
));
657 static emacs_value
module_make_user_ptr (emacs_env
*env
,
658 emacs_finalizer_function fin
,
661 check_main_thread ();
662 return lisp_to_value (env
, make_user_ptr (fin
, ptr
));
665 static void* module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
667 check_main_thread ();
668 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
669 const Lisp_Object lisp
= value_to_lisp (uptr
);
670 if (! USER_PTRP (lisp
))
672 module_wrong_type (env
, Quser_ptr
, lisp
);
675 return XUSER_PTR (lisp
)->p
;
678 static void module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
680 check_main_thread ();
681 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
682 const Lisp_Object lisp
= value_to_lisp (uptr
);
683 if (! USER_PTRP (lisp
)) module_wrong_type (env
, Quser_ptr
, lisp
);
684 XUSER_PTR (lisp
)->p
= ptr
;
687 static emacs_finalizer_function
module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
689 check_main_thread ();
690 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
691 const Lisp_Object lisp
= value_to_lisp (uptr
);
692 if (! USER_PTRP (lisp
))
694 module_wrong_type (env
, Quser_ptr
, lisp
);
697 return XUSER_PTR (lisp
)->finalizer
;
700 static void module_set_user_finalizer (emacs_env
*env
,
702 emacs_finalizer_function fin
)
704 check_main_thread ();
705 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
706 const Lisp_Object lisp
= value_to_lisp (uptr
);
707 if (! USER_PTRP (lisp
)) module_wrong_type (env
, Quser_ptr
, lisp
);
708 XUSER_PTR (lisp
)->finalizer
= fin
;
711 static void module_vec_set (emacs_env
*env
,
716 check_main_thread ();
717 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
718 if (i
> MOST_POSITIVE_FIXNUM
)
720 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
723 Lisp_Object lvec
= value_to_lisp (vec
);
724 if (! VECTORP (lvec
))
726 module_wrong_type (env
, Qvectorp
, lvec
);
729 if (i
>= ASIZE (lvec
))
731 module_args_out_of_range (env
, lvec
, make_number (i
));
734 ASET (lvec
, i
, value_to_lisp (val
));
737 static emacs_value
module_vec_get (emacs_env
*env
,
741 /* Type of ASIZE (lvec) is ptrdiff_t, make sure it fits */
742 verify (PTRDIFF_MAX
<= SIZE_MAX
);
743 check_main_thread ();
744 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
745 if (i
> MOST_POSITIVE_FIXNUM
)
747 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
750 Lisp_Object lvec
= value_to_lisp (vec
);
751 if (! VECTORP (lvec
))
753 module_wrong_type (env
, Qvectorp
, lvec
);
756 /* Prevent error-prone comparison between types of different signedness. */
757 const size_t size
= ASIZE (lvec
);
761 if (i
> MOST_POSITIVE_FIXNUM
)
762 i
= (size_t) MOST_POSITIVE_FIXNUM
;
763 module_args_out_of_range (env
, lvec
, make_number (i
));
766 return lisp_to_value (env
, AREF (lvec
, i
));
769 static size_t module_vec_size (emacs_env
*env
,
772 /* Type of ASIZE (lvec) is ptrdiff_t, make sure it fits */
773 verify (PTRDIFF_MAX
<= SIZE_MAX
);
774 check_main_thread ();
775 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
776 Lisp_Object lvec
= value_to_lisp (vec
);
777 if (! VECTORP (lvec
))
779 module_wrong_type (env
, Qvectorp
, lvec
);
782 eassert (ASIZE (lvec
) >= 0);
789 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
790 doc
: /* Load module FILE. */)
793 dynlib_handle_ptr handle
;
794 emacs_init_function module_init
;
798 handle
= dynlib_open (SDATA (file
));
800 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
802 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
804 error ("Module %s is not GPL compatible", SDATA (file
));
806 module_init
= (emacs_init_function
) dynlib_sym (handle
, "emacs_module_init");
808 error ("Module %s does not have an init function.", SDATA (file
));
811 struct emacs_runtime pub
;
812 struct emacs_runtime_private priv
;
815 .size
= sizeof runtime
.pub
,
816 .get_environment
= module_get_environment
,
817 .private_members
= &runtime
.priv
820 initialize_environment (&runtime
.priv
.environment
);
821 int r
= module_init (&runtime
.pub
);
822 finalize_environment (&runtime
.priv
.environment
);
826 if (r
< MOST_NEGATIVE_FIXNUM
)
827 xsignal0 (Qunderflow_error
);
828 if (r
> MOST_POSITIVE_FIXNUM
)
829 xsignal0 (Qoverflow_error
);
830 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
836 DEFUN ("module-call", Fmodule_call
, Smodule_call
, 2, 2, 0,
837 doc
: /* Internal function to call a module function.
838 ENVOBJ is a save pointer to a module_fun_env structure.
839 ARGLIST is a list of arguments passed to SUBRPTR. */)
840 (Lisp_Object envobj
, Lisp_Object arglist
)
842 const struct module_fun_env
*const envptr
=
843 (const struct module_fun_env
*) XSAVE_POINTER (envobj
, 0);
844 const EMACS_INT len
= XINT (Flength (arglist
));
846 if (len
> MOST_POSITIVE_FIXNUM
)
847 xsignal0 (Qoverflow_error
);
848 if (len
> INT_MAX
|| len
< envptr
->min_arity
|| (envptr
->max_arity
>= 0 && len
> envptr
->max_arity
))
849 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
), make_number (len
));
851 struct env_storage env
;
852 initialize_environment (&env
);
854 emacs_value
*args
= xzalloc (len
* sizeof (*args
));
857 for (i
= 0; i
< len
; i
++)
859 args
[i
] = lisp_to_value (&env
.pub
, XCAR (arglist
));
860 if (! args
[i
]) memory_full (sizeof *args
[i
]);
861 arglist
= XCDR (arglist
);
864 emacs_value ret
= envptr
->subr (&env
.pub
, len
, args
, envptr
->data
);
867 switch (env
.priv
.pending_non_local_exit
)
869 case emacs_funcall_exit_return
:
870 finalize_environment (&env
);
871 if (ret
== NULL
) xsignal1 (Qinvalid_module_call
, module_format_fun_env (envptr
));
872 return value_to_lisp (ret
);
873 case emacs_funcall_exit_signal
:
875 const Lisp_Object symbol
= value_to_lisp (&env
.priv
.non_local_exit_symbol
);
876 const Lisp_Object data
= value_to_lisp (&env
.priv
.non_local_exit_data
);
877 finalize_environment (&env
);
878 xsignal (symbol
, data
);
880 case emacs_funcall_exit_throw
:
882 const Lisp_Object tag
= value_to_lisp (&env
.priv
.non_local_exit_symbol
);
883 const Lisp_Object value
= value_to_lisp (&env
.priv
.non_local_exit_data
);
884 finalize_environment (&env
);
891 /* Helper functions */
893 static void check_main_thread (void)
895 #if defined(HAVE_THREADS_H)
896 eassert (thrd_equal (thdr_current (), main_thread
);
897 #elif defined(HAVE_PTHREAD)
898 eassert (pthread_equal (pthread_self (), main_thread
));
899 #elif defined(WINDOWSNT)
900 /* CompareObjectHandles would be perfect, but is only available in
901 Windows 10. Also check whether the thread is still running to
902 protect against thread identifier reuse. */
903 eassert (GetCurrentThreadId () == main_thread_id
904 && WaitForSingleObject (main_thread
, 0) == WAIT_TIMEOUT
);
908 static void module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
, Lisp_Object data
)
910 struct emacs_env_private
*const p
= env
->private_members
;
911 eassert (p
->pending_non_local_exit
== emacs_funcall_exit_return
);
912 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
913 p
->non_local_exit_symbol
.v
= sym
;
914 p
->non_local_exit_data
.v
= data
;
917 static void module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
, Lisp_Object value
)
919 struct emacs_env_private
*const p
= env
->private_members
;
920 eassert (p
->pending_non_local_exit
== emacs_funcall_exit_return
);
921 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
922 p
->non_local_exit_symbol
.v
= tag
;
923 p
->non_local_exit_data
.v
= value
;
926 static void module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
)
928 module_non_local_exit_signal_1 (env
, Qwrong_type_argument
, list2 (predicate
, value
));
931 static void module_out_of_memory (emacs_env
*env
)
933 // TODO: Reimplement this so it works even if memory-signal-data has been modified.
934 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
), XCDR (Vmemory_signal_data
));
937 static void module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
)
939 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, list2 (a1
, a2
));
943 /* Value conversion */
945 static Lisp_Object
value_to_lisp (emacs_value v
)
950 static emacs_value
lisp_to_value (emacs_env
*env
, Lisp_Object o
)
952 struct emacs_env_private
*const p
= env
->private_members
;
953 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
) return NULL
;
954 return allocate_emacs_value (env
, &p
->storage
, o
);
958 /* Memory management */
960 static void initialize_frame (struct emacs_value_frame
*frame
)
966 static void initialize_storage (struct emacs_value_storage
*storage
)
968 initialize_frame (&storage
->initial
);
969 storage
->current
= &storage
->initial
;
972 static void finalize_storage (struct emacs_value_storage
*storage
)
974 struct emacs_value_frame
*next
= storage
->initial
.next
;
977 struct emacs_value_frame
*const current
= next
;
978 next
= current
->next
;
983 static emacs_value
allocate_emacs_value (emacs_env
*env
, struct emacs_value_storage
*storage
,
986 eassert (storage
->current
);
987 eassert (storage
->current
->offset
< value_frame_size
);
988 eassert (! storage
->current
->next
);
989 if (storage
->current
->offset
== value_frame_size
- 1)
991 storage
->current
->next
= malloc (sizeof *storage
->current
->next
);
992 if (! storage
->current
->next
)
994 module_out_of_memory (env
);
997 initialize_frame (storage
->current
->next
);
998 storage
->current
= storage
->current
->next
;
1000 const emacs_value value
= storage
->current
->objects
+ storage
->current
->offset
;
1002 ++storage
->current
->offset
;
1006 /* Mark all objects allocated from local environments so that they
1007 don't get garbage-collected. */
1008 void mark_modules (void)
1010 for (Lisp_Object tem
= Vmodule_environments
; CONSP (tem
); tem
= XCDR (tem
))
1012 const struct env_storage
*const env
= XSAVE_POINTER (tem
, 0);
1013 for (const struct emacs_value_frame
*frame
= &env
->priv
.storage
.initial
; frame
!= NULL
; frame
= frame
->next
)
1014 for (size_t i
= 0; i
< frame
->offset
; ++i
)
1015 mark_object (frame
->objects
[i
].v
);
1020 /* Environment lifetime management */
1022 static void initialize_environment (struct env_storage
*env
)
1024 env
->priv
.pending_non_local_exit
= emacs_funcall_exit_return
;
1025 initialize_storage (&env
->priv
.storage
);
1026 env
->pub
.size
= sizeof env
->pub
;
1027 env
->pub
.private_members
= &env
->priv
;
1028 env
->pub
.make_global_ref
= module_make_global_ref
;
1029 env
->pub
.free_global_ref
= module_free_global_ref
;
1030 env
->pub
.non_local_exit_check
= module_non_local_exit_check
;
1031 env
->pub
.non_local_exit_clear
= module_non_local_exit_clear
;
1032 env
->pub
.non_local_exit_get
= module_non_local_exit_get
;
1033 env
->pub
.non_local_exit_signal
= module_non_local_exit_signal
;
1034 env
->pub
.non_local_exit_throw
= module_non_local_exit_throw
;
1035 env
->pub
.make_function
= module_make_function
;
1036 env
->pub
.funcall
= module_funcall
;
1037 env
->pub
.intern
= module_intern
;
1038 env
->pub
.type_of
= module_type_of
;
1039 env
->pub
.is_not_nil
= module_is_not_nil
;
1040 env
->pub
.eq
= module_eq
;
1041 env
->pub
.extract_integer
= module_extract_integer
;
1042 env
->pub
.make_integer
= module_make_integer
;
1043 env
->pub
.extract_float
= module_extract_float
;
1044 env
->pub
.make_float
= module_make_float
;
1045 env
->pub
.copy_string_contents
= module_copy_string_contents
;
1046 env
->pub
.make_string
= module_make_string
;
1047 env
->pub
.make_user_ptr
= module_make_user_ptr
;
1048 env
->pub
.get_user_ptr
= module_get_user_ptr
;
1049 env
->pub
.set_user_ptr
= module_set_user_ptr
;
1050 env
->pub
.get_user_finalizer
= module_get_user_finalizer
;
1051 env
->pub
.set_user_finalizer
= module_set_user_finalizer
;
1052 env
->pub
.vec_set
= module_vec_set
;
1053 env
->pub
.vec_get
= module_vec_get
;
1054 env
->pub
.vec_size
= module_vec_size
;
1055 Vmodule_environments
= Fcons (make_save_ptr (env
), Vmodule_environments
);
1058 static void finalize_environment (struct env_storage
*env
)
1060 finalize_storage (&env
->priv
.storage
);
1061 Vmodule_environments
= XCDR (Vmodule_environments
);
1065 /* Non-local exit handling */
1067 static void module_reset_handlerlist(const int *dummy
)
1069 handlerlist
= handlerlist
->next
;
1072 static void module_handle_signal (emacs_env
*const env
, const Lisp_Object err
)
1074 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
1077 static void module_handle_throw (emacs_env
*const env
, const Lisp_Object tag_val
)
1079 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
1083 /* Function environments */
1085 static Lisp_Object
module_format_fun_env (const struct module_fun_env
*const env
)
1087 /* Try to print a function name if possible. */
1088 const char *path
, *sym
;
1089 if (dynlib_addr (env
->subr
, &path
, &sym
))
1091 const char *const format
= "#<module function %s from %s>";
1092 const int size
= snprintf (NULL
, 0, format
, sym
, path
);
1094 char buffer
[size
+ 1];
1095 snprintf (buffer
, sizeof buffer
, format
, sym
, path
);
1096 return make_unibyte_string (buffer
, size
);
1100 const char *const format
= "#<module function at %p>";
1101 const void *const subr
= env
->subr
;
1102 const int size
= snprintf (NULL
, 0, format
, subr
);
1104 char buffer
[size
+ 1];
1105 snprintf (buffer
, sizeof buffer
, format
, subr
);
1106 return make_unibyte_string (buffer
, size
);
1111 /* Segment initializer */
1113 void syms_of_module (void)
1115 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
1116 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
1117 doc
: /* Module global referrence table. */);
1119 Vmodule_refs_hash
= make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
1120 make_float (DEFAULT_REHASH_SIZE
),
1121 make_float (DEFAULT_REHASH_THRESHOLD
),
1123 Funintern (Qmodule_refs_hash
, Qnil
);
1125 DEFSYM (Qmodule_environments
, "module-environments");
1126 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1127 doc
: /* List of active module environments. */);
1128 Vmodule_environments
= Qnil
;
1129 /* Unintern `module-environments' because it is only used
1131 Funintern (Qmodule_environments
, Qnil
);
1133 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1134 Fput (Qmodule_load_failed
, Qerror_conditions
,
1135 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1136 Fput (Qmodule_load_failed
, Qerror_message
,
1137 build_pure_c_string ("Module load failed"));
1139 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1140 Fput (Qinvalid_module_call
, Qerror_conditions
,
1141 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1142 Fput (Qinvalid_module_call
, Qerror_message
,
1143 build_pure_c_string ("Invalid module call"));
1145 DEFSYM (Qinvalid_arity
, "invalid-arity");
1146 Fput (Qinvalid_arity
, Qerror_conditions
,
1147 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1148 Fput (Qinvalid_arity
, Qerror_message
,
1149 build_pure_c_string ("Invalid function arity"));
1151 initialize_storage (&global_storage
);
1153 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1154 code or modules should not access it. */
1155 Funintern (Qmodule_refs_hash
, Qnil
);
1157 defsubr (&Smodule_load
);
1159 /* Don't call defsubr on `module-call' because that would intern it,
1160 but `module-call' is an internal function that users cannot
1161 meaningfully use. Instead, assign its definition to a private
1163 XSETPVECTYPE (&Smodule_call
, PVEC_SUBR
);
1164 XSETSUBR (module_call_func
, &Smodule_call
);
1167 /* Unlike syms_of_module, this initializer is called even from an
1168 * initialized (dumped) Emacs. */
1170 void module_init (void)
1172 /* It is not guaranteed that dynamic initializers run in the main thread,
1173 therefore we detect the main thread here. */
1174 #if defined(HAVE_THREADS_H)
1175 main_thread
= thrd_current ();
1176 #elif defined(HAVE_PTHREAD)
1177 main_thread
= pthread_self ();
1178 #elif defined(WINDOWSNT)
1179 /* This calls APIs that are only available on Vista and later. */
1181 /* GetCurrentProcess returns a pseudohandle, which we have to duplicate. */
1182 if (! DuplicateHandle (GetCurrentProcess(), GetCurrentThread(),
1183 GetCurrentProcess(), &main_thread
,
1184 SYNCHRONIZE
| THREAD_QUERY_INFORMATION
,
1188 /* GetCurrentThread returns a pseudohandle, which we have to duplicate. */
1189 HANDLE th
= GetCurrentThread ();
1190 if (!DuplicateHandle (GetCurrentProcess (), th
,
1191 GetCurrentProcess (), &main_thread
, 0, FALSE
,
1192 DUPLICATE_SAME_ACCESS
))
1194 main_thread_id
= GetCurrentThreadId ();