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"
38 /* True if __attribute__ ((cleanup (...))) works, false otherwise. */
39 #ifdef HAVE_VAR_ATTRIBUTE_CLEANUP
40 enum { module_has_cleanup
= true };
42 enum { module_has_cleanup
= false };
45 /* Handle to the main thread. Used to verify that modules call us in
49 static thrd_t main_thread
;
50 #elif defined HAVE_PTHREAD
52 static pthread_t main_thread
;
53 #elif defined WINDOWSNT
56 static DWORD main_thread
;
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 /* The private parts of an `emacs_runtime' object contain the initial
116 struct emacs_runtime_private
118 /* FIXME: Ideally, we would just define "struct emacs_runtime_private"
119 * as a synonym of "emacs_env", but I don't know how to do that in C. */
124 /* Forward declarations. */
126 struct module_fun_env
;
128 static Lisp_Object
module_format_fun_env (const struct module_fun_env
*);
129 static Lisp_Object
value_to_lisp (emacs_value
);
130 static emacs_value
allocate_emacs_value (emacs_env
*, struct emacs_value_storage
*, Lisp_Object
);
131 static emacs_value
lisp_to_value (emacs_env
*, Lisp_Object
);
132 static enum emacs_funcall_exit
module_non_local_exit_check (emacs_env
*);
133 static void check_main_thread (void);
134 static void finalize_environment (struct emacs_env_private
*);
135 static void initialize_environment (emacs_env
*, struct emacs_env_private
*priv
);
136 static void module_args_out_of_range (emacs_env
*, Lisp_Object
, Lisp_Object
);
137 static void module_handle_signal (emacs_env
*, Lisp_Object
);
138 static void module_handle_throw (emacs_env
*, Lisp_Object
);
139 static void module_non_local_exit_signal_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
140 static void module_non_local_exit_throw_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
141 static void module_out_of_memory (emacs_env
*);
142 static void module_reset_handlerlist (const int *);
143 static void module_wrong_type (emacs_env
*, Lisp_Object
, Lisp_Object
);
146 /* Convenience macros for non-local exit handling. */
148 /* Emacs uses setjmp and longjmp for non-local exits, but
149 module frames cannot be skipped because they are in general
150 not prepared for long jumps (e.g., the behavior in C++ is undefined
151 if objects with nontrivial destructors would be skipped).
152 Therefore, catch all non-local exits. There are two kinds of
153 non-local exits: `signal' and `throw'. The macros in this section
154 can be used to catch both. Use macros to avoid additional variants
155 of `internal_condition_case' etc., and to avoid worrying about
156 passing information to the handler functions. */
158 /* Place this macro at the beginning of a function returning a number
159 or a pointer to handle signals. The function must have an ENV
160 parameter. The function will return 0 (or NULL) if a signal is
162 #define MODULE_HANDLE_SIGNALS MODULE_HANDLE_SIGNALS_RETURN (0)
164 /* Place this macro at the beginning of a function returning void to
165 handle signals. The function must have an ENV parameter. */
166 #define MODULE_HANDLE_SIGNALS_VOID MODULE_HANDLE_SIGNALS_RETURN ()
168 #define MODULE_HANDLE_SIGNALS_RETURN(retval) \
169 MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval)
171 /* Place this macro at the beginning of a function returning a pointer
172 to handle non-local exits via `throw'. The function must have an
173 ENV parameter. The function will return NULL if a `throw' is
175 #define MODULE_HANDLE_THROW \
176 MODULE_SETJMP (CATCHER_ALL, module_handle_throw, NULL)
178 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
179 MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \
180 internal_handler_##handlertype, \
181 internal_cleanup_##handlertype)
183 /* It is very important that pushing the handler doesn't itself raise
184 a signal. Install the cleanup only after the handler has been
185 pushed. Use __attribute__ ((cleanup)) to avoid
186 non-local-exit-prone manual cleanup.
188 The do-while forces uses of the macro to be followed by a semicolon.
189 This macro cannot enclose its entire body inside a do-while, as the
190 code after the macro may longjmp back into the macro, which means
191 its local variable C must stay live in later code. */
193 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
194 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
196 struct handler *c = push_handler_nosignal (Qt, handlertype); \
199 module_out_of_memory (env); \
202 verify (module_has_cleanup); \
203 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
204 if (sys_setjmp (c->jmp)) \
206 (handlerfunc) (env, c->val); \
212 /* Function environments. */
214 /* A function environment is an auxiliary structure used by
215 `module_make_function' to store information about a module
216 function. It is stored in a save pointer and retrieved by
217 `internal--module-call'. Its members correspond to the arguments
218 given to `module_make_function'. */
220 struct module_fun_env
222 ptrdiff_t min_arity
, max_arity
;
228 /* Implementation of runtime and environment functions.
230 These should abide by the following rules:
232 1. The first argument should always be a pointer to emacs_env.
234 2. Each function should first call check_main_thread. Note that
235 this function is a no-op unless Emacs was built with
238 3. The very next thing each function should do is check that the
239 emacs_env object does not have a non-local exit indication set,
240 by calling module_non_local_exit_check. If that returns
241 anything but emacs_funcall_exit_return, the function should do
242 nothing and return immediately with an error indication, without
243 clobbering the existing error indication in emacs_env. This is
244 needed for correct reporting of Lisp errors to the Emacs Lisp
247 4. Any function that needs to call Emacs facilities, such as
248 encoding or decoding functions, or 'intern', or 'make_string',
249 should protect itself from signals and 'throw' in the called
250 Emacs functions, by placing the macros MODULE_HANDLE_SIGNALS
251 and/or MODULE_HANDLE_THROW right after the above 2 tests.
253 5. Do NOT use 'eassert' for checking validity of user code in the
254 module. Instead, make those checks part of the code, and if the
255 check fails, call 'module_non_local_exit_signal_1' or
256 'module_non_local_exit_throw_1' to report the error. This is
257 because using 'eassert' in these situations will abort Emacs
258 instead of reporting the error back to Lisp, and also because
259 'eassert' is compiled to nothing in the release version. */
261 /* Catch signals and throws only if the code can actually signal or
262 throw. If checking is enabled, abort if the current thread is not
263 the Emacs main thread. */
266 module_get_environment (struct emacs_runtime
*ert
)
268 check_main_thread ();
269 return &ert
->private_members
->pub
;
272 /* To make global refs (GC-protected global values) keep a hash that
273 maps global Lisp objects to reference counts. */
276 module_make_global_ref (emacs_env
*env
, emacs_value ref
)
278 check_main_thread ();
279 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
281 MODULE_HANDLE_SIGNALS
;
282 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
283 Lisp_Object new_obj
= value_to_lisp (ref
);
285 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
289 Lisp_Object value
= HASH_VALUE (h
, i
);
290 EMACS_INT refcount
= XFASTINT (value
) + 1;
291 if (refcount
> MOST_POSITIVE_FIXNUM
)
293 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
296 value
= make_natnum (refcount
);
297 set_hash_value_slot (h
, i
, value
);
301 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
304 return allocate_emacs_value (env
, &global_storage
, new_obj
);
308 module_free_global_ref (emacs_env
*env
, emacs_value ref
)
310 check_main_thread ();
311 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
313 /* TODO: This probably never signals. */
314 /* FIXME: Wait a minute. Shouldn't this function report an error if
315 the hash lookup fails? */
316 MODULE_HANDLE_SIGNALS_VOID
;
317 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
318 Lisp_Object obj
= value_to_lisp (ref
);
320 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
324 Lisp_Object value
= HASH_VALUE (h
, i
);
325 EMACS_INT refcount
= XFASTINT (value
) - 1;
328 value
= make_natnum (refcount
);
329 set_hash_value_slot (h
, i
, value
);
332 hash_remove_from_table (h
, value
);
336 static enum emacs_funcall_exit
337 module_non_local_exit_check (emacs_env
*env
)
339 check_main_thread ();
340 return env
->private_members
->pending_non_local_exit
;
344 module_non_local_exit_clear (emacs_env
*env
)
346 check_main_thread ();
347 env
->private_members
->pending_non_local_exit
= emacs_funcall_exit_return
;
350 static enum emacs_funcall_exit
351 module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
)
353 check_main_thread ();
354 struct emacs_env_private
*p
= env
->private_members
;
355 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
357 *sym
= &p
->non_local_exit_symbol
;
358 *data
= &p
->non_local_exit_data
;
360 return p
->pending_non_local_exit
;
363 /* Like for `signal', DATA must be a list. */
365 module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
)
367 check_main_thread ();
368 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
369 module_non_local_exit_signal_1 (env
, value_to_lisp (sym
),
370 value_to_lisp (data
));
374 module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
)
376 check_main_thread ();
377 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
378 module_non_local_exit_throw_1 (env
, value_to_lisp (tag
),
379 value_to_lisp (value
));
382 /* A module function is lambda function that calls
383 `internal--module-call', passing the function pointer of the module
384 function along with the module emacs_env pointer as arguments.
386 (function (lambda (&rest arglist)
387 (internal--module-call envobj arglist))) */
390 module_make_function (emacs_env
*env
, ptrdiff_t min_arity
, ptrdiff_t max_arity
,
391 emacs_subr subr
, const char *documentation
,
394 check_main_thread ();
395 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
397 MODULE_HANDLE_SIGNALS
;
399 if (! (0 <= min_arity
401 ? max_arity
== emacs_variadic_function
402 : min_arity
<= max_arity
)))
403 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
405 /* FIXME: This should be freed when envobj is GC'd. */
406 struct module_fun_env
*envptr
= xmalloc (sizeof *envptr
);
407 envptr
->min_arity
= min_arity
;
408 envptr
->max_arity
= max_arity
;
412 Lisp_Object envobj
= make_save_ptr (envptr
);
415 ? code_convert_string_norecord (build_unibyte_string (documentation
),
418 Lisp_Object ret
= list4 (Qlambda
,
419 list2 (Qand_rest
, Qargs
),
421 list3 (Qinternal_module_call
,
425 return lisp_to_value (env
, ret
);
429 module_funcall (emacs_env
*env
, emacs_value fun
, ptrdiff_t nargs
,
432 check_main_thread ();
433 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
435 MODULE_HANDLE_SIGNALS
;
438 /* Make a new Lisp_Object array starting with the function as the
439 first arg, because that's what Ffuncall takes. */
440 Lisp_Object
*newargs
;
442 SAFE_ALLOCA_LISP (newargs
, nargs
+ 1);
443 newargs
[0] = value_to_lisp (fun
);
444 for (ptrdiff_t i
= 0; i
< nargs
; i
++)
445 newargs
[1 + i
] = value_to_lisp (args
[i
]);
446 emacs_value result
= lisp_to_value (env
, Ffuncall (nargs
+ 1, newargs
));
452 module_intern (emacs_env
*env
, const char *name
)
454 check_main_thread ();
455 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
457 MODULE_HANDLE_SIGNALS
;
458 return lisp_to_value (env
, intern (name
));
462 module_type_of (emacs_env
*env
, emacs_value value
)
464 check_main_thread ();
465 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
467 return lisp_to_value (env
, Ftype_of (value_to_lisp (value
)));
471 module_is_not_nil (emacs_env
*env
, emacs_value value
)
473 check_main_thread ();
474 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
476 return ! NILP (value_to_lisp (value
));
480 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
482 check_main_thread ();
483 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
485 return EQ (value_to_lisp (a
), value_to_lisp (b
));
489 module_extract_integer (emacs_env
*env
, emacs_value n
)
491 check_main_thread ();
492 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
494 Lisp_Object l
= value_to_lisp (n
);
497 module_wrong_type (env
, Qintegerp
, l
);
504 module_make_integer (emacs_env
*env
, intmax_t n
)
506 check_main_thread ();
507 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
509 if (! (MOST_NEGATIVE_FIXNUM
<= n
&& n
<= MOST_POSITIVE_FIXNUM
))
511 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
514 return lisp_to_value (env
, make_number (n
));
518 module_extract_float (emacs_env
*env
, emacs_value f
)
520 check_main_thread ();
521 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
523 Lisp_Object lisp
= value_to_lisp (f
);
526 module_wrong_type (env
, Qfloatp
, lisp
);
529 return XFLOAT_DATA (lisp
);
533 module_make_float (emacs_env
*env
, double d
)
535 check_main_thread ();
536 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
538 MODULE_HANDLE_SIGNALS
;
539 return lisp_to_value (env
, make_float (d
));
543 module_copy_string_contents (emacs_env
*env
, emacs_value value
, char *buffer
,
546 check_main_thread ();
547 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
549 MODULE_HANDLE_SIGNALS
;
550 Lisp_Object lisp_str
= value_to_lisp (value
);
551 if (! STRINGP (lisp_str
))
553 module_wrong_type (env
, Qstringp
, lisp_str
);
557 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
558 ptrdiff_t raw_size
= SBYTES (lisp_str_utf8
);
559 if (raw_size
== PTRDIFF_MAX
)
561 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
564 ptrdiff_t required_buf_size
= raw_size
+ 1;
566 eassert (length
!= NULL
);
570 *length
= required_buf_size
;
574 eassert (*length
>= 0);
576 if (*length
< required_buf_size
)
578 *length
= required_buf_size
;
579 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, Qnil
);
583 *length
= required_buf_size
;
584 memcpy (buffer
, SDATA (lisp_str_utf8
), raw_size
+ 1);
590 module_make_string (emacs_env
*env
, const char *str
, ptrdiff_t length
)
592 check_main_thread ();
593 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
595 MODULE_HANDLE_SIGNALS
;
596 if (length
> STRING_BYTES_BOUND
)
598 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
601 Lisp_Object lstr
= make_unibyte_string (str
, length
);
602 return lisp_to_value (env
,
603 code_convert_string_norecord (lstr
, Qutf_8
, false));
607 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
609 check_main_thread ();
610 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
612 return lisp_to_value (env
, make_user_ptr (fin
, ptr
));
616 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
618 check_main_thread ();
619 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
621 Lisp_Object lisp
= value_to_lisp (uptr
);
622 if (! USER_PTRP (lisp
))
624 module_wrong_type (env
, Quser_ptr
, lisp
);
627 return XUSER_PTR (lisp
)->p
;
631 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
633 check_main_thread ();
634 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
636 Lisp_Object lisp
= value_to_lisp (uptr
);
637 if (! USER_PTRP (lisp
))
638 module_wrong_type (env
, Quser_ptr
, lisp
);
639 XUSER_PTR (lisp
)->p
= ptr
;
642 static emacs_finalizer_function
643 module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
645 check_main_thread ();
646 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
648 Lisp_Object lisp
= value_to_lisp (uptr
);
649 if (! USER_PTRP (lisp
))
651 module_wrong_type (env
, Quser_ptr
, lisp
);
654 return XUSER_PTR (lisp
)->finalizer
;
658 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
659 emacs_finalizer_function fin
)
661 check_main_thread ();
662 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
664 Lisp_Object lisp
= value_to_lisp (uptr
);
665 if (! USER_PTRP (lisp
))
666 module_wrong_type (env
, Quser_ptr
, lisp
);
667 XUSER_PTR (lisp
)->finalizer
= fin
;
671 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
673 check_main_thread ();
674 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
676 Lisp_Object lvec
= value_to_lisp (vec
);
677 if (! VECTORP (lvec
))
679 module_wrong_type (env
, Qvectorp
, lvec
);
682 if (! (0 <= i
&& i
< ASIZE (lvec
)))
684 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
685 module_args_out_of_range (env
, lvec
, make_number (i
));
687 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
690 ASET (lvec
, i
, value_to_lisp (val
));
694 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
696 check_main_thread ();
697 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
699 Lisp_Object lvec
= value_to_lisp (vec
);
700 if (! VECTORP (lvec
))
702 module_wrong_type (env
, Qvectorp
, lvec
);
705 if (! (0 <= i
&& i
< ASIZE (lvec
)))
707 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
708 module_args_out_of_range (env
, lvec
, make_number (i
));
710 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
713 return lisp_to_value (env
, AREF (lvec
, i
));
717 module_vec_size (emacs_env
*env
, emacs_value vec
)
719 check_main_thread ();
720 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
722 Lisp_Object lvec
= value_to_lisp (vec
);
723 if (! VECTORP (lvec
))
725 module_wrong_type (env
, Qvectorp
, lvec
);
734 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
735 doc
: /* Load module FILE. */)
738 dynlib_handle_ptr handle
;
739 emacs_init_function module_init
;
743 handle
= dynlib_open (SSDATA (file
));
745 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
747 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
749 error ("Module %s is not GPL compatible", SDATA (file
));
751 module_init
= (emacs_init_function
) dynlib_func (handle
, "emacs_module_init");
753 error ("Module %s does not have an init function.", SDATA (file
));
755 struct emacs_runtime_private rt
; /* Includes the public emacs_env. */
756 struct emacs_env_private priv
;
757 initialize_environment (&rt
.pub
, &priv
);
758 struct emacs_runtime pub
=
761 .private_members
= &rt
,
762 .get_environment
= module_get_environment
764 int r
= module_init (&pub
);
765 finalize_environment (&priv
);
769 if (! (MOST_NEGATIVE_FIXNUM
<= r
&& r
<= MOST_POSITIVE_FIXNUM
))
770 xsignal0 (Qoverflow_error
);
771 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
777 DEFUN ("internal--module-call", Finternal_module_call
, Sinternal_module_call
, 2, 2, 0,
778 doc
: /* Internal function to call a module function.
779 ENVOBJ is a save pointer to a module_fun_env structure.
780 ARGLIST is a list of arguments passed to SUBRPTR. */)
781 (Lisp_Object envobj
, Lisp_Object arglist
)
783 CHECK_TYPE (SAVE_VALUEP (envobj
), Qsave_value_p
, envobj
);
784 struct Lisp_Save_Value
*save_value
= XSAVE_VALUE (envobj
);
785 CHECK_TYPE (save_type (save_value
, 0) == SAVE_POINTER
, Qsave_pointer_p
, envobj
);
786 CHECK_CONS (arglist
);
787 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
788 EMACS_INT len
= XFASTINT (Flength (arglist
));
789 eassume (0 <= envptr
->min_arity
);
790 if (! (envptr
->min_arity
<= len
791 && len
<= (envptr
->max_arity
< 0 ? PTRDIFF_MAX
: envptr
->max_arity
)))
792 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
796 struct emacs_env_private priv
;
797 initialize_environment (&pub
, &priv
);
799 emacs_value
*args
= xnmalloc (len
, sizeof *args
);
801 for (ptrdiff_t i
= 0; i
< len
; i
++)
803 args
[i
] = lisp_to_value (&pub
, XCAR (arglist
));
805 memory_full (sizeof *args
[i
]);
806 arglist
= XCDR (arglist
);
809 emacs_value ret
= envptr
->subr (&pub
, len
, args
, envptr
->data
);
812 eassert (&priv
== pub
.private_members
);
814 switch (priv
.pending_non_local_exit
)
816 case emacs_funcall_exit_return
:
817 finalize_environment (&priv
);
819 xsignal1 (Qinvalid_module_call
, module_format_fun_env (envptr
));
820 return value_to_lisp (ret
);
821 case emacs_funcall_exit_signal
:
823 Lisp_Object symbol
= value_to_lisp (&priv
.non_local_exit_symbol
);
824 Lisp_Object data
= value_to_lisp (&priv
.non_local_exit_data
);
825 finalize_environment (&priv
);
826 xsignal (symbol
, data
);
828 case emacs_funcall_exit_throw
:
830 Lisp_Object tag
= value_to_lisp (&priv
.non_local_exit_symbol
);
831 Lisp_Object value
= value_to_lisp (&priv
.non_local_exit_data
);
832 finalize_environment (&priv
);
841 /* Helper functions. */
844 check_main_thread (void)
846 #ifdef HAVE_THREADS_H
847 eassert (thrd_equal (thdr_current (), main_thread
));
848 #elif defined HAVE_PTHREAD
849 eassert (pthread_equal (pthread_self (), main_thread
));
850 #elif defined WINDOWSNT
851 eassert (GetCurrentThreadId () == main_thread
);
856 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
859 struct emacs_env_private
*p
= env
->private_members
;
860 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
862 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
863 p
->non_local_exit_symbol
.v
= sym
;
864 p
->non_local_exit_data
.v
= data
;
869 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
872 struct emacs_env_private
*p
= env
->private_members
;
873 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
875 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
876 p
->non_local_exit_symbol
.v
= tag
;
877 p
->non_local_exit_data
.v
= value
;
881 /* Module version of `wrong_type_argument'. */
883 module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
)
885 module_non_local_exit_signal_1 (env
, Qwrong_type_argument
,
886 list2 (predicate
, value
));
889 /* Signal an out-of-memory condition to the caller. */
891 module_out_of_memory (emacs_env
*env
)
893 /* TODO: Reimplement this so it works even if memory-signal-data has
895 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
896 XCDR (Vmemory_signal_data
));
899 /* Signal arguments are out of range. */
901 module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
)
903 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, list2 (a1
, a2
));
907 /* Value conversion. */
909 /* Convert an `emacs_value' to the corresponding internal object.
912 value_to_lisp (emacs_value v
)
917 /* Convert an internal object to an `emacs_value'. Allocate storage
918 from the environment; return NULL if allocation fails. */
920 lisp_to_value (emacs_env
*env
, Lisp_Object o
)
922 struct emacs_env_private
*p
= env
->private_members
;
923 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
925 return allocate_emacs_value (env
, &p
->storage
, o
);
929 /* Memory management. */
931 /* Must be called for each frame before it can be used for allocation. */
933 initialize_frame (struct emacs_value_frame
*frame
)
939 /* Must be called for any storage object before it can be used for
942 initialize_storage (struct emacs_value_storage
*storage
)
944 initialize_frame (&storage
->initial
);
945 storage
->current
= &storage
->initial
;
948 /* Must be called for any initialized storage object before its
949 lifetime ends. Free all dynamically-allocated frames. */
951 finalize_storage (struct emacs_value_storage
*storage
)
953 struct emacs_value_frame
*next
= storage
->initial
.next
;
956 struct emacs_value_frame
*current
= next
;
957 next
= current
->next
;
962 /* Allocate a new value from STORAGE and stores OBJ in it. Return
963 NULL if allocation fails and use ENV for non local exit reporting. */
965 allocate_emacs_value (emacs_env
*env
, struct emacs_value_storage
*storage
,
968 eassert (storage
->current
);
969 eassert (storage
->current
->offset
< value_frame_size
);
970 eassert (! storage
->current
->next
);
971 if (storage
->current
->offset
== value_frame_size
- 1)
973 storage
->current
->next
= malloc (sizeof *storage
->current
->next
);
974 if (! storage
->current
->next
)
976 module_out_of_memory (env
);
979 initialize_frame (storage
->current
->next
);
980 storage
->current
= storage
->current
->next
;
982 emacs_value value
= storage
->current
->objects
+ storage
->current
->offset
;
984 ++storage
->current
->offset
;
988 /* Mark all objects allocated from local environments so that they
989 don't get garbage-collected. */
993 for (Lisp_Object tem
= Vmodule_environments
; CONSP (tem
); tem
= XCDR (tem
))
995 struct emacs_env_private
*priv
= XSAVE_POINTER (tem
, 0);
996 for (struct emacs_value_frame
*frame
= &priv
->storage
.initial
;
999 for (int i
= 0; i
< frame
->offset
; ++i
)
1000 mark_object (frame
->objects
[i
].v
);
1005 /* Environment lifetime management. */
1007 /* Must be called before the environment can be used. */
1009 initialize_environment (emacs_env
*env
, struct emacs_env_private
*priv
)
1011 priv
->pending_non_local_exit
= emacs_funcall_exit_return
;
1012 initialize_storage (&priv
->storage
);
1013 env
->size
= sizeof *env
;
1014 env
->private_members
= priv
;
1015 env
->make_global_ref
= module_make_global_ref
;
1016 env
->free_global_ref
= module_free_global_ref
;
1017 env
->non_local_exit_check
= module_non_local_exit_check
;
1018 env
->non_local_exit_clear
= module_non_local_exit_clear
;
1019 env
->non_local_exit_get
= module_non_local_exit_get
;
1020 env
->non_local_exit_signal
= module_non_local_exit_signal
;
1021 env
->non_local_exit_throw
= module_non_local_exit_throw
;
1022 env
->make_function
= module_make_function
;
1023 env
->funcall
= module_funcall
;
1024 env
->intern
= module_intern
;
1025 env
->type_of
= module_type_of
;
1026 env
->is_not_nil
= module_is_not_nil
;
1027 env
->eq
= module_eq
;
1028 env
->extract_integer
= module_extract_integer
;
1029 env
->make_integer
= module_make_integer
;
1030 env
->extract_float
= module_extract_float
;
1031 env
->make_float
= module_make_float
;
1032 env
->copy_string_contents
= module_copy_string_contents
;
1033 env
->make_string
= module_make_string
;
1034 env
->make_user_ptr
= module_make_user_ptr
;
1035 env
->get_user_ptr
= module_get_user_ptr
;
1036 env
->set_user_ptr
= module_set_user_ptr
;
1037 env
->get_user_finalizer
= module_get_user_finalizer
;
1038 env
->set_user_finalizer
= module_set_user_finalizer
;
1039 env
->vec_set
= module_vec_set
;
1040 env
->vec_get
= module_vec_get
;
1041 env
->vec_size
= module_vec_size
;
1042 Vmodule_environments
= Fcons (make_save_ptr (priv
), Vmodule_environments
);
1045 /* Must be called before the lifetime of the environment object
1048 finalize_environment (struct emacs_env_private
*env
)
1050 finalize_storage (&env
->storage
);
1051 Vmodule_environments
= XCDR (Vmodule_environments
);
1055 /* Non-local exit handling. */
1057 /* Must be called after setting up a handler immediately before
1058 returning from the function. See the comments in lisp.h and the
1059 code in eval.c for details. The macros below arrange for this
1060 function to be called automatically. DUMMY is ignored. */
1062 module_reset_handlerlist (const int *dummy
)
1064 handlerlist
= handlerlist
->next
;
1067 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
1068 stored in the environment. Set the pending non-local exit flag. */
1070 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
1072 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
1075 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
1076 stored in the environment. Set the pending non-local exit flag. */
1078 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
1080 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
1084 /* Function environments. */
1086 /* Return a string object that contains a user-friendly
1087 representation of the function environment. */
1089 module_format_fun_env (const struct module_fun_env
*env
)
1091 /* Try to print a function name if possible. */
1092 const char *path
, *sym
;
1093 static char const noaddr_format
[] = "#<module function at %p>";
1094 char buffer
[sizeof noaddr_format
+ INT_STRLEN_BOUND (intptr_t) + 256];
1096 ptrdiff_t bufsize
= sizeof buffer
;
1098 = (dynlib_addr (env
->subr
, &path
, &sym
)
1099 ? exprintf (&buf
, &bufsize
, buffer
, -1,
1100 "#<module function %s from %s>", sym
, path
)
1101 : sprintf (buffer
, noaddr_format
, env
->subr
));
1102 Lisp_Object unibyte_result
= make_unibyte_string (buffer
, size
);
1105 return code_convert_string_norecord (unibyte_result
, Qutf_8
, false);
1109 /* Segment initializer. */
1112 syms_of_module (void)
1114 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
1115 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
1116 doc
: /* Module global referrence table. */);
1119 = 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 DEFSYM (Qsave_value_p
, "save-value-p");
1158 DEFSYM (Qsave_pointer_p
, "save-pointer-p");
1160 defsubr (&Smodule_load
);
1162 DEFSYM (Qinternal_module_call
, "internal--module-call");
1163 defsubr (&Sinternal_module_call
);
1166 /* Unlike syms_of_module, this initializer is called even from an
1167 initialized (dumped) Emacs. */
1172 /* It is not guaranteed that dynamic initializers run in the main thread,
1173 therefore detect the main thread here. */
1174 #ifdef HAVE_THREADS_H
1175 main_thread
= thrd_current ();
1176 #elif defined HAVE_PTHREAD
1177 main_thread
= pthread_self ();
1178 #elif defined WINDOWSNT
1179 /* The 'main' function already recorded the main thread's thread ID,
1180 so we need just to use it . */
1181 main_thread
= dwMainThreadId
;