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/>. */
27 #include "emacs-module.h"
35 /* True if __attribute__ ((cleanup (...))) works, false otherwise. */
36 #ifdef HAVE_VAR_ATTRIBUTE_CLEANUP
37 enum { module_has_cleanup
= true };
39 enum { module_has_cleanup
= false };
42 /* Handle to the main thread. Used to verify that modules call us in
46 static thrd_t main_thread
;
47 #elif defined HAVE_PTHREAD
49 static pthread_t main_thread
;
50 #elif defined WINDOWSNT
52 /* On Windows, store both a handle to the main thread and the
53 thread ID because the latter can be reused when a thread
55 static HANDLE main_thread
;
56 static DWORD main_thread_id
;
60 /* Memory management. */
62 /* An `emacs_value' is just a pointer to a structure holding an
63 internal Lisp object. */
64 struct emacs_value_tag
{ Lisp_Object v
; };
66 /* Local value objects use a simple fixed-sized block allocation
67 scheme without explicit deallocation. All local values are
68 deallocated when the lifetime of their environment ends. Keep
69 track of a current frame from which new values are allocated,
70 appending further dynamically-allocated frames if necessary. */
72 enum { value_frame_size
= 512 };
74 /* A block from which `emacs_value' object can be allocated. */
75 struct emacs_value_frame
77 /* Storage for values. */
78 struct emacs_value_tag objects
[value_frame_size
];
80 /* Index of the next free value in `objects'. */
83 /* Pointer to next frame, if any. */
84 struct emacs_value_frame
*next
;
87 /* A structure that holds an initial frame (so that the first local
88 values require no dynamic allocation) and keeps track of the
90 static struct emacs_value_storage
92 struct emacs_value_frame initial
;
93 struct emacs_value_frame
*current
;
97 /* Private runtime and environment members. */
99 /* The private part of an environment stores the current non local exit state
100 and holds the `emacs_value' objects allocated during the lifetime
101 of the environment. */
102 struct emacs_env_private
104 enum emacs_funcall_exit pending_non_local_exit
;
106 /* Dedicated storage for non-local exit symbol and data so that
107 storage is always available for them, even in an out-of-memory
109 struct emacs_value_tag non_local_exit_symbol
, non_local_exit_data
;
111 struct emacs_value_storage storage
;
114 /* Combine public and private parts in one structure. This structure
115 is used whenever an environment is created. */
119 struct emacs_env_private priv
;
122 /* The private parts of an `emacs_runtime' object contain the initial
124 struct emacs_runtime_private
126 struct env_storage environment
;
131 /* Forward declarations. */
133 struct module_fun_env
;
135 static Lisp_Object
module_format_fun_env (const struct module_fun_env
*);
136 static Lisp_Object
value_to_lisp (emacs_value
);
137 static emacs_value
allocate_emacs_value (emacs_env
*, struct emacs_value_storage
*, Lisp_Object
);
138 static emacs_value
lisp_to_value (emacs_env
*, Lisp_Object
);
139 static enum emacs_funcall_exit
module_non_local_exit_check (emacs_env
*);
140 static void check_main_thread (void);
141 static void finalize_environment (struct env_storage
*);
142 static void initialize_environment (struct env_storage
*);
143 static void module_args_out_of_range (emacs_env
*, Lisp_Object
, Lisp_Object
);
144 static void module_handle_signal (emacs_env
*, Lisp_Object
);
145 static void module_handle_throw (emacs_env
*, Lisp_Object
);
146 static void module_non_local_exit_signal_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
147 static void module_non_local_exit_throw_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
148 static void module_out_of_memory (emacs_env
*);
149 static void module_reset_handlerlist (const int *);
150 static void module_wrong_type (emacs_env
*, Lisp_Object
, Lisp_Object
);
153 /* Convenience macros for non-local exit handling. */
155 /* Emacs uses setjmp and longjmp for non-local exits, but
156 module frames cannot be skipped because they are in general
157 not prepared for long jumps (e.g., the behavior in C++ is undefined
158 if objects with nontrivial destructors would be skipped).
159 Therefore, catch all non-local exits. There are two kinds of
160 non-local exits: `signal' and `throw'. The macros in this section
161 can be used to catch both. Use macros to avoid additional variants
162 of `internal_condition_case' etc., and to avoid worrying about
163 passing information to the handler functions. */
165 /* Place this macro at the beginning of a function returning a number
166 or a pointer to handle signals. The function must have an ENV
167 parameter. The function will return 0 (or NULL) if a signal is
169 #define MODULE_HANDLE_SIGNALS MODULE_HANDLE_SIGNALS_RETURN (0)
171 /* Place this macro at the beginning of a function returning void to
172 handle signals. The function must have an ENV parameter. */
173 #define MODULE_HANDLE_SIGNALS_VOID MODULE_HANDLE_SIGNALS_RETURN ()
175 #define MODULE_HANDLE_SIGNALS_RETURN(retval) \
176 MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval)
178 /* Place this macro at the beginning of a function returning a pointer
179 to handle non-local exits via `throw'. The function must have an
180 ENV parameter. The function will return NULL if a `throw' is
182 #define MODULE_HANDLE_THROW \
183 MODULE_SETJMP (CATCHER_ALL, module_handle_throw, NULL)
185 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
186 MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \
187 internal_handler_##handlertype, \
188 internal_cleanup_##handlertype)
190 /* It is very important that pushing the handler doesn't itself raise
191 a signal. Install the cleanup only after the handler has been
192 pushed. Use __attribute__ ((cleanup)) to avoid
193 non-local-exit-prone manual cleanup. */
194 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
196 eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); \
198 if (!push_handler_nosignal (&c, Qt, handlertype)) \
200 module_out_of_memory (env); \
203 verify (module_has_cleanup); \
204 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
205 if (sys_setjmp (c->jmp)) \
207 (handlerfunc) (env, c->val); \
213 /* Function environments. */
215 /* A function environment is an auxiliary structure used by
216 `module_make_function' to store information about a module
217 function. It is stored in a save pointer and retrieved by
218 `module-call'. Its members correspond to the arguments given to
219 `module_make_function'. */
221 struct module_fun_env
223 int min_arity
, max_arity
;
228 /* The function definition of `module-call'. `module-call' is
229 uninterned because user code couldn't meaningfully use it, so keep
230 its definition around somewhere else. */
231 static Lisp_Object module_call_func
;
234 /* Implementation of runtime and environment functions. */
236 /* Catch signals and throws only if the code can actually signal or
237 throw. If checking is enabled, abort if the current thread is not
238 the Emacs main thread. */
241 module_get_environment (struct emacs_runtime
*ert
)
243 check_main_thread ();
244 return &ert
->private_members
->environment
.pub
;
247 /* To make global refs (GC-protected global values) keep a hash that
248 maps global Lisp objects to reference counts. */
251 module_make_global_ref (emacs_env
*env
, emacs_value ref
)
253 check_main_thread ();
254 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
255 MODULE_HANDLE_SIGNALS
;
256 eassert (HASH_TABLE_P (Vmodule_refs_hash
));
257 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
258 Lisp_Object new_obj
= value_to_lisp (ref
);
260 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
264 Lisp_Object value
= HASH_VALUE (h
, i
);
265 eassert (NATNUMP (value
));
266 EMACS_INT refcount
= XFASTINT (value
) + 1;
267 if (refcount
> MOST_POSITIVE_FIXNUM
)
269 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
272 value
= make_natnum (refcount
);
273 set_hash_value_slot (h
, i
, value
);
277 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
280 return allocate_emacs_value (env
, &global_storage
, new_obj
);
284 module_free_global_ref (emacs_env
*env
, emacs_value ref
)
286 check_main_thread ();
287 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
288 /* TODO: This probably never signals. */
289 MODULE_HANDLE_SIGNALS_VOID
;
290 eassert (HASH_TABLE_P (Vmodule_refs_hash
));
291 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
292 Lisp_Object obj
= value_to_lisp (ref
);
294 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
298 Lisp_Object value
= HASH_VALUE (h
, i
);
299 eassert (NATNUMP (value
));
300 EMACS_INT refcount
= XFASTINT (value
) - 1;
303 value
= make_natnum (refcount
- 1);
304 set_hash_value_slot (h
, i
, value
);
308 eassert (refcount
== 0);
309 hash_remove_from_table (h
, value
);
314 static enum emacs_funcall_exit
315 module_non_local_exit_check (emacs_env
*env
)
317 check_main_thread ();
318 return env
->private_members
->pending_non_local_exit
;
322 module_non_local_exit_clear (emacs_env
*env
)
324 check_main_thread ();
325 env
->private_members
->pending_non_local_exit
= emacs_funcall_exit_return
;
328 static enum emacs_funcall_exit
329 module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
)
331 check_main_thread ();
332 struct emacs_env_private
*p
= env
->private_members
;
333 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
335 *sym
= &p
->non_local_exit_symbol
;
336 *data
= &p
->non_local_exit_data
;
338 return p
->pending_non_local_exit
;
341 /* Like for `signal', DATA must be a list. */
343 module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
)
345 check_main_thread ();
346 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
347 module_non_local_exit_signal_1 (env
, value_to_lisp (sym
),
348 value_to_lisp (data
));
352 module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
)
354 check_main_thread ();
355 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
356 module_non_local_exit_throw_1 (env
, value_to_lisp (tag
),
357 value_to_lisp (value
));
360 /* A module function is lambda function that calls `module-call',
361 passing the function pointer of the module function along with the
362 module emacs_env pointer as arguments.
364 (function (lambda (&rest arglist)
365 (module-call envobj arglist))) */
368 module_make_function (emacs_env
*env
, int min_arity
, int max_arity
,
369 emacs_subr subr
, const char *documentation
,
372 check_main_thread ();
373 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
374 MODULE_HANDLE_SIGNALS
;
376 if (min_arity
> MOST_POSITIVE_FIXNUM
|| max_arity
> MOST_POSITIVE_FIXNUM
)
377 xsignal0 (Qoverflow_error
);
380 || (max_arity
>= 0 && max_arity
< min_arity
)
381 || (max_arity
< 0 && max_arity
!= emacs_variadic_function
))
382 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
386 /* XXX: This should need to be freed when envobj is GC'd. */
387 struct module_fun_env
*envptr
= xzalloc (sizeof *envptr
);
388 envptr
->min_arity
= min_arity
;
389 envptr
->max_arity
= max_arity
;
392 envobj
= make_save_ptr (envptr
);
394 Lisp_Object ret
= list4 (Qlambda
,
395 list2 (Qand_rest
, Qargs
),
396 documentation
? build_string (documentation
) : Qnil
,
397 list3 (module_call_func
,
401 return lisp_to_value (env
, ret
);
405 module_funcall (emacs_env
*env
, emacs_value fun
, int nargs
, emacs_value args
[])
407 check_main_thread ();
408 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
409 MODULE_HANDLE_SIGNALS
;
412 /* Make a new Lisp_Object array starting with the function as the
413 first arg, because that's what Ffuncall takes. */
414 Lisp_Object newargs
[nargs
+ 1];
415 newargs
[0] = value_to_lisp (fun
);
416 for (int i
= 0; i
< nargs
; i
++)
417 newargs
[1 + i
] = value_to_lisp (args
[i
]);
418 return lisp_to_value (env
, Ffuncall (nargs
+ 1, newargs
));
422 module_intern (emacs_env
*env
, const char *name
)
424 check_main_thread ();
425 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
426 MODULE_HANDLE_SIGNALS
;
427 return lisp_to_value (env
, intern (name
));
431 module_type_of (emacs_env
*env
, emacs_value value
)
433 check_main_thread ();
434 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
435 return lisp_to_value (env
, Ftype_of (value_to_lisp (value
)));
439 module_is_not_nil (emacs_env
*env
, emacs_value value
)
441 check_main_thread ();
442 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
443 return ! NILP (value_to_lisp (value
));
447 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
449 check_main_thread ();
450 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
451 return EQ (value_to_lisp (a
), value_to_lisp (b
));
455 module_extract_integer (emacs_env
*env
, emacs_value n
)
457 check_main_thread ();
458 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
459 Lisp_Object l
= value_to_lisp (n
);
462 module_wrong_type (env
, Qintegerp
, l
);
469 module_make_integer (emacs_env
*env
, intmax_t n
)
471 check_main_thread ();
472 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
473 if (! (MOST_NEGATIVE_FIXNUM
<= n
&& n
<= MOST_POSITIVE_FIXNUM
))
475 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
478 return lisp_to_value (env
, make_number (n
));
482 module_extract_float (emacs_env
*env
, emacs_value f
)
484 check_main_thread ();
485 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
486 Lisp_Object lisp
= value_to_lisp (f
);
489 module_wrong_type (env
, Qfloatp
, lisp
);
492 return XFLOAT_DATA (lisp
);
496 module_make_float (emacs_env
*env
, double d
)
498 check_main_thread ();
499 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
500 MODULE_HANDLE_SIGNALS
;
501 return lisp_to_value (env
, make_float (d
));
505 module_copy_string_contents (emacs_env
*env
, emacs_value value
, char *buffer
,
508 check_main_thread ();
509 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
510 MODULE_HANDLE_SIGNALS
;
511 Lisp_Object lisp_str
= value_to_lisp (value
);
512 if (! STRINGP (lisp_str
))
514 module_wrong_type (env
, Qstringp
, lisp_str
);
518 ptrdiff_t raw_size
= SBYTES (lisp_str
);
520 /* Emacs internal encoding is more-or-less UTF8, let's assume utf8
521 encoded emacs string are the same byte size. */
523 if (!buffer
|| length
== 0 || *length
-1 < raw_size
)
525 *length
= raw_size
+ 1;
529 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
530 eassert (raw_size
== SBYTES (lisp_str_utf8
));
531 *length
= raw_size
+ 1;
532 memcpy (buffer
, SDATA (lisp_str_utf8
), SBYTES (lisp_str_utf8
));
533 buffer
[raw_size
] = 0;
539 module_make_string (emacs_env
*env
, const char *str
, ptrdiff_t length
)
541 check_main_thread ();
542 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
543 MODULE_HANDLE_SIGNALS
;
544 if (length
> PTRDIFF_MAX
)
546 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
549 /* Assume STR is utf8 encoded. */
550 return lisp_to_value (env
, make_string (str
, length
));
554 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
556 check_main_thread ();
557 return lisp_to_value (env
, make_user_ptr (fin
, ptr
));
561 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
563 check_main_thread ();
564 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
565 Lisp_Object lisp
= value_to_lisp (uptr
);
566 if (! USER_PTRP (lisp
))
568 module_wrong_type (env
, Quser_ptr
, lisp
);
571 return XUSER_PTR (lisp
)->p
;
575 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
577 check_main_thread ();
578 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
579 Lisp_Object lisp
= value_to_lisp (uptr
);
580 if (! USER_PTRP (lisp
))
581 module_wrong_type (env
, Quser_ptr
, lisp
);
582 XUSER_PTR (lisp
)->p
= ptr
;
585 static emacs_finalizer_function
586 module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
588 check_main_thread ();
589 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
590 Lisp_Object lisp
= value_to_lisp (uptr
);
591 if (! USER_PTRP (lisp
))
593 module_wrong_type (env
, Quser_ptr
, lisp
);
596 return XUSER_PTR (lisp
)->finalizer
;
600 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
601 emacs_finalizer_function fin
)
603 check_main_thread ();
604 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
605 Lisp_Object lisp
= value_to_lisp (uptr
);
606 if (! USER_PTRP (lisp
))
607 module_wrong_type (env
, Quser_ptr
, lisp
);
608 XUSER_PTR (lisp
)->finalizer
= fin
;
612 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
614 check_main_thread ();
615 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
616 if (i
> MOST_POSITIVE_FIXNUM
)
618 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
621 Lisp_Object lvec
= value_to_lisp (vec
);
622 if (! VECTORP (lvec
))
624 module_wrong_type (env
, Qvectorp
, lvec
);
627 if (i
>= ASIZE (lvec
))
629 module_args_out_of_range (env
, lvec
, make_number (i
));
632 ASET (lvec
, i
, value_to_lisp (val
));
636 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
638 check_main_thread ();
639 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
640 Lisp_Object lvec
= value_to_lisp (vec
);
641 if (! VECTORP (lvec
))
643 module_wrong_type (env
, Qvectorp
, lvec
);
646 ptrdiff_t size
= ASIZE (lvec
);
648 if (! (0 <= i
&& i
< size
))
650 module_args_out_of_range (env
, lvec
, make_number (i
));
653 return lisp_to_value (env
, AREF (lvec
, i
));
657 module_vec_size (emacs_env
*env
, emacs_value vec
)
659 check_main_thread ();
660 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
661 Lisp_Object lvec
= value_to_lisp (vec
);
662 if (! VECTORP (lvec
))
664 module_wrong_type (env
, Qvectorp
, lvec
);
667 eassert (ASIZE (lvec
) >= 0);
674 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
675 doc
: /* Load module FILE. */)
678 dynlib_handle_ptr handle
;
679 emacs_init_function module_init
;
683 handle
= dynlib_open (SSDATA (file
));
685 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
687 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
689 error ("Module %s is not GPL compatible", SDATA (file
));
691 module_init
= (emacs_init_function
) dynlib_sym (handle
, "emacs_module_init");
693 error ("Module %s does not have an init function.", SDATA (file
));
695 struct emacs_runtime_private priv
;
696 struct emacs_runtime pub
=
699 .private_members
= &priv
,
700 .get_environment
= module_get_environment
702 initialize_environment (&priv
.environment
);
703 int r
= module_init (&pub
);
704 finalize_environment (&priv
.environment
);
708 if (r
< MOST_NEGATIVE_FIXNUM
)
709 xsignal0 (Qunderflow_error
);
710 if (r
> MOST_POSITIVE_FIXNUM
)
711 xsignal0 (Qoverflow_error
);
712 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
718 DEFUN ("module-call", Fmodule_call
, Smodule_call
, 2, 2, 0,
719 doc
: /* Internal function to call a module function.
720 ENVOBJ is a save pointer to a module_fun_env structure.
721 ARGLIST is a list of arguments passed to SUBRPTR. */)
722 (Lisp_Object envobj
, Lisp_Object arglist
)
724 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
725 EMACS_INT len
= XINT (Flength (arglist
));
727 if (len
> MOST_POSITIVE_FIXNUM
)
728 xsignal0 (Qoverflow_error
);
729 if (len
> INT_MAX
|| len
< envptr
->min_arity
730 || (envptr
->max_arity
>= 0 && len
> envptr
->max_arity
))
731 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
734 struct env_storage env
;
735 initialize_environment (&env
);
737 emacs_value
*args
= xzalloc (len
* sizeof *args
);
740 for (i
= 0; i
< len
; i
++)
742 args
[i
] = lisp_to_value (&env
.pub
, XCAR (arglist
));
744 memory_full (sizeof *args
[i
]);
745 arglist
= XCDR (arglist
);
748 emacs_value ret
= envptr
->subr (&env
.pub
, len
, args
, envptr
->data
);
751 switch (env
.priv
.pending_non_local_exit
)
753 case emacs_funcall_exit_return
:
754 finalize_environment (&env
);
756 xsignal1 (Qinvalid_module_call
, module_format_fun_env (envptr
));
757 return value_to_lisp (ret
);
758 case emacs_funcall_exit_signal
:
760 Lisp_Object symbol
= value_to_lisp (&env
.priv
.non_local_exit_symbol
);
761 Lisp_Object data
= value_to_lisp (&env
.priv
.non_local_exit_data
);
762 finalize_environment (&env
);
763 xsignal (symbol
, data
);
765 case emacs_funcall_exit_throw
:
767 Lisp_Object tag
= value_to_lisp (&env
.priv
.non_local_exit_symbol
);
768 Lisp_Object value
= value_to_lisp (&env
.priv
.non_local_exit_data
);
769 finalize_environment (&env
);
778 /* Helper functions. */
781 check_main_thread (void)
783 #ifdef HAVE_THREADS_H
784 eassert (thrd_equal (thdr_current (), main_thread
));
785 #elif defined HAVE_PTHREAD
786 eassert (pthread_equal (pthread_self (), main_thread
));
787 #elif defined WINDOWSNT
788 /* CompareObjectHandles would be perfect, but is only available in
789 Windows 10. Also check whether the thread is still running to
790 protect against thread identifier reuse. */
791 eassert (GetCurrentThreadId () == main_thread_id
792 && WaitForSingleObject (main_thread
, 0) == WAIT_TIMEOUT
);
797 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
800 struct emacs_env_private
*p
= env
->private_members
;
801 eassert (p
->pending_non_local_exit
== emacs_funcall_exit_return
);
802 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
803 p
->non_local_exit_symbol
.v
= sym
;
804 p
->non_local_exit_data
.v
= data
;
808 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
811 struct emacs_env_private
*p
= env
->private_members
;
812 eassert (p
->pending_non_local_exit
== emacs_funcall_exit_return
);
813 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
814 p
->non_local_exit_symbol
.v
= tag
;
815 p
->non_local_exit_data
.v
= value
;
818 /* Module version of `wrong_type_argument'. */
820 module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
)
822 module_non_local_exit_signal_1 (env
, Qwrong_type_argument
,
823 list2 (predicate
, value
));
826 /* Signal an out-of-memory condition to the caller. */
828 module_out_of_memory (emacs_env
*env
)
830 /* TODO: Reimplement this so it works even if memory-signal-data has
832 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
833 XCDR (Vmemory_signal_data
));
836 /* Signal arguments are out of range. */
838 module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
)
840 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, list2 (a1
, a2
));
844 /* Value conversion. */
846 /* Convert an `emacs_value' to the corresponding internal object.
849 value_to_lisp (emacs_value v
)
854 /* Convert an internal object to an `emacs_value'. Allocate storage
855 from the environment; return NULL if allocation fails. */
857 lisp_to_value (emacs_env
*env
, Lisp_Object o
)
859 struct emacs_env_private
*p
= env
->private_members
;
860 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
862 return allocate_emacs_value (env
, &p
->storage
, o
);
866 /* Memory management. */
868 /* Must be called for each frame before it can be used for allocation. */
870 initialize_frame (struct emacs_value_frame
*frame
)
876 /* Must be called for any storage object before it can be used for
879 initialize_storage (struct emacs_value_storage
*storage
)
881 initialize_frame (&storage
->initial
);
882 storage
->current
= &storage
->initial
;
885 /* Must be called for any initialized storage object before its
886 lifetime ends. Free all dynamically-allocated frames. */
888 finalize_storage (struct emacs_value_storage
*storage
)
890 struct emacs_value_frame
*next
= storage
->initial
.next
;
893 struct emacs_value_frame
*current
= next
;
894 next
= current
->next
;
899 /* Allocate a new value from STORAGE and stores OBJ in it. Return
900 NULL if allocations fails and use ENV for non local exit reporting. */
902 allocate_emacs_value (emacs_env
*env
, struct emacs_value_storage
*storage
,
905 eassert (storage
->current
);
906 eassert (storage
->current
->offset
< value_frame_size
);
907 eassert (! storage
->current
->next
);
908 if (storage
->current
->offset
== value_frame_size
- 1)
910 storage
->current
->next
= malloc (sizeof *storage
->current
->next
);
911 if (! storage
->current
->next
)
913 module_out_of_memory (env
);
916 initialize_frame (storage
->current
->next
);
917 storage
->current
= storage
->current
->next
;
919 emacs_value value
= storage
->current
->objects
+ storage
->current
->offset
;
921 ++storage
->current
->offset
;
925 /* Mark all objects allocated from local environments so that they
926 don't get garbage-collected. */
927 void mark_modules (void)
929 for (Lisp_Object tem
= Vmodule_environments
; CONSP (tem
); tem
= XCDR (tem
))
931 struct env_storage
*env
= XSAVE_POINTER (tem
, 0);
932 for (struct emacs_value_frame
*frame
= &env
->priv
.storage
.initial
;
935 for (int i
= 0; i
< frame
->offset
; ++i
)
936 mark_object (frame
->objects
[i
].v
);
941 /* Environment lifetime management. */
943 /* Must be called before the environment can be used. */
945 initialize_environment (struct env_storage
*env
)
947 env
->priv
.pending_non_local_exit
= emacs_funcall_exit_return
;
948 initialize_storage (&env
->priv
.storage
);
949 env
->pub
.size
= sizeof env
->pub
;
950 env
->pub
.private_members
= &env
->priv
;
951 env
->pub
.make_global_ref
= module_make_global_ref
;
952 env
->pub
.free_global_ref
= module_free_global_ref
;
953 env
->pub
.non_local_exit_check
= module_non_local_exit_check
;
954 env
->pub
.non_local_exit_clear
= module_non_local_exit_clear
;
955 env
->pub
.non_local_exit_get
= module_non_local_exit_get
;
956 env
->pub
.non_local_exit_signal
= module_non_local_exit_signal
;
957 env
->pub
.non_local_exit_throw
= module_non_local_exit_throw
;
958 env
->pub
.make_function
= module_make_function
;
959 env
->pub
.funcall
= module_funcall
;
960 env
->pub
.intern
= module_intern
;
961 env
->pub
.type_of
= module_type_of
;
962 env
->pub
.is_not_nil
= module_is_not_nil
;
963 env
->pub
.eq
= module_eq
;
964 env
->pub
.extract_integer
= module_extract_integer
;
965 env
->pub
.make_integer
= module_make_integer
;
966 env
->pub
.extract_float
= module_extract_float
;
967 env
->pub
.make_float
= module_make_float
;
968 env
->pub
.copy_string_contents
= module_copy_string_contents
;
969 env
->pub
.make_string
= module_make_string
;
970 env
->pub
.make_user_ptr
= module_make_user_ptr
;
971 env
->pub
.get_user_ptr
= module_get_user_ptr
;
972 env
->pub
.set_user_ptr
= module_set_user_ptr
;
973 env
->pub
.get_user_finalizer
= module_get_user_finalizer
;
974 env
->pub
.set_user_finalizer
= module_set_user_finalizer
;
975 env
->pub
.vec_set
= module_vec_set
;
976 env
->pub
.vec_get
= module_vec_get
;
977 env
->pub
.vec_size
= module_vec_size
;
978 Vmodule_environments
= Fcons (make_save_ptr (env
), Vmodule_environments
);
981 /* Must be called before the lifetime of the environment object
984 finalize_environment (struct env_storage
*env
)
986 finalize_storage (&env
->priv
.storage
);
987 Vmodule_environments
= XCDR (Vmodule_environments
);
991 /* Non-local exit handling. */
993 /* Must be called after setting up a handler immediately before
994 returning from the function. See the comments in lisp.h and the
995 code in eval.c for details. The macros below arrange for this
996 function to be called automatically. DUMMY is ignored. */
998 module_reset_handlerlist (const int *dummy
)
1000 handlerlist
= handlerlist
->next
;
1003 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
1004 stored in the environment. Set the pending non-local exit flag. */
1006 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
1008 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
1011 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
1012 stored in the environment. Set the pending non-local exit flag. */
1014 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
1016 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
1020 /* Function environments. */
1022 /* Return a string object that contains a user-friendly
1023 representation of the function environment. */
1025 module_format_fun_env (const struct module_fun_env
*env
)
1027 /* Try to print a function name if possible. */
1028 const char *path
, *sym
;
1029 if (dynlib_addr (env
->subr
, &path
, &sym
))
1031 static char const format
[] = "#<module function %s from %s>";
1032 int size
= snprintf (NULL
, 0, format
, sym
, path
);
1034 char buffer
[size
+ 1];
1035 snprintf (buffer
, sizeof buffer
, format
, sym
, path
);
1036 return make_unibyte_string (buffer
, size
);
1040 static char const format
[] = "#<module function at %p>";
1041 void *subr
= env
->subr
;
1042 int size
= snprintf (NULL
, 0, format
, subr
);
1044 char buffer
[size
+ 1];
1045 snprintf (buffer
, sizeof buffer
, format
, subr
);
1046 return make_unibyte_string (buffer
, size
);
1051 /* Segment initializer. */
1054 syms_of_module (void)
1056 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
1057 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
1058 doc
: /* Module global referrence table. */);
1061 = make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
1062 make_float (DEFAULT_REHASH_SIZE
),
1063 make_float (DEFAULT_REHASH_THRESHOLD
),
1065 Funintern (Qmodule_refs_hash
, Qnil
);
1067 DEFSYM (Qmodule_environments
, "module-environments");
1068 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1069 doc
: /* List of active module environments. */);
1070 Vmodule_environments
= Qnil
;
1071 /* Unintern `module-environments' because it is only used
1073 Funintern (Qmodule_environments
, Qnil
);
1075 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1076 Fput (Qmodule_load_failed
, Qerror_conditions
,
1077 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1078 Fput (Qmodule_load_failed
, Qerror_message
,
1079 build_pure_c_string ("Module load failed"));
1081 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1082 Fput (Qinvalid_module_call
, Qerror_conditions
,
1083 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1084 Fput (Qinvalid_module_call
, Qerror_message
,
1085 build_pure_c_string ("Invalid module call"));
1087 DEFSYM (Qinvalid_arity
, "invalid-arity");
1088 Fput (Qinvalid_arity
, Qerror_conditions
,
1089 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1090 Fput (Qinvalid_arity
, Qerror_message
,
1091 build_pure_c_string ("Invalid function arity"));
1093 initialize_storage (&global_storage
);
1095 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1096 code or modules should not access it. */
1097 Funintern (Qmodule_refs_hash
, Qnil
);
1099 defsubr (&Smodule_load
);
1101 /* Don't call defsubr on `module-call' because that would intern it,
1102 but `module-call' is an internal function that users cannot
1103 meaningfully use. Instead, assign its definition to a private
1105 XSETPVECTYPE (&Smodule_call
, PVEC_SUBR
);
1106 XSETSUBR (module_call_func
, &Smodule_call
);
1109 /* Unlike syms_of_module, this initializer is called even from an
1110 initialized (dumped) Emacs. */
1115 /* It is not guaranteed that dynamic initializers run in the main thread,
1116 therefore detect the main thread here. */
1117 #ifdef HAVE_THREADS_H
1118 main_thread
= thrd_current ();
1119 #elif defined HAVE_PTHREAD
1120 main_thread
= pthread_self ();
1121 #elif defined WINDOWSNT
1122 /* This calls APIs that are only available on Vista and later. */
1124 /* GetCurrentProcess returns a pseudohandle, which must be duplicated. */
1125 if (! DuplicateHandle (GetCurrentProcess (), GetCurrentThread (),
1126 GetCurrentProcess (), &main_thread
,
1127 SYNCHRONIZE
| THREAD_QUERY_INFORMATION
,
1131 /* GetCurrentThread returns a pseudohandle, which must be duplicated. */
1132 HANDLE th
= GetCurrentThread ();
1133 if (!DuplicateHandle (GetCurrentProcess (), th
,
1134 GetCurrentProcess (), &main_thread
, 0, FALSE
,
1135 DUPLICATE_SAME_ACCESS
))
1137 main_thread_id
= GetCurrentThreadId ();