1 /* emacs-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/>. */
22 #include "emacs-module.h"
37 /* True if __attribute__ ((cleanup (...))) works, false otherwise. */
38 #ifdef HAVE_VAR_ATTRIBUTE_CLEANUP
39 enum { module_has_cleanup
= true };
41 enum { module_has_cleanup
= false };
44 /* Handle to the main thread. Used to verify that modules call us in
48 static thrd_t main_thread
;
49 #elif defined HAVE_PTHREAD
51 static pthread_t main_thread
;
52 #elif defined WINDOWSNT
54 /* On Windows, store both a handle to the main thread and the
55 thread ID because the latter can be reused when a thread
57 static HANDLE main_thread
;
58 static DWORD main_thread_id
;
62 /* Memory management. */
64 /* An `emacs_value' is just a pointer to a structure holding an
65 internal Lisp object. */
66 struct emacs_value_tag
{ Lisp_Object v
; };
68 /* Local value objects use a simple fixed-sized block allocation
69 scheme without explicit deallocation. All local values are
70 deallocated when the lifetime of their environment ends. Keep
71 track of a current frame from which new values are allocated,
72 appending further dynamically-allocated frames if necessary. */
74 enum { value_frame_size
= 512 };
76 /* A block from which `emacs_value' object can be allocated. */
77 struct emacs_value_frame
79 /* Storage for values. */
80 struct emacs_value_tag objects
[value_frame_size
];
82 /* Index of the next free value in `objects'. */
85 /* Pointer to next frame, if any. */
86 struct emacs_value_frame
*next
;
89 /* A structure that holds an initial frame (so that the first local
90 values require no dynamic allocation) and keeps track of the
92 static struct emacs_value_storage
94 struct emacs_value_frame initial
;
95 struct emacs_value_frame
*current
;
99 /* Private runtime and environment members. */
101 /* The private part of an environment stores the current non local exit state
102 and holds the `emacs_value' objects allocated during the lifetime
103 of the environment. */
104 struct emacs_env_private
106 enum emacs_funcall_exit pending_non_local_exit
;
108 /* Dedicated storage for non-local exit symbol and data so that
109 storage is always available for them, even in an out-of-memory
111 struct emacs_value_tag non_local_exit_symbol
, non_local_exit_data
;
113 struct emacs_value_storage storage
;
116 /* Combine public and private parts in one structure. This structure
117 is used whenever an environment is created. */
121 struct emacs_env_private priv
;
124 /* The private parts of an `emacs_runtime' object contain the initial
126 struct emacs_runtime_private
128 struct env_storage environment
;
133 /* Forward declarations. */
135 struct module_fun_env
;
137 static Lisp_Object
module_format_fun_env (const struct module_fun_env
*);
138 static Lisp_Object
value_to_lisp (emacs_value
);
139 static emacs_value
allocate_emacs_value (emacs_env
*, struct emacs_value_storage
*, Lisp_Object
);
140 static emacs_value
lisp_to_value (emacs_env
*, Lisp_Object
);
141 static enum emacs_funcall_exit
module_non_local_exit_check (emacs_env
*);
142 static void check_main_thread (void);
143 static void finalize_environment (struct env_storage
*);
144 static void initialize_environment (struct env_storage
*);
145 static void module_args_out_of_range (emacs_env
*, Lisp_Object
, Lisp_Object
);
146 static void module_handle_signal (emacs_env
*, Lisp_Object
);
147 static void module_handle_throw (emacs_env
*, Lisp_Object
);
148 static void module_non_local_exit_signal_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
149 static void module_non_local_exit_throw_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
150 static void module_out_of_memory (emacs_env
*);
151 static void module_reset_handlerlist (const int *);
152 static void module_wrong_type (emacs_env
*, Lisp_Object
, Lisp_Object
);
155 /* Convenience macros for non-local exit handling. */
157 /* Emacs uses setjmp and longjmp for non-local exits, but
158 module frames cannot be skipped because they are in general
159 not prepared for long jumps (e.g., the behavior in C++ is undefined
160 if objects with nontrivial destructors would be skipped).
161 Therefore, catch all non-local exits. There are two kinds of
162 non-local exits: `signal' and `throw'. The macros in this section
163 can be used to catch both. Use macros to avoid additional variants
164 of `internal_condition_case' etc., and to avoid worrying about
165 passing information to the handler functions. */
167 /* Place this macro at the beginning of a function returning a number
168 or a pointer to handle signals. The function must have an ENV
169 parameter. The function will return 0 (or NULL) if a signal is
171 #define MODULE_HANDLE_SIGNALS MODULE_HANDLE_SIGNALS_RETURN (0)
173 /* Place this macro at the beginning of a function returning void to
174 handle signals. The function must have an ENV parameter. */
175 #define MODULE_HANDLE_SIGNALS_VOID MODULE_HANDLE_SIGNALS_RETURN ()
177 #define MODULE_HANDLE_SIGNALS_RETURN(retval) \
178 MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval)
180 /* Place this macro at the beginning of a function returning a pointer
181 to handle non-local exits via `throw'. The function must have an
182 ENV parameter. The function will return NULL if a `throw' is
184 #define MODULE_HANDLE_THROW \
185 MODULE_SETJMP (CATCHER_ALL, module_handle_throw, NULL)
187 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
188 MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \
189 internal_handler_##handlertype, \
190 internal_cleanup_##handlertype)
192 /* It is very important that pushing the handler doesn't itself raise
193 a signal. Install the cleanup only after the handler has been
194 pushed. Use __attribute__ ((cleanup)) to avoid
195 non-local-exit-prone manual cleanup.
197 The do-while forces uses of the macro to be followed by a semicolon.
198 This macro cannot enclose its entire body inside a do-while, as the
199 code after the macro may longjmp back into the macro, which means
200 its local variable C must stay live in later code. */
202 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
203 eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); \
204 struct handler *c = push_handler_nosignal (Qt, handlertype); \
207 module_out_of_memory (env); \
210 verify (module_has_cleanup); \
211 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
212 if (sys_setjmp (c->jmp)) \
214 (handlerfunc) (env, c->val); \
220 /* Function environments. */
222 /* A function environment is an auxiliary structure used by
223 `module_make_function' to store information about a module
224 function. It is stored in a save pointer and retrieved by
225 `module-call'. Its members correspond to the arguments given to
226 `module_make_function'. */
228 struct module_fun_env
230 ptrdiff_t min_arity
, max_arity
;
235 /* The function definition of `module-call'. `module-call' is
236 uninterned because user code couldn't meaningfully use it, so keep
237 its definition around somewhere else. */
238 static Lisp_Object module_call_func
;
241 /* Implementation of runtime and environment functions. */
243 /* Catch signals and throws only if the code can actually signal or
244 throw. If checking is enabled, abort if the current thread is not
245 the Emacs main thread. */
248 module_get_environment (struct emacs_runtime
*ert
)
250 check_main_thread ();
251 return &ert
->private_members
->environment
.pub
;
254 /* To make global refs (GC-protected global values) keep a hash that
255 maps global Lisp objects to reference counts. */
258 module_make_global_ref (emacs_env
*env
, emacs_value ref
)
260 check_main_thread ();
261 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
262 MODULE_HANDLE_SIGNALS
;
263 eassert (HASH_TABLE_P (Vmodule_refs_hash
));
264 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
265 Lisp_Object new_obj
= value_to_lisp (ref
);
267 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
271 Lisp_Object value
= HASH_VALUE (h
, i
);
272 eassert (NATNUMP (value
));
273 EMACS_INT refcount
= XFASTINT (value
) + 1;
274 if (refcount
> MOST_POSITIVE_FIXNUM
)
276 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
279 value
= make_natnum (refcount
);
280 set_hash_value_slot (h
, i
, value
);
284 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
287 return allocate_emacs_value (env
, &global_storage
, new_obj
);
291 module_free_global_ref (emacs_env
*env
, emacs_value ref
)
293 check_main_thread ();
294 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
295 /* TODO: This probably never signals. */
296 /* FIXME: Wait a minute. Shouldn't this function report an error if
297 the hash lookup fails? */
298 MODULE_HANDLE_SIGNALS_VOID
;
299 eassert (HASH_TABLE_P (Vmodule_refs_hash
));
300 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
301 Lisp_Object obj
= value_to_lisp (ref
);
303 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
307 Lisp_Object value
= HASH_VALUE (h
, i
);
308 eassert (NATNUMP (value
));
309 EMACS_INT refcount
= XFASTINT (value
) - 1;
312 value
= make_natnum (refcount
);
313 set_hash_value_slot (h
, i
, value
);
317 eassert (refcount
== 0);
318 hash_remove_from_table (h
, value
);
323 static enum emacs_funcall_exit
324 module_non_local_exit_check (emacs_env
*env
)
326 check_main_thread ();
327 return env
->private_members
->pending_non_local_exit
;
331 module_non_local_exit_clear (emacs_env
*env
)
333 check_main_thread ();
334 env
->private_members
->pending_non_local_exit
= emacs_funcall_exit_return
;
337 static enum emacs_funcall_exit
338 module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
)
340 check_main_thread ();
341 struct emacs_env_private
*p
= env
->private_members
;
342 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
344 *sym
= &p
->non_local_exit_symbol
;
345 *data
= &p
->non_local_exit_data
;
347 return p
->pending_non_local_exit
;
350 /* Like for `signal', DATA must be a list. */
352 module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
)
354 check_main_thread ();
355 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
356 module_non_local_exit_signal_1 (env
, value_to_lisp (sym
),
357 value_to_lisp (data
));
361 module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
)
363 check_main_thread ();
364 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
365 module_non_local_exit_throw_1 (env
, value_to_lisp (tag
),
366 value_to_lisp (value
));
369 /* A module function is lambda function that calls `module-call',
370 passing the function pointer of the module function along with the
371 module emacs_env pointer as arguments.
373 (function (lambda (&rest arglist)
374 (module-call envobj arglist))) */
377 module_make_function (emacs_env
*env
, ptrdiff_t min_arity
, ptrdiff_t max_arity
,
378 emacs_subr subr
, const char *documentation
,
381 check_main_thread ();
382 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
383 MODULE_HANDLE_SIGNALS
;
385 if (! (0 <= min_arity
387 ? max_arity
== emacs_variadic_function
388 : min_arity
<= max_arity
)))
389 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
391 /* FIXME: This should be freed when envobj is GC'd. */
392 struct module_fun_env
*envptr
= xmalloc (sizeof *envptr
);
393 envptr
->min_arity
= min_arity
;
394 envptr
->max_arity
= max_arity
;
398 Lisp_Object envobj
= make_save_ptr (envptr
);
399 Lisp_Object ret
= list4 (Qlambda
,
400 list2 (Qand_rest
, Qargs
),
401 documentation
? build_string (documentation
) : Qnil
,
402 list3 (module_call_func
,
406 return lisp_to_value (env
, ret
);
410 module_funcall (emacs_env
*env
, emacs_value fun
, ptrdiff_t nargs
,
413 check_main_thread ();
414 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
415 MODULE_HANDLE_SIGNALS
;
418 /* Make a new Lisp_Object array starting with the function as the
419 first arg, because that's what Ffuncall takes. */
420 Lisp_Object
*newargs
;
422 SAFE_ALLOCA_LISP (newargs
, nargs
+ 1);
423 newargs
[0] = value_to_lisp (fun
);
424 for (ptrdiff_t i
= 0; i
< nargs
; i
++)
425 newargs
[1 + i
] = value_to_lisp (args
[i
]);
426 emacs_value result
= lisp_to_value (env
, Ffuncall (nargs
+ 1, newargs
));
432 module_intern (emacs_env
*env
, const char *name
)
434 check_main_thread ();
435 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
436 MODULE_HANDLE_SIGNALS
;
437 return lisp_to_value (env
, intern (name
));
441 module_type_of (emacs_env
*env
, emacs_value value
)
443 check_main_thread ();
444 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
445 return lisp_to_value (env
, Ftype_of (value_to_lisp (value
)));
449 module_is_not_nil (emacs_env
*env
, emacs_value value
)
451 check_main_thread ();
452 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
453 return ! NILP (value_to_lisp (value
));
457 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
459 check_main_thread ();
460 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
461 return EQ (value_to_lisp (a
), value_to_lisp (b
));
465 module_extract_integer (emacs_env
*env
, emacs_value n
)
467 check_main_thread ();
468 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
469 Lisp_Object l
= value_to_lisp (n
);
472 module_wrong_type (env
, Qintegerp
, l
);
479 module_make_integer (emacs_env
*env
, intmax_t n
)
481 check_main_thread ();
482 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
483 if (! (MOST_NEGATIVE_FIXNUM
<= n
&& n
<= MOST_POSITIVE_FIXNUM
))
485 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
488 return lisp_to_value (env
, make_number (n
));
492 module_extract_float (emacs_env
*env
, emacs_value f
)
494 check_main_thread ();
495 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
496 Lisp_Object lisp
= value_to_lisp (f
);
499 module_wrong_type (env
, Qfloatp
, lisp
);
502 return XFLOAT_DATA (lisp
);
506 module_make_float (emacs_env
*env
, double d
)
508 check_main_thread ();
509 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
510 MODULE_HANDLE_SIGNALS
;
511 return lisp_to_value (env
, make_float (d
));
515 module_copy_string_contents (emacs_env
*env
, emacs_value value
, char *buffer
,
518 check_main_thread ();
519 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
520 MODULE_HANDLE_SIGNALS
;
521 Lisp_Object lisp_str
= value_to_lisp (value
);
522 if (! STRINGP (lisp_str
))
524 module_wrong_type (env
, Qstringp
, lisp_str
);
528 ptrdiff_t raw_size
= SBYTES (lisp_str
);
530 /* Emacs internal encoding is more-or-less UTF8, let's assume utf8
531 encoded emacs string are the same byte size. */
533 if (!buffer
|| length
== 0 || *length
-1 < raw_size
)
535 *length
= raw_size
+ 1;
539 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
540 eassert (raw_size
== SBYTES (lisp_str_utf8
));
541 *length
= raw_size
+ 1;
542 memcpy (buffer
, SDATA (lisp_str_utf8
), SBYTES (lisp_str_utf8
));
543 buffer
[raw_size
] = 0;
549 module_make_string (emacs_env
*env
, const char *str
, ptrdiff_t length
)
551 check_main_thread ();
552 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
553 MODULE_HANDLE_SIGNALS
;
554 if (length
> PTRDIFF_MAX
)
556 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
559 /* Assume STR is utf8 encoded. */
560 return lisp_to_value (env
, make_string (str
, length
));
564 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
566 check_main_thread ();
567 return lisp_to_value (env
, make_user_ptr (fin
, ptr
));
571 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
573 check_main_thread ();
574 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
575 Lisp_Object lisp
= value_to_lisp (uptr
);
576 if (! USER_PTRP (lisp
))
578 module_wrong_type (env
, Quser_ptr
, lisp
);
581 return XUSER_PTR (lisp
)->p
;
585 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
587 check_main_thread ();
588 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
589 Lisp_Object lisp
= value_to_lisp (uptr
);
590 if (! USER_PTRP (lisp
))
591 module_wrong_type (env
, Quser_ptr
, lisp
);
592 XUSER_PTR (lisp
)->p
= ptr
;
595 static emacs_finalizer_function
596 module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
598 check_main_thread ();
599 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
600 Lisp_Object lisp
= value_to_lisp (uptr
);
601 if (! USER_PTRP (lisp
))
603 module_wrong_type (env
, Quser_ptr
, lisp
);
606 return XUSER_PTR (lisp
)->finalizer
;
610 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
611 emacs_finalizer_function fin
)
613 check_main_thread ();
614 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
615 Lisp_Object lisp
= value_to_lisp (uptr
);
616 if (! USER_PTRP (lisp
))
617 module_wrong_type (env
, Quser_ptr
, lisp
);
618 XUSER_PTR (lisp
)->finalizer
= fin
;
622 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
624 check_main_thread ();
625 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
626 Lisp_Object lvec
= value_to_lisp (vec
);
627 if (! VECTORP (lvec
))
629 module_wrong_type (env
, Qvectorp
, lvec
);
632 if (! (0 <= i
&& i
< ASIZE (lvec
)))
634 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
635 module_args_out_of_range (env
, lvec
, make_number (i
));
637 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
640 ASET (lvec
, i
, value_to_lisp (val
));
644 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
646 check_main_thread ();
647 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
648 Lisp_Object lvec
= value_to_lisp (vec
);
649 if (! VECTORP (lvec
))
651 module_wrong_type (env
, Qvectorp
, lvec
);
654 if (! (0 <= i
&& i
< ASIZE (lvec
)))
656 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
657 module_args_out_of_range (env
, lvec
, make_number (i
));
659 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
662 return lisp_to_value (env
, AREF (lvec
, i
));
666 module_vec_size (emacs_env
*env
, emacs_value vec
)
668 check_main_thread ();
669 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
670 Lisp_Object lvec
= value_to_lisp (vec
);
671 if (! VECTORP (lvec
))
673 module_wrong_type (env
, Qvectorp
, lvec
);
676 eassert (ASIZE (lvec
) >= 0);
683 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
684 doc
: /* Load module FILE. */)
687 dynlib_handle_ptr handle
;
688 emacs_init_function module_init
;
692 handle
= dynlib_open (SSDATA (file
));
694 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
696 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
698 error ("Module %s is not GPL compatible", SDATA (file
));
700 module_init
= (emacs_init_function
) dynlib_sym (handle
, "emacs_module_init");
702 error ("Module %s does not have an init function.", SDATA (file
));
704 struct emacs_runtime_private priv
;
705 struct emacs_runtime pub
=
708 .private_members
= &priv
,
709 .get_environment
= module_get_environment
711 initialize_environment (&priv
.environment
);
712 int r
= module_init (&pub
);
713 finalize_environment (&priv
.environment
);
717 if (! (MOST_NEGATIVE_FIXNUM
<= r
&& r
<= MOST_POSITIVE_FIXNUM
))
718 xsignal0 (Qoverflow_error
);
719 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
725 DEFUN ("module-call", Fmodule_call
, Smodule_call
, 2, 2, 0,
726 doc
: /* Internal function to call a module function.
727 ENVOBJ is a save pointer to a module_fun_env structure.
728 ARGLIST is a list of arguments passed to SUBRPTR. */)
729 (Lisp_Object envobj
, Lisp_Object arglist
)
731 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
732 EMACS_INT len
= XFASTINT (Flength (arglist
));
733 eassume (0 <= envptr
->min_arity
);
734 if (! (envptr
->min_arity
<= len
735 && len
<= (envptr
->max_arity
< 0 ? PTRDIFF_MAX
: envptr
->max_arity
)))
736 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
739 struct env_storage env
;
740 initialize_environment (&env
);
742 emacs_value
*args
= xnmalloc (len
, sizeof *args
);
744 for (ptrdiff_t i
= 0; i
< len
; i
++)
746 args
[i
] = lisp_to_value (&env
.pub
, XCAR (arglist
));
748 memory_full (sizeof *args
[i
]);
749 arglist
= XCDR (arglist
);
752 emacs_value ret
= envptr
->subr (&env
.pub
, len
, args
, envptr
->data
);
755 switch (env
.priv
.pending_non_local_exit
)
757 case emacs_funcall_exit_return
:
758 finalize_environment (&env
);
760 xsignal1 (Qinvalid_module_call
, module_format_fun_env (envptr
));
761 return value_to_lisp (ret
);
762 case emacs_funcall_exit_signal
:
764 Lisp_Object symbol
= value_to_lisp (&env
.priv
.non_local_exit_symbol
);
765 Lisp_Object data
= value_to_lisp (&env
.priv
.non_local_exit_data
);
766 finalize_environment (&env
);
767 xsignal (symbol
, data
);
769 case emacs_funcall_exit_throw
:
771 Lisp_Object tag
= value_to_lisp (&env
.priv
.non_local_exit_symbol
);
772 Lisp_Object value
= value_to_lisp (&env
.priv
.non_local_exit_data
);
773 finalize_environment (&env
);
782 /* Helper functions. */
785 check_main_thread (void)
787 #ifdef HAVE_THREADS_H
788 eassert (thrd_equal (thdr_current (), main_thread
));
789 #elif defined HAVE_PTHREAD
790 eassert (pthread_equal (pthread_self (), main_thread
));
791 #elif defined WINDOWSNT
792 /* CompareObjectHandles would be perfect, but is only available in
793 Windows 10. Also check whether the thread is still running to
794 protect against thread identifier reuse. */
795 eassert (GetCurrentThreadId () == main_thread_id
796 && WaitForSingleObject (main_thread
, 0) == WAIT_TIMEOUT
);
801 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
804 struct emacs_env_private
*p
= env
->private_members
;
805 eassert (p
->pending_non_local_exit
== emacs_funcall_exit_return
);
806 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
807 p
->non_local_exit_symbol
.v
= sym
;
808 p
->non_local_exit_data
.v
= data
;
812 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
815 struct emacs_env_private
*p
= env
->private_members
;
816 eassert (p
->pending_non_local_exit
== emacs_funcall_exit_return
);
817 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
818 p
->non_local_exit_symbol
.v
= tag
;
819 p
->non_local_exit_data
.v
= value
;
822 /* Module version of `wrong_type_argument'. */
824 module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
)
826 module_non_local_exit_signal_1 (env
, Qwrong_type_argument
,
827 list2 (predicate
, value
));
830 /* Signal an out-of-memory condition to the caller. */
832 module_out_of_memory (emacs_env
*env
)
834 /* TODO: Reimplement this so it works even if memory-signal-data has
836 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
837 XCDR (Vmemory_signal_data
));
840 /* Signal arguments are out of range. */
842 module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
)
844 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, list2 (a1
, a2
));
848 /* Value conversion. */
850 /* Convert an `emacs_value' to the corresponding internal object.
853 value_to_lisp (emacs_value v
)
858 /* Convert an internal object to an `emacs_value'. Allocate storage
859 from the environment; return NULL if allocation fails. */
861 lisp_to_value (emacs_env
*env
, Lisp_Object o
)
863 struct emacs_env_private
*p
= env
->private_members
;
864 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
866 return allocate_emacs_value (env
, &p
->storage
, o
);
870 /* Memory management. */
872 /* Must be called for each frame before it can be used for allocation. */
874 initialize_frame (struct emacs_value_frame
*frame
)
880 /* Must be called for any storage object before it can be used for
883 initialize_storage (struct emacs_value_storage
*storage
)
885 initialize_frame (&storage
->initial
);
886 storage
->current
= &storage
->initial
;
889 /* Must be called for any initialized storage object before its
890 lifetime ends. Free all dynamically-allocated frames. */
892 finalize_storage (struct emacs_value_storage
*storage
)
894 struct emacs_value_frame
*next
= storage
->initial
.next
;
897 struct emacs_value_frame
*current
= next
;
898 next
= current
->next
;
903 /* Allocate a new value from STORAGE and stores OBJ in it. Return
904 NULL if allocations fails and use ENV for non local exit reporting. */
906 allocate_emacs_value (emacs_env
*env
, struct emacs_value_storage
*storage
,
909 eassert (storage
->current
);
910 eassert (storage
->current
->offset
< value_frame_size
);
911 eassert (! storage
->current
->next
);
912 if (storage
->current
->offset
== value_frame_size
- 1)
914 storage
->current
->next
= malloc (sizeof *storage
->current
->next
);
915 if (! storage
->current
->next
)
917 module_out_of_memory (env
);
920 initialize_frame (storage
->current
->next
);
921 storage
->current
= storage
->current
->next
;
923 emacs_value value
= storage
->current
->objects
+ storage
->current
->offset
;
925 ++storage
->current
->offset
;
929 /* Mark all objects allocated from local environments so that they
930 don't get garbage-collected. */
931 void mark_modules (void)
933 for (Lisp_Object tem
= Vmodule_environments
; CONSP (tem
); tem
= XCDR (tem
))
935 struct env_storage
*env
= XSAVE_POINTER (tem
, 0);
936 for (struct emacs_value_frame
*frame
= &env
->priv
.storage
.initial
;
939 for (int i
= 0; i
< frame
->offset
; ++i
)
940 mark_object (frame
->objects
[i
].v
);
945 /* Environment lifetime management. */
947 /* Must be called before the environment can be used. */
949 initialize_environment (struct env_storage
*env
)
951 env
->priv
.pending_non_local_exit
= emacs_funcall_exit_return
;
952 initialize_storage (&env
->priv
.storage
);
953 env
->pub
.size
= sizeof env
->pub
;
954 env
->pub
.private_members
= &env
->priv
;
955 env
->pub
.make_global_ref
= module_make_global_ref
;
956 env
->pub
.free_global_ref
= module_free_global_ref
;
957 env
->pub
.non_local_exit_check
= module_non_local_exit_check
;
958 env
->pub
.non_local_exit_clear
= module_non_local_exit_clear
;
959 env
->pub
.non_local_exit_get
= module_non_local_exit_get
;
960 env
->pub
.non_local_exit_signal
= module_non_local_exit_signal
;
961 env
->pub
.non_local_exit_throw
= module_non_local_exit_throw
;
962 env
->pub
.make_function
= module_make_function
;
963 env
->pub
.funcall
= module_funcall
;
964 env
->pub
.intern
= module_intern
;
965 env
->pub
.type_of
= module_type_of
;
966 env
->pub
.is_not_nil
= module_is_not_nil
;
967 env
->pub
.eq
= module_eq
;
968 env
->pub
.extract_integer
= module_extract_integer
;
969 env
->pub
.make_integer
= module_make_integer
;
970 env
->pub
.extract_float
= module_extract_float
;
971 env
->pub
.make_float
= module_make_float
;
972 env
->pub
.copy_string_contents
= module_copy_string_contents
;
973 env
->pub
.make_string
= module_make_string
;
974 env
->pub
.make_user_ptr
= module_make_user_ptr
;
975 env
->pub
.get_user_ptr
= module_get_user_ptr
;
976 env
->pub
.set_user_ptr
= module_set_user_ptr
;
977 env
->pub
.get_user_finalizer
= module_get_user_finalizer
;
978 env
->pub
.set_user_finalizer
= module_set_user_finalizer
;
979 env
->pub
.vec_set
= module_vec_set
;
980 env
->pub
.vec_get
= module_vec_get
;
981 env
->pub
.vec_size
= module_vec_size
;
982 Vmodule_environments
= Fcons (make_save_ptr (env
), Vmodule_environments
);
985 /* Must be called before the lifetime of the environment object
988 finalize_environment (struct env_storage
*env
)
990 finalize_storage (&env
->priv
.storage
);
991 Vmodule_environments
= XCDR (Vmodule_environments
);
995 /* Non-local exit handling. */
997 /* Must be called after setting up a handler immediately before
998 returning from the function. See the comments in lisp.h and the
999 code in eval.c for details. The macros below arrange for this
1000 function to be called automatically. DUMMY is ignored. */
1002 module_reset_handlerlist (const int *dummy
)
1004 handlerlist
= handlerlist
->next
;
1007 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
1008 stored in the environment. Set the pending non-local exit flag. */
1010 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
1012 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
1015 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
1016 stored in the environment. Set the pending non-local exit flag. */
1018 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
1020 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
1024 /* Function environments. */
1026 /* Return a string object that contains a user-friendly
1027 representation of the function environment. */
1029 module_format_fun_env (const struct module_fun_env
*env
)
1031 /* Try to print a function name if possible. */
1032 const char *path
, *sym
;
1033 if (dynlib_addr (env
->subr
, &path
, &sym
))
1035 static char const format
[] = "#<module function %s from %s>";
1036 int size
= snprintf (NULL
, 0, format
, sym
, path
);
1038 char buffer
[size
+ 1];
1039 snprintf (buffer
, sizeof buffer
, format
, sym
, path
);
1040 return make_unibyte_string (buffer
, size
);
1044 static char const format
[] = "#<module function at %p>";
1045 void *subr
= env
->subr
;
1046 int size
= snprintf (NULL
, 0, format
, subr
);
1048 char buffer
[size
+ 1];
1049 snprintf (buffer
, sizeof buffer
, format
, subr
);
1050 return make_unibyte_string (buffer
, size
);
1055 /* Segment initializer. */
1058 syms_of_module (void)
1060 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
1061 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
1062 doc
: /* Module global referrence table. */);
1065 = make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
1066 make_float (DEFAULT_REHASH_SIZE
),
1067 make_float (DEFAULT_REHASH_THRESHOLD
),
1069 Funintern (Qmodule_refs_hash
, Qnil
);
1071 DEFSYM (Qmodule_environments
, "module-environments");
1072 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1073 doc
: /* List of active module environments. */);
1074 Vmodule_environments
= Qnil
;
1075 /* Unintern `module-environments' because it is only used
1077 Funintern (Qmodule_environments
, Qnil
);
1079 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1080 Fput (Qmodule_load_failed
, Qerror_conditions
,
1081 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1082 Fput (Qmodule_load_failed
, Qerror_message
,
1083 build_pure_c_string ("Module load failed"));
1085 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1086 Fput (Qinvalid_module_call
, Qerror_conditions
,
1087 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1088 Fput (Qinvalid_module_call
, Qerror_message
,
1089 build_pure_c_string ("Invalid module call"));
1091 DEFSYM (Qinvalid_arity
, "invalid-arity");
1092 Fput (Qinvalid_arity
, Qerror_conditions
,
1093 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1094 Fput (Qinvalid_arity
, Qerror_message
,
1095 build_pure_c_string ("Invalid function arity"));
1097 initialize_storage (&global_storage
);
1099 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1100 code or modules should not access it. */
1101 Funintern (Qmodule_refs_hash
, Qnil
);
1103 defsubr (&Smodule_load
);
1105 /* Don't call defsubr on `module-call' because that would intern it,
1106 but `module-call' is an internal function that users cannot
1107 meaningfully use. Instead, assign its definition to a private
1109 XSETPVECTYPE (&Smodule_call
, PVEC_SUBR
);
1110 XSETSUBR (module_call_func
, &Smodule_call
);
1113 /* Unlike syms_of_module, this initializer is called even from an
1114 initialized (dumped) Emacs. */
1119 /* It is not guaranteed that dynamic initializers run in the main thread,
1120 therefore detect the main thread here. */
1121 #ifdef HAVE_THREADS_H
1122 main_thread
= thrd_current ();
1123 #elif defined HAVE_PTHREAD
1124 main_thread
= pthread_self ();
1125 #elif defined WINDOWSNT
1126 /* This calls APIs that are only available on Vista and later. */
1128 /* GetCurrentProcess returns a pseudohandle, which must be duplicated. */
1129 if (! DuplicateHandle (GetCurrentProcess (), GetCurrentThread (),
1130 GetCurrentProcess (), &main_thread
,
1131 SYNCHRONIZE
| THREAD_QUERY_INFORMATION
,
1135 /* GetCurrentThread returns a pseudohandle, which must be duplicated. */
1136 HANDLE th
= GetCurrentThread ();
1137 if (!DuplicateHandle (GetCurrentProcess (), th
,
1138 GetCurrentProcess (), &main_thread
, 0, FALSE
,
1139 DUPLICATE_SAME_ACCESS
))
1141 main_thread_id
= GetCurrentThreadId ();