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 non-local exits. The function must have an
160 ENV parameter. The function will return the specified value if a
161 signal or throw is caught. */
162 // TODO: Have Fsignal check for CATCHER_ALL so we only have to install
164 #define MODULE_HANDLE_NONLOCAL_EXIT(retval) \
165 MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval); \
166 MODULE_SETJMP (CATCHER_ALL, module_handle_throw, retval)
168 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
169 MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \
170 internal_handler_##handlertype, \
171 internal_cleanup_##handlertype)
173 /* It is very important that pushing the handler doesn't itself raise
174 a signal. Install the cleanup only after the handler has been
175 pushed. Use __attribute__ ((cleanup)) to avoid
176 non-local-exit-prone manual cleanup.
178 The do-while forces uses of the macro to be followed by a semicolon.
179 This macro cannot enclose its entire body inside a do-while, as the
180 code after the macro may longjmp back into the macro, which means
181 its local variable C must stay live in later code. */
183 // TODO: Make backtraces work if this macros is used.
185 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
186 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
188 struct handler *c = push_handler_nosignal (Qt, handlertype); \
191 module_out_of_memory (env); \
194 verify (module_has_cleanup); \
195 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
196 if (sys_setjmp (c->jmp)) \
198 (handlerfunc) (env, c->val); \
204 /* Function environments. */
206 /* A function environment is an auxiliary structure used by
207 `module_make_function' to store information about a module
208 function. It is stored in a save pointer and retrieved by
209 `internal--module-call'. Its members correspond to the arguments
210 given to `module_make_function'. */
212 struct module_fun_env
214 ptrdiff_t min_arity
, max_arity
;
220 /* Implementation of runtime and environment functions.
222 These should abide by the following rules:
224 1. The first argument should always be a pointer to emacs_env.
226 2. Each function should first call check_main_thread. Note that
227 this function is a no-op unless Emacs was built with
230 3. The very next thing each function should do is check that the
231 emacs_env object does not have a non-local exit indication set,
232 by calling module_non_local_exit_check. If that returns
233 anything but emacs_funcall_exit_return, the function should do
234 nothing and return immediately with an error indication, without
235 clobbering the existing error indication in emacs_env. This is
236 needed for correct reporting of Lisp errors to the Emacs Lisp
239 4. Any function that needs to call Emacs facilities, such as
240 encoding or decoding functions, or 'intern', or 'make_string',
241 should protect itself from signals and 'throw' in the called
242 Emacs functions, by placing the macro
243 MODULE_HANDLE_NONLOCAL_EXIT right after the above 2 tests.
245 5. Do NOT use 'eassert' for checking validity of user code in the
246 module. Instead, make those checks part of the code, and if the
247 check fails, call 'module_non_local_exit_signal_1' or
248 'module_non_local_exit_throw_1' to report the error. This is
249 because using 'eassert' in these situations will abort Emacs
250 instead of reporting the error back to Lisp, and also because
251 'eassert' is compiled to nothing in the release version. */
253 /* Use MODULE_FUNCTION_BEGIN to implement steps 2 through 4 for most
254 environment functions. On error it will return its argument, which
255 should be a sentinel value. */
257 #define MODULE_FUNCTION_BEGIN(error_retval) \
258 check_main_thread (); \
259 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
260 return error_retval; \
261 MODULE_HANDLE_NONLOCAL_EXIT (error_retval)
263 /* Catch signals and throws only if the code can actually signal or
264 throw. If checking is enabled, abort if the current thread is not
265 the Emacs main thread. */
268 module_get_environment (struct emacs_runtime
*ert
)
270 check_main_thread ();
271 return &ert
->private_members
->pub
;
274 /* To make global refs (GC-protected global values) keep a hash that
275 maps global Lisp objects to reference counts. */
278 module_make_global_ref (emacs_env
*env
, emacs_value ref
)
280 MODULE_FUNCTION_BEGIN (NULL
);
281 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
282 Lisp_Object new_obj
= value_to_lisp (ref
);
284 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
288 Lisp_Object value
= HASH_VALUE (h
, i
);
289 EMACS_INT refcount
= XFASTINT (value
) + 1;
290 if (refcount
> MOST_POSITIVE_FIXNUM
)
292 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
295 value
= make_natnum (refcount
);
296 set_hash_value_slot (h
, i
, value
);
300 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
303 return allocate_emacs_value (env
, &global_storage
, new_obj
);
307 module_free_global_ref (emacs_env
*env
, emacs_value ref
)
309 /* TODO: This probably never signals. */
310 /* FIXME: Wait a minute. Shouldn't this function report an error if
311 the hash lookup fails? */
312 MODULE_FUNCTION_BEGIN ();
313 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
314 Lisp_Object obj
= value_to_lisp (ref
);
316 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
320 Lisp_Object value
= HASH_VALUE (h
, i
);
321 EMACS_INT refcount
= XFASTINT (value
) - 1;
324 value
= make_natnum (refcount
);
325 set_hash_value_slot (h
, i
, value
);
328 hash_remove_from_table (h
, value
);
332 static enum emacs_funcall_exit
333 module_non_local_exit_check (emacs_env
*env
)
335 check_main_thread ();
336 return env
->private_members
->pending_non_local_exit
;
340 module_non_local_exit_clear (emacs_env
*env
)
342 check_main_thread ();
343 env
->private_members
->pending_non_local_exit
= emacs_funcall_exit_return
;
346 static enum emacs_funcall_exit
347 module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
)
349 check_main_thread ();
350 struct emacs_env_private
*p
= env
->private_members
;
351 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
353 *sym
= &p
->non_local_exit_symbol
;
354 *data
= &p
->non_local_exit_data
;
356 return p
->pending_non_local_exit
;
359 /* Like for `signal', DATA must be a list. */
361 module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
)
363 check_main_thread ();
364 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
365 module_non_local_exit_signal_1 (env
, value_to_lisp (sym
),
366 value_to_lisp (data
));
370 module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
)
372 check_main_thread ();
373 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
374 module_non_local_exit_throw_1 (env
, value_to_lisp (tag
),
375 value_to_lisp (value
));
378 /* A module function is lambda function that calls
379 `internal--module-call', passing the function pointer of the module
380 function along with the module emacs_env pointer as arguments.
382 (function (lambda (&rest arglist)
383 (internal--module-call envobj arglist))) */
386 module_make_function (emacs_env
*env
, ptrdiff_t min_arity
, ptrdiff_t max_arity
,
387 emacs_subr subr
, const char *documentation
,
390 MODULE_FUNCTION_BEGIN (NULL
);
392 if (! (0 <= min_arity
394 ? max_arity
== emacs_variadic_function
395 : min_arity
<= max_arity
)))
396 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
398 /* FIXME: This should be freed when envobj is GC'd. */
399 struct module_fun_env
*envptr
= xmalloc (sizeof *envptr
);
400 envptr
->min_arity
= min_arity
;
401 envptr
->max_arity
= max_arity
;
405 Lisp_Object envobj
= make_save_ptr (envptr
);
408 ? code_convert_string_norecord (build_unibyte_string (documentation
),
411 Lisp_Object ret
= list4 (Qlambda
,
412 list2 (Qand_rest
, Qargs
),
414 list3 (Qinternal_module_call
,
418 return lisp_to_value (env
, ret
);
422 module_funcall (emacs_env
*env
, emacs_value fun
, ptrdiff_t nargs
,
425 MODULE_FUNCTION_BEGIN (NULL
);
427 /* Make a new Lisp_Object array starting with the function as the
428 first arg, because that's what Ffuncall takes. */
429 Lisp_Object
*newargs
;
431 SAFE_ALLOCA_LISP (newargs
, nargs
+ 1);
432 newargs
[0] = value_to_lisp (fun
);
433 for (ptrdiff_t i
= 0; i
< nargs
; i
++)
434 newargs
[1 + i
] = value_to_lisp (args
[i
]);
435 emacs_value result
= lisp_to_value (env
, Ffuncall (nargs
+ 1, newargs
));
441 module_intern (emacs_env
*env
, const char *name
)
443 MODULE_FUNCTION_BEGIN (NULL
);
444 return lisp_to_value (env
, intern (name
));
448 module_type_of (emacs_env
*env
, emacs_value value
)
450 MODULE_FUNCTION_BEGIN (NULL
);
451 return lisp_to_value (env
, Ftype_of (value_to_lisp (value
)));
455 module_is_not_nil (emacs_env
*env
, emacs_value value
)
457 check_main_thread ();
458 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
460 return ! NILP (value_to_lisp (value
));
464 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
466 check_main_thread ();
467 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
469 return EQ (value_to_lisp (a
), value_to_lisp (b
));
473 module_extract_integer (emacs_env
*env
, emacs_value n
)
475 MODULE_FUNCTION_BEGIN (0);
476 Lisp_Object l
= value_to_lisp (n
);
479 module_wrong_type (env
, Qintegerp
, l
);
486 module_make_integer (emacs_env
*env
, intmax_t n
)
488 MODULE_FUNCTION_BEGIN (NULL
);
489 if (! (MOST_NEGATIVE_FIXNUM
<= n
&& n
<= MOST_POSITIVE_FIXNUM
))
491 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
494 return lisp_to_value (env
, make_number (n
));
498 module_extract_float (emacs_env
*env
, emacs_value f
)
500 MODULE_FUNCTION_BEGIN (0);
501 Lisp_Object lisp
= value_to_lisp (f
);
504 module_wrong_type (env
, Qfloatp
, lisp
);
507 return XFLOAT_DATA (lisp
);
511 module_make_float (emacs_env
*env
, double d
)
513 MODULE_FUNCTION_BEGIN (NULL
);
514 return lisp_to_value (env
, make_float (d
));
518 module_copy_string_contents (emacs_env
*env
, emacs_value value
, char *buffer
,
521 MODULE_FUNCTION_BEGIN (false);
522 Lisp_Object lisp_str
= value_to_lisp (value
);
523 if (! STRINGP (lisp_str
))
525 module_wrong_type (env
, Qstringp
, lisp_str
);
529 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
530 ptrdiff_t raw_size
= SBYTES (lisp_str_utf8
);
531 if (raw_size
== PTRDIFF_MAX
)
533 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
536 ptrdiff_t required_buf_size
= raw_size
+ 1;
538 eassert (length
!= NULL
);
542 *length
= required_buf_size
;
546 eassert (*length
>= 0);
548 if (*length
< required_buf_size
)
550 *length
= required_buf_size
;
551 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, Qnil
);
555 *length
= required_buf_size
;
556 memcpy (buffer
, SDATA (lisp_str_utf8
), raw_size
+ 1);
562 module_make_string (emacs_env
*env
, const char *str
, ptrdiff_t length
)
564 MODULE_FUNCTION_BEGIN (NULL
);
565 if (length
> STRING_BYTES_BOUND
)
567 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
570 Lisp_Object lstr
= make_unibyte_string (str
, length
);
571 return lisp_to_value (env
,
572 code_convert_string_norecord (lstr
, Qutf_8
, false));
576 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
578 MODULE_FUNCTION_BEGIN (NULL
);
579 return lisp_to_value (env
, make_user_ptr (fin
, ptr
));
583 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
585 MODULE_FUNCTION_BEGIN (NULL
);
586 Lisp_Object lisp
= value_to_lisp (uptr
);
587 if (! USER_PTRP (lisp
))
589 module_wrong_type (env
, Quser_ptr
, lisp
);
592 return XUSER_PTR (lisp
)->p
;
596 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
598 // FIXME: This function should return bool because it can fail.
599 MODULE_FUNCTION_BEGIN ();
600 check_main_thread ();
601 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
603 Lisp_Object lisp
= value_to_lisp (uptr
);
604 if (! USER_PTRP (lisp
))
605 module_wrong_type (env
, Quser_ptr
, lisp
);
606 XUSER_PTR (lisp
)->p
= ptr
;
609 static emacs_finalizer_function
610 module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
612 MODULE_FUNCTION_BEGIN (NULL
);
613 Lisp_Object lisp
= value_to_lisp (uptr
);
614 if (! USER_PTRP (lisp
))
616 module_wrong_type (env
, Quser_ptr
, lisp
);
619 return XUSER_PTR (lisp
)->finalizer
;
623 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
624 emacs_finalizer_function fin
)
626 // FIXME: This function should return bool because it can fail.
627 MODULE_FUNCTION_BEGIN ();
628 Lisp_Object lisp
= value_to_lisp (uptr
);
629 if (! USER_PTRP (lisp
))
630 module_wrong_type (env
, Quser_ptr
, lisp
);
631 XUSER_PTR (lisp
)->finalizer
= fin
;
635 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
637 // FIXME: This function should return bool because it can fail.
638 MODULE_FUNCTION_BEGIN ();
639 Lisp_Object lvec
= value_to_lisp (vec
);
640 if (! VECTORP (lvec
))
642 module_wrong_type (env
, Qvectorp
, lvec
);
645 if (! (0 <= i
&& i
< ASIZE (lvec
)))
647 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
648 module_args_out_of_range (env
, lvec
, make_number (i
));
650 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
653 ASET (lvec
, i
, value_to_lisp (val
));
657 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
659 MODULE_FUNCTION_BEGIN (NULL
);
660 Lisp_Object lvec
= value_to_lisp (vec
);
661 if (! VECTORP (lvec
))
663 module_wrong_type (env
, Qvectorp
, lvec
);
666 if (! (0 <= i
&& i
< ASIZE (lvec
)))
668 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
669 module_args_out_of_range (env
, lvec
, make_number (i
));
671 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
674 return lisp_to_value (env
, AREF (lvec
, i
));
678 module_vec_size (emacs_env
*env
, emacs_value vec
)
680 // FIXME: Return a sentinel value (e.g., -1) on error.
681 MODULE_FUNCTION_BEGIN (0);
682 Lisp_Object lvec
= value_to_lisp (vec
);
683 if (! VECTORP (lvec
))
685 module_wrong_type (env
, Qvectorp
, lvec
);
694 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
695 doc
: /* Load module FILE. */)
698 dynlib_handle_ptr handle
;
699 emacs_init_function module_init
;
703 handle
= dynlib_open (SSDATA (file
));
705 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
707 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
709 error ("Module %s is not GPL compatible", SDATA (file
));
711 module_init
= (emacs_init_function
) dynlib_func (handle
, "emacs_module_init");
713 error ("Module %s does not have an init function.", SDATA (file
));
715 struct emacs_runtime_private rt
; /* Includes the public emacs_env. */
716 struct emacs_env_private priv
;
717 initialize_environment (&rt
.pub
, &priv
);
718 struct emacs_runtime pub
=
721 .private_members
= &rt
,
722 .get_environment
= module_get_environment
724 int r
= module_init (&pub
);
725 finalize_environment (&priv
);
729 if (! (MOST_NEGATIVE_FIXNUM
<= r
&& r
<= MOST_POSITIVE_FIXNUM
))
730 xsignal0 (Qoverflow_error
);
731 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
737 DEFUN ("internal--module-call", Finternal_module_call
, Sinternal_module_call
, 2, 2, 0,
738 doc
: /* Internal function to call a module function.
739 ENVOBJ is a save pointer to a module_fun_env structure.
740 ARGLIST is a list of arguments passed to SUBRPTR, or nil. */)
741 (Lisp_Object envobj
, Lisp_Object arglist
)
743 CHECK_TYPE (SAVE_VALUEP (envobj
), Qsave_value_p
, envobj
);
744 struct Lisp_Save_Value
*save_value
= XSAVE_VALUE (envobj
);
745 CHECK_TYPE (save_type (save_value
, 0) == SAVE_POINTER
, Qsave_pointer_p
, envobj
);
747 CHECK_CONS (arglist
);
748 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
749 EMACS_INT len
= XFASTINT (Flength (arglist
));
750 eassume (0 <= envptr
->min_arity
);
751 if (! (envptr
->min_arity
<= len
752 && len
<= (envptr
->max_arity
< 0 ? PTRDIFF_MAX
: envptr
->max_arity
)))
753 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
757 struct emacs_env_private priv
;
758 initialize_environment (&pub
, &priv
);
760 emacs_value
*args
= xnmalloc (len
, sizeof *args
);
762 for (ptrdiff_t i
= 0; i
< len
; i
++)
764 args
[i
] = lisp_to_value (&pub
, XCAR (arglist
));
766 memory_full (sizeof *args
[i
]);
767 arglist
= XCDR (arglist
);
770 emacs_value ret
= envptr
->subr (&pub
, len
, args
, envptr
->data
);
773 eassert (&priv
== pub
.private_members
);
775 switch (priv
.pending_non_local_exit
)
777 case emacs_funcall_exit_return
:
778 finalize_environment (&priv
);
780 xsignal1 (Qinvalid_module_call
, module_format_fun_env (envptr
));
781 return value_to_lisp (ret
);
782 case emacs_funcall_exit_signal
:
784 Lisp_Object symbol
= value_to_lisp (&priv
.non_local_exit_symbol
);
785 Lisp_Object data
= value_to_lisp (&priv
.non_local_exit_data
);
786 finalize_environment (&priv
);
787 xsignal (symbol
, data
);
789 case emacs_funcall_exit_throw
:
791 Lisp_Object tag
= value_to_lisp (&priv
.non_local_exit_symbol
);
792 Lisp_Object value
= value_to_lisp (&priv
.non_local_exit_data
);
793 finalize_environment (&priv
);
802 /* Helper functions. */
805 check_main_thread (void)
807 #ifdef HAVE_THREADS_H
808 eassert (thrd_equal (thdr_current (), main_thread
));
809 #elif defined HAVE_PTHREAD
810 eassert (pthread_equal (pthread_self (), main_thread
));
811 #elif defined WINDOWSNT
812 eassert (GetCurrentThreadId () == main_thread
);
817 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
820 struct emacs_env_private
*p
= env
->private_members
;
821 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
823 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
824 p
->non_local_exit_symbol
.v
= sym
;
825 p
->non_local_exit_data
.v
= data
;
830 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
833 struct emacs_env_private
*p
= env
->private_members
;
834 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
836 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
837 p
->non_local_exit_symbol
.v
= tag
;
838 p
->non_local_exit_data
.v
= value
;
842 /* Module version of `wrong_type_argument'. */
844 module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
)
846 module_non_local_exit_signal_1 (env
, Qwrong_type_argument
,
847 list2 (predicate
, value
));
850 /* Signal an out-of-memory condition to the caller. */
852 module_out_of_memory (emacs_env
*env
)
854 /* TODO: Reimplement this so it works even if memory-signal-data has
856 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
857 XCDR (Vmemory_signal_data
));
860 /* Signal arguments are out of range. */
862 module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
)
864 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, list2 (a1
, a2
));
868 /* Value conversion. */
870 /* Convert an `emacs_value' to the corresponding internal object.
873 value_to_lisp (emacs_value v
)
878 /* Convert an internal object to an `emacs_value'. Allocate storage
879 from the environment; return NULL if allocation fails. */
881 lisp_to_value (emacs_env
*env
, Lisp_Object o
)
883 struct emacs_env_private
*p
= env
->private_members
;
884 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
886 return allocate_emacs_value (env
, &p
->storage
, o
);
890 /* Memory management. */
892 /* Must be called for each frame before it can be used for allocation. */
894 initialize_frame (struct emacs_value_frame
*frame
)
900 /* Must be called for any storage object before it can be used for
903 initialize_storage (struct emacs_value_storage
*storage
)
905 initialize_frame (&storage
->initial
);
906 storage
->current
= &storage
->initial
;
909 /* Must be called for any initialized storage object before its
910 lifetime ends. Free all dynamically-allocated frames. */
912 finalize_storage (struct emacs_value_storage
*storage
)
914 struct emacs_value_frame
*next
= storage
->initial
.next
;
917 struct emacs_value_frame
*current
= next
;
918 next
= current
->next
;
923 /* Allocate a new value from STORAGE and stores OBJ in it. Return
924 NULL if allocation fails and use ENV for non local exit reporting. */
926 allocate_emacs_value (emacs_env
*env
, struct emacs_value_storage
*storage
,
929 eassert (storage
->current
);
930 eassert (storage
->current
->offset
< value_frame_size
);
931 eassert (! storage
->current
->next
);
932 if (storage
->current
->offset
== value_frame_size
- 1)
934 storage
->current
->next
= malloc (sizeof *storage
->current
->next
);
935 if (! storage
->current
->next
)
937 module_out_of_memory (env
);
940 initialize_frame (storage
->current
->next
);
941 storage
->current
= storage
->current
->next
;
943 emacs_value value
= storage
->current
->objects
+ storage
->current
->offset
;
945 ++storage
->current
->offset
;
949 /* Mark all objects allocated from local environments so that they
950 don't get garbage-collected. */
954 for (Lisp_Object tem
= Vmodule_environments
; CONSP (tem
); tem
= XCDR (tem
))
956 struct emacs_env_private
*priv
= XSAVE_POINTER (tem
, 0);
957 for (struct emacs_value_frame
*frame
= &priv
->storage
.initial
;
960 for (int i
= 0; i
< frame
->offset
; ++i
)
961 mark_object (frame
->objects
[i
].v
);
966 /* Environment lifetime management. */
968 /* Must be called before the environment can be used. */
970 initialize_environment (emacs_env
*env
, struct emacs_env_private
*priv
)
972 priv
->pending_non_local_exit
= emacs_funcall_exit_return
;
973 initialize_storage (&priv
->storage
);
974 env
->size
= sizeof *env
;
975 env
->private_members
= priv
;
976 env
->make_global_ref
= module_make_global_ref
;
977 env
->free_global_ref
= module_free_global_ref
;
978 env
->non_local_exit_check
= module_non_local_exit_check
;
979 env
->non_local_exit_clear
= module_non_local_exit_clear
;
980 env
->non_local_exit_get
= module_non_local_exit_get
;
981 env
->non_local_exit_signal
= module_non_local_exit_signal
;
982 env
->non_local_exit_throw
= module_non_local_exit_throw
;
983 env
->make_function
= module_make_function
;
984 env
->funcall
= module_funcall
;
985 env
->intern
= module_intern
;
986 env
->type_of
= module_type_of
;
987 env
->is_not_nil
= module_is_not_nil
;
989 env
->extract_integer
= module_extract_integer
;
990 env
->make_integer
= module_make_integer
;
991 env
->extract_float
= module_extract_float
;
992 env
->make_float
= module_make_float
;
993 env
->copy_string_contents
= module_copy_string_contents
;
994 env
->make_string
= module_make_string
;
995 env
->make_user_ptr
= module_make_user_ptr
;
996 env
->get_user_ptr
= module_get_user_ptr
;
997 env
->set_user_ptr
= module_set_user_ptr
;
998 env
->get_user_finalizer
= module_get_user_finalizer
;
999 env
->set_user_finalizer
= module_set_user_finalizer
;
1000 env
->vec_set
= module_vec_set
;
1001 env
->vec_get
= module_vec_get
;
1002 env
->vec_size
= module_vec_size
;
1003 Vmodule_environments
= Fcons (make_save_ptr (priv
), Vmodule_environments
);
1006 /* Must be called before the lifetime of the environment object
1009 finalize_environment (struct emacs_env_private
*env
)
1011 finalize_storage (&env
->storage
);
1012 Vmodule_environments
= XCDR (Vmodule_environments
);
1016 /* Non-local exit handling. */
1018 /* Must be called after setting up a handler immediately before
1019 returning from the function. See the comments in lisp.h and the
1020 code in eval.c for details. The macros below arrange for this
1021 function to be called automatically. DUMMY is ignored. */
1023 module_reset_handlerlist (const int *dummy
)
1025 handlerlist
= handlerlist
->next
;
1028 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
1029 stored in the environment. Set the pending non-local exit flag. */
1031 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
1033 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
1036 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
1037 stored in the environment. Set the pending non-local exit flag. */
1039 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
1041 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
1045 /* Function environments. */
1047 /* Return a string object that contains a user-friendly
1048 representation of the function environment. */
1050 module_format_fun_env (const struct module_fun_env
*env
)
1052 /* Try to print a function name if possible. */
1053 const char *path
, *sym
;
1054 static char const noaddr_format
[] = "#<module function at %p>";
1055 char buffer
[sizeof noaddr_format
+ INT_STRLEN_BOUND (intptr_t) + 256];
1057 ptrdiff_t bufsize
= sizeof buffer
;
1059 = (dynlib_addr (env
->subr
, &path
, &sym
)
1060 ? exprintf (&buf
, &bufsize
, buffer
, -1,
1061 "#<module function %s from %s>", sym
, path
)
1062 : sprintf (buffer
, noaddr_format
, env
->subr
));
1063 Lisp_Object unibyte_result
= make_unibyte_string (buffer
, size
);
1066 return code_convert_string_norecord (unibyte_result
, Qutf_8
, false);
1070 /* Segment initializer. */
1073 syms_of_module (void)
1075 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
1076 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
1077 doc
: /* Module global reference table. */);
1080 = make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
1081 make_float (DEFAULT_REHASH_SIZE
),
1082 make_float (DEFAULT_REHASH_THRESHOLD
),
1084 Funintern (Qmodule_refs_hash
, Qnil
);
1086 DEFSYM (Qmodule_environments
, "module-environments");
1087 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1088 doc
: /* List of active module environments. */);
1089 Vmodule_environments
= Qnil
;
1090 /* Unintern `module-environments' because it is only used
1092 Funintern (Qmodule_environments
, Qnil
);
1094 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1095 Fput (Qmodule_load_failed
, Qerror_conditions
,
1096 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1097 Fput (Qmodule_load_failed
, Qerror_message
,
1098 build_pure_c_string ("Module load failed"));
1100 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1101 Fput (Qinvalid_module_call
, Qerror_conditions
,
1102 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1103 Fput (Qinvalid_module_call
, Qerror_message
,
1104 build_pure_c_string ("Invalid module call"));
1106 DEFSYM (Qinvalid_arity
, "invalid-arity");
1107 Fput (Qinvalid_arity
, Qerror_conditions
,
1108 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1109 Fput (Qinvalid_arity
, Qerror_message
,
1110 build_pure_c_string ("Invalid function arity"));
1112 initialize_storage (&global_storage
);
1114 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1115 code or modules should not access it. */
1116 Funintern (Qmodule_refs_hash
, Qnil
);
1118 DEFSYM (Qsave_value_p
, "save-value-p");
1119 DEFSYM (Qsave_pointer_p
, "save-pointer-p");
1121 defsubr (&Smodule_load
);
1123 DEFSYM (Qinternal_module_call
, "internal--module-call");
1124 defsubr (&Sinternal_module_call
);
1127 /* Unlike syms_of_module, this initializer is called even from an
1128 initialized (dumped) Emacs. */
1133 /* It is not guaranteed that dynamic initializers run in the main thread,
1134 therefore detect the main thread here. */
1135 #ifdef HAVE_THREADS_H
1136 main_thread
= thrd_current ();
1137 #elif defined HAVE_PTHREAD
1138 main_thread
= pthread_self ();
1139 #elif defined WINDOWSNT
1140 /* The 'main' function already recorded the main thread's thread ID,
1141 so we need just to use it . */
1142 main_thread
= dwMainThreadId
;