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 /* 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.
195 The do-while forces uses of the macro to be followed by a semicolon.
196 This macro cannot enclose its entire body inside a do-while, as the
197 code after the macro may longjmp back into the macro, which means
198 its local variable C must stay live in later code. */
200 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
201 eassert (module_non_local_exit_check (env) == emacs_funcall_exit_return); \
202 struct handler *c = push_handler_nosignal (Qt, handlertype); \
205 module_out_of_memory (env); \
208 verify (module_has_cleanup); \
209 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
210 if (sys_setjmp (c->jmp)) \
212 (handlerfunc) (env, c->val); \
218 /* Function environments. */
220 /* A function environment is an auxiliary structure used by
221 `module_make_function' to store information about a module
222 function. It is stored in a save pointer and retrieved by
223 `module-call'. Its members correspond to the arguments given to
224 `module_make_function'. */
226 struct module_fun_env
228 ptrdiff_t min_arity
, max_arity
;
233 /* The function definition of `module-call'. `module-call' is
234 uninterned because user code couldn't meaningfully use it, so keep
235 its definition around somewhere else. */
236 static Lisp_Object module_call_func
;
239 /* Implementation of runtime and environment functions. */
241 /* Catch signals and throws only if the code can actually signal or
242 throw. If checking is enabled, abort if the current thread is not
243 the Emacs main thread. */
246 module_get_environment (struct emacs_runtime
*ert
)
248 check_main_thread ();
249 return &ert
->private_members
->environment
.pub
;
252 /* To make global refs (GC-protected global values) keep a hash that
253 maps global Lisp objects to reference counts. */
256 module_make_global_ref (emacs_env
*env
, emacs_value ref
)
258 check_main_thread ();
259 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
260 MODULE_HANDLE_SIGNALS
;
261 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
262 Lisp_Object new_obj
= value_to_lisp (ref
);
264 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
268 Lisp_Object value
= HASH_VALUE (h
, i
);
269 EMACS_INT refcount
= XFASTINT (value
) + 1;
270 if (refcount
> MOST_POSITIVE_FIXNUM
)
272 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
275 value
= make_natnum (refcount
);
276 set_hash_value_slot (h
, i
, value
);
280 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
283 return allocate_emacs_value (env
, &global_storage
, new_obj
);
287 module_free_global_ref (emacs_env
*env
, emacs_value ref
)
289 check_main_thread ();
290 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
291 /* TODO: This probably never signals. */
292 /* FIXME: Wait a minute. Shouldn't this function report an error if
293 the hash lookup fails? */
294 MODULE_HANDLE_SIGNALS_VOID
;
295 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
296 Lisp_Object obj
= value_to_lisp (ref
);
298 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
302 Lisp_Object value
= HASH_VALUE (h
, i
);
303 EMACS_INT refcount
= XFASTINT (value
) - 1;
306 value
= make_natnum (refcount
);
307 set_hash_value_slot (h
, i
, value
);
310 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
, ptrdiff_t min_arity
, ptrdiff_t 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 (! (0 <= min_arity
378 ? max_arity
== emacs_variadic_function
379 : min_arity
<= max_arity
)))
380 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
382 /* FIXME: This should be freed when envobj is GC'd. */
383 struct module_fun_env
*envptr
= xmalloc (sizeof *envptr
);
384 envptr
->min_arity
= min_arity
;
385 envptr
->max_arity
= max_arity
;
389 Lisp_Object envobj
= make_save_ptr (envptr
);
391 if (documentation
== NULL
)
395 ptrdiff_t nbytes
= strlen (documentation
);
396 doc
= make_unibyte_string (documentation
, nbytes
);
397 doc
= code_convert_string_norecord (doc
, Qutf_8
, false);
400 Lisp_Object ret
= list4 (Qlambda
,
401 list2 (Qand_rest
, Qargs
),
403 list3 (module_call_func
,
407 return lisp_to_value (env
, ret
);
411 module_funcall (emacs_env
*env
, emacs_value fun
, ptrdiff_t nargs
,
414 check_main_thread ();
415 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
416 MODULE_HANDLE_SIGNALS
;
419 /* Make a new Lisp_Object array starting with the function as the
420 first arg, because that's what Ffuncall takes. */
421 Lisp_Object
*newargs
;
423 SAFE_ALLOCA_LISP (newargs
, nargs
+ 1);
424 newargs
[0] = value_to_lisp (fun
);
425 for (ptrdiff_t i
= 0; i
< nargs
; i
++)
426 newargs
[1 + i
] = value_to_lisp (args
[i
]);
427 emacs_value result
= lisp_to_value (env
, Ffuncall (nargs
+ 1, newargs
));
433 module_intern (emacs_env
*env
, const char *name
)
435 check_main_thread ();
436 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
437 MODULE_HANDLE_SIGNALS
;
438 return lisp_to_value (env
, intern (name
));
442 module_type_of (emacs_env
*env
, emacs_value value
)
444 check_main_thread ();
445 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
446 return lisp_to_value (env
, Ftype_of (value_to_lisp (value
)));
450 module_is_not_nil (emacs_env
*env
, emacs_value value
)
452 check_main_thread ();
453 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
454 return ! NILP (value_to_lisp (value
));
458 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
460 check_main_thread ();
461 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
462 return EQ (value_to_lisp (a
), value_to_lisp (b
));
466 module_extract_integer (emacs_env
*env
, emacs_value n
)
468 check_main_thread ();
469 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
470 Lisp_Object l
= value_to_lisp (n
);
473 module_wrong_type (env
, Qintegerp
, l
);
480 module_make_integer (emacs_env
*env
, intmax_t n
)
482 check_main_thread ();
483 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
484 if (! (MOST_NEGATIVE_FIXNUM
<= n
&& n
<= MOST_POSITIVE_FIXNUM
))
486 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
489 return lisp_to_value (env
, make_number (n
));
493 module_extract_float (emacs_env
*env
, emacs_value f
)
495 check_main_thread ();
496 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
497 Lisp_Object lisp
= value_to_lisp (f
);
500 module_wrong_type (env
, Qfloatp
, lisp
);
503 return XFLOAT_DATA (lisp
);
507 module_make_float (emacs_env
*env
, double d
)
509 check_main_thread ();
510 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
511 MODULE_HANDLE_SIGNALS
;
512 return lisp_to_value (env
, make_float (d
));
516 module_copy_string_contents (emacs_env
*env
, emacs_value value
, char *buffer
,
519 check_main_thread ();
520 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
521 MODULE_HANDLE_SIGNALS
;
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 check_main_thread ();
565 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
566 MODULE_HANDLE_SIGNALS
;
567 if (length
> STRING_BYTES_BOUND
)
569 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
572 Lisp_Object lstr
= make_unibyte_string (str
, length
);
573 return lisp_to_value (env
,
574 code_convert_string_norecord (lstr
, Qutf_8
, false));
578 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
580 check_main_thread ();
581 return lisp_to_value (env
, make_user_ptr (fin
, ptr
));
585 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
587 check_main_thread ();
588 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
589 Lisp_Object lisp
= value_to_lisp (uptr
);
590 if (! USER_PTRP (lisp
))
592 module_wrong_type (env
, Quser_ptr
, lisp
);
595 return XUSER_PTR (lisp
)->p
;
599 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
601 check_main_thread ();
602 eassert (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 check_main_thread ();
613 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
614 Lisp_Object lisp
= value_to_lisp (uptr
);
615 if (! USER_PTRP (lisp
))
617 module_wrong_type (env
, Quser_ptr
, lisp
);
620 return XUSER_PTR (lisp
)->finalizer
;
624 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
625 emacs_finalizer_function fin
)
627 check_main_thread ();
628 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
629 Lisp_Object lisp
= value_to_lisp (uptr
);
630 if (! USER_PTRP (lisp
))
631 module_wrong_type (env
, Quser_ptr
, lisp
);
632 XUSER_PTR (lisp
)->finalizer
= fin
;
636 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
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 if (! (0 <= i
&& i
< ASIZE (lvec
)))
648 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
649 module_args_out_of_range (env
, lvec
, make_number (i
));
651 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
654 ASET (lvec
, i
, value_to_lisp (val
));
658 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
660 check_main_thread ();
661 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
662 Lisp_Object lvec
= value_to_lisp (vec
);
663 if (! VECTORP (lvec
))
665 module_wrong_type (env
, Qvectorp
, lvec
);
668 if (! (0 <= i
&& i
< ASIZE (lvec
)))
670 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
671 module_args_out_of_range (env
, lvec
, make_number (i
));
673 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
676 return lisp_to_value (env
, AREF (lvec
, i
));
680 module_vec_size (emacs_env
*env
, emacs_value vec
)
682 check_main_thread ();
683 eassert (module_non_local_exit_check (env
) == emacs_funcall_exit_return
);
684 Lisp_Object lvec
= value_to_lisp (vec
);
685 if (! VECTORP (lvec
))
687 module_wrong_type (env
, Qvectorp
, lvec
);
696 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
697 doc
: /* Load module FILE. */)
700 dynlib_handle_ptr handle
;
701 emacs_init_function module_init
;
705 handle
= dynlib_open (SSDATA (file
));
707 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
709 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
711 error ("Module %s is not GPL compatible", SDATA (file
));
713 module_init
= (emacs_init_function
) dynlib_sym (handle
, "emacs_module_init");
715 error ("Module %s does not have an init function.", SDATA (file
));
717 struct emacs_runtime_private priv
;
718 struct emacs_runtime pub
=
721 .private_members
= &priv
,
722 .get_environment
= module_get_environment
724 initialize_environment (&priv
.environment
);
725 int r
= module_init (&pub
);
726 finalize_environment (&priv
.environment
);
730 if (! (MOST_NEGATIVE_FIXNUM
<= r
&& r
<= MOST_POSITIVE_FIXNUM
))
731 xsignal0 (Qoverflow_error
);
732 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
738 DEFUN ("module-call", Fmodule_call
, Smodule_call
, 2, 2, 0,
739 doc
: /* Internal function to call a module function.
740 ENVOBJ is a save pointer to a module_fun_env structure.
741 ARGLIST is a list of arguments passed to SUBRPTR. */)
742 (Lisp_Object envobj
, Lisp_Object arglist
)
744 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
745 EMACS_INT len
= XFASTINT (Flength (arglist
));
746 eassume (0 <= envptr
->min_arity
);
747 if (! (envptr
->min_arity
<= len
748 && len
<= (envptr
->max_arity
< 0 ? PTRDIFF_MAX
: envptr
->max_arity
)))
749 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
752 struct env_storage env
;
753 initialize_environment (&env
);
755 emacs_value
*args
= xnmalloc (len
, sizeof *args
);
757 for (ptrdiff_t i
= 0; i
< len
; i
++)
759 args
[i
] = lisp_to_value (&env
.pub
, XCAR (arglist
));
761 memory_full (sizeof *args
[i
]);
762 arglist
= XCDR (arglist
);
765 emacs_value ret
= envptr
->subr (&env
.pub
, len
, args
, envptr
->data
);
768 switch (env
.priv
.pending_non_local_exit
)
770 case emacs_funcall_exit_return
:
771 finalize_environment (&env
);
773 xsignal1 (Qinvalid_module_call
, module_format_fun_env (envptr
));
774 return value_to_lisp (ret
);
775 case emacs_funcall_exit_signal
:
777 Lisp_Object symbol
= value_to_lisp (&env
.priv
.non_local_exit_symbol
);
778 Lisp_Object data
= value_to_lisp (&env
.priv
.non_local_exit_data
);
779 finalize_environment (&env
);
780 xsignal (symbol
, data
);
782 case emacs_funcall_exit_throw
:
784 Lisp_Object tag
= value_to_lisp (&env
.priv
.non_local_exit_symbol
);
785 Lisp_Object value
= value_to_lisp (&env
.priv
.non_local_exit_data
);
786 finalize_environment (&env
);
795 /* Helper functions. */
798 check_main_thread (void)
800 #ifdef HAVE_THREADS_H
801 eassert (thrd_equal (thdr_current (), main_thread
));
802 #elif defined HAVE_PTHREAD
803 eassert (pthread_equal (pthread_self (), main_thread
));
804 #elif defined WINDOWSNT
805 eassert (GetCurrentThreadId () == main_thread
);
810 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
813 struct emacs_env_private
*p
= env
->private_members
;
814 eassert (p
->pending_non_local_exit
== emacs_funcall_exit_return
);
815 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
816 p
->non_local_exit_symbol
.v
= sym
;
817 p
->non_local_exit_data
.v
= data
;
821 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
824 struct emacs_env_private
*p
= env
->private_members
;
825 eassert (p
->pending_non_local_exit
== emacs_funcall_exit_return
);
826 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
827 p
->non_local_exit_symbol
.v
= tag
;
828 p
->non_local_exit_data
.v
= value
;
831 /* Module version of `wrong_type_argument'. */
833 module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
)
835 module_non_local_exit_signal_1 (env
, Qwrong_type_argument
,
836 list2 (predicate
, value
));
839 /* Signal an out-of-memory condition to the caller. */
841 module_out_of_memory (emacs_env
*env
)
843 /* TODO: Reimplement this so it works even if memory-signal-data has
845 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
846 XCDR (Vmemory_signal_data
));
849 /* Signal arguments are out of range. */
851 module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
)
853 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, list2 (a1
, a2
));
857 /* Value conversion. */
859 /* Convert an `emacs_value' to the corresponding internal object.
862 value_to_lisp (emacs_value v
)
867 /* Convert an internal object to an `emacs_value'. Allocate storage
868 from the environment; return NULL if allocation fails. */
870 lisp_to_value (emacs_env
*env
, Lisp_Object o
)
872 struct emacs_env_private
*p
= env
->private_members
;
873 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
875 return allocate_emacs_value (env
, &p
->storage
, o
);
879 /* Memory management. */
881 /* Must be called for each frame before it can be used for allocation. */
883 initialize_frame (struct emacs_value_frame
*frame
)
889 /* Must be called for any storage object before it can be used for
892 initialize_storage (struct emacs_value_storage
*storage
)
894 initialize_frame (&storage
->initial
);
895 storage
->current
= &storage
->initial
;
898 /* Must be called for any initialized storage object before its
899 lifetime ends. Free all dynamically-allocated frames. */
901 finalize_storage (struct emacs_value_storage
*storage
)
903 struct emacs_value_frame
*next
= storage
->initial
.next
;
906 struct emacs_value_frame
*current
= next
;
907 next
= current
->next
;
912 /* Allocate a new value from STORAGE and stores OBJ in it. Return
913 NULL if allocation fails and use ENV for non local exit reporting. */
915 allocate_emacs_value (emacs_env
*env
, struct emacs_value_storage
*storage
,
918 eassert (storage
->current
);
919 eassert (storage
->current
->offset
< value_frame_size
);
920 eassert (! storage
->current
->next
);
921 if (storage
->current
->offset
== value_frame_size
- 1)
923 storage
->current
->next
= malloc (sizeof *storage
->current
->next
);
924 if (! storage
->current
->next
)
926 module_out_of_memory (env
);
929 initialize_frame (storage
->current
->next
);
930 storage
->current
= storage
->current
->next
;
932 emacs_value value
= storage
->current
->objects
+ storage
->current
->offset
;
934 ++storage
->current
->offset
;
938 /* Mark all objects allocated from local environments so that they
939 don't get garbage-collected. */
940 void mark_modules (void)
942 for (Lisp_Object tem
= Vmodule_environments
; CONSP (tem
); tem
= XCDR (tem
))
944 struct env_storage
*env
= XSAVE_POINTER (tem
, 0);
945 for (struct emacs_value_frame
*frame
= &env
->priv
.storage
.initial
;
948 for (int i
= 0; i
< frame
->offset
; ++i
)
949 mark_object (frame
->objects
[i
].v
);
954 /* Environment lifetime management. */
956 /* Must be called before the environment can be used. */
958 initialize_environment (struct env_storage
*env
)
960 env
->priv
.pending_non_local_exit
= emacs_funcall_exit_return
;
961 initialize_storage (&env
->priv
.storage
);
962 env
->pub
.size
= sizeof env
->pub
;
963 env
->pub
.private_members
= &env
->priv
;
964 env
->pub
.make_global_ref
= module_make_global_ref
;
965 env
->pub
.free_global_ref
= module_free_global_ref
;
966 env
->pub
.non_local_exit_check
= module_non_local_exit_check
;
967 env
->pub
.non_local_exit_clear
= module_non_local_exit_clear
;
968 env
->pub
.non_local_exit_get
= module_non_local_exit_get
;
969 env
->pub
.non_local_exit_signal
= module_non_local_exit_signal
;
970 env
->pub
.non_local_exit_throw
= module_non_local_exit_throw
;
971 env
->pub
.make_function
= module_make_function
;
972 env
->pub
.funcall
= module_funcall
;
973 env
->pub
.intern
= module_intern
;
974 env
->pub
.type_of
= module_type_of
;
975 env
->pub
.is_not_nil
= module_is_not_nil
;
976 env
->pub
.eq
= module_eq
;
977 env
->pub
.extract_integer
= module_extract_integer
;
978 env
->pub
.make_integer
= module_make_integer
;
979 env
->pub
.extract_float
= module_extract_float
;
980 env
->pub
.make_float
= module_make_float
;
981 env
->pub
.copy_string_contents
= module_copy_string_contents
;
982 env
->pub
.make_string
= module_make_string
;
983 env
->pub
.make_user_ptr
= module_make_user_ptr
;
984 env
->pub
.get_user_ptr
= module_get_user_ptr
;
985 env
->pub
.set_user_ptr
= module_set_user_ptr
;
986 env
->pub
.get_user_finalizer
= module_get_user_finalizer
;
987 env
->pub
.set_user_finalizer
= module_set_user_finalizer
;
988 env
->pub
.vec_set
= module_vec_set
;
989 env
->pub
.vec_get
= module_vec_get
;
990 env
->pub
.vec_size
= module_vec_size
;
991 Vmodule_environments
= Fcons (make_save_ptr (env
), Vmodule_environments
);
994 /* Must be called before the lifetime of the environment object
997 finalize_environment (struct env_storage
*env
)
999 finalize_storage (&env
->priv
.storage
);
1000 Vmodule_environments
= XCDR (Vmodule_environments
);
1004 /* Non-local exit handling. */
1006 /* Must be called after setting up a handler immediately before
1007 returning from the function. See the comments in lisp.h and the
1008 code in eval.c for details. The macros below arrange for this
1009 function to be called automatically. DUMMY is ignored. */
1011 module_reset_handlerlist (const int *dummy
)
1013 handlerlist
= handlerlist
->next
;
1016 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
1017 stored in the environment. Set the pending non-local exit flag. */
1019 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
1021 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
1024 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
1025 stored in the environment. Set the pending non-local exit flag. */
1027 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
1029 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
1033 /* Function environments. */
1035 /* Return a string object that contains a user-friendly
1036 representation of the function environment. */
1038 module_format_fun_env (const struct module_fun_env
*env
)
1040 /* Try to print a function name if possible. */
1041 const char *path
, *sym
;
1044 ptrdiff_t bufsize
= sizeof buffer
;
1046 = (dynlib_addr (env
->subr
, &path
, &sym
)
1047 ? exprintf (&buf
, &bufsize
, buffer
, -1,
1048 "#<module function %s from %s>", sym
, path
)
1049 : exprintf (&buf
, &bufsize
, buffer
, -1,
1050 "#<module function at %p>", env
->subr
));
1051 Lisp_Object unibyte_result
= make_unibyte_string (buffer
, size
);
1054 return code_convert_string_norecord (unibyte_result
, Qutf_8
, false);
1058 /* Segment initializer. */
1061 syms_of_module (void)
1063 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
1064 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
1065 doc
: /* Module global referrence table. */);
1068 = make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
1069 make_float (DEFAULT_REHASH_SIZE
),
1070 make_float (DEFAULT_REHASH_THRESHOLD
),
1072 Funintern (Qmodule_refs_hash
, Qnil
);
1074 DEFSYM (Qmodule_environments
, "module-environments");
1075 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1076 doc
: /* List of active module environments. */);
1077 Vmodule_environments
= Qnil
;
1078 /* Unintern `module-environments' because it is only used
1080 Funintern (Qmodule_environments
, Qnil
);
1082 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1083 Fput (Qmodule_load_failed
, Qerror_conditions
,
1084 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1085 Fput (Qmodule_load_failed
, Qerror_message
,
1086 build_pure_c_string ("Module load failed"));
1088 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1089 Fput (Qinvalid_module_call
, Qerror_conditions
,
1090 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1091 Fput (Qinvalid_module_call
, Qerror_message
,
1092 build_pure_c_string ("Invalid module call"));
1094 DEFSYM (Qinvalid_arity
, "invalid-arity");
1095 Fput (Qinvalid_arity
, Qerror_conditions
,
1096 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1097 Fput (Qinvalid_arity
, Qerror_message
,
1098 build_pure_c_string ("Invalid function arity"));
1100 initialize_storage (&global_storage
);
1102 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1103 code or modules should not access it. */
1104 Funintern (Qmodule_refs_hash
, Qnil
);
1106 defsubr (&Smodule_load
);
1108 /* Don't call defsubr on `module-call' because that would intern it,
1109 but `module-call' is an internal function that users cannot
1110 meaningfully use. Instead, assign its definition to a private
1112 XSETPVECTYPE (&Smodule_call
, PVEC_SUBR
);
1113 XSETSUBR (module_call_func
, &Smodule_call
);
1116 /* Unlike syms_of_module, this initializer is called even from an
1117 initialized (dumped) Emacs. */
1122 /* It is not guaranteed that dynamic initializers run in the main thread,
1123 therefore detect the main thread here. */
1124 #ifdef HAVE_THREADS_H
1125 main_thread
= thrd_current ();
1126 #elif defined HAVE_PTHREAD
1127 main_thread
= pthread_self ();
1128 #elif defined WINDOWSNT
1129 /* The 'main' function already recorded the main thread's thread ID,
1130 so we need just to use it . */
1131 main_thread
= dwMainThreadId
;