1 /* emacs-module.c - Module loading and runtime implementation
3 Copyright (C) 2015-2016 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 pthread_t main_thread
;
50 #elif defined WINDOWSNT
53 static DWORD main_thread
;
56 /* True if Lisp_Object and emacs_value have the same representation.
57 This is typically true unless WIDE_EMACS_INT. In practice, having
58 the same sizes and alignments and maximums should be a good enough
59 proxy for equality of representation. */
63 = (sizeof (Lisp_Object
) == sizeof (emacs_value
)
64 && alignof (Lisp_Object
) == alignof (emacs_value
)
65 && INTPTR_MAX
== EMACS_INT_MAX
)
69 /* Private runtime and environment members. */
71 /* The private part of an environment stores the current non local exit state
72 and holds the `emacs_value' objects allocated during the lifetime
73 of the environment. */
74 struct emacs_env_private
76 enum emacs_funcall_exit pending_non_local_exit
;
78 /* Dedicated storage for non-local exit symbol and data so that
79 storage is always available for them, even in an out-of-memory
81 Lisp_Object non_local_exit_symbol
, non_local_exit_data
;
84 /* The private parts of an `emacs_runtime' object contain the initial
86 struct emacs_runtime_private
88 /* FIXME: Ideally, we would just define "struct emacs_runtime_private"
89 as a synonym of "emacs_env", but I don't know how to do that in C. */
94 /* Forward declarations. */
96 struct module_fun_env
;
98 static Lisp_Object
module_format_fun_env (const struct module_fun_env
*);
99 static Lisp_Object
value_to_lisp (emacs_value
);
100 static emacs_value
lisp_to_value (Lisp_Object
);
101 static enum emacs_funcall_exit
module_non_local_exit_check (emacs_env
*);
102 static void check_main_thread (void);
103 static void finalize_environment (struct emacs_env_private
*);
104 static void initialize_environment (emacs_env
*, struct emacs_env_private
*priv
);
105 static void module_args_out_of_range (emacs_env
*, Lisp_Object
, Lisp_Object
);
106 static void module_handle_signal (emacs_env
*, Lisp_Object
);
107 static void module_handle_throw (emacs_env
*, Lisp_Object
);
108 static void module_non_local_exit_signal_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
109 static void module_non_local_exit_throw_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
110 static void module_out_of_memory (emacs_env
*);
111 static void module_reset_handlerlist (const int *);
112 static void module_wrong_type (emacs_env
*, Lisp_Object
, Lisp_Object
);
114 /* We used to return NULL when emacs_value was a different type from
115 Lisp_Object, but nowadays we just use Qnil instead. Although they
116 happen to be the same thing in the current implementation, module
117 code should not assume this. */
118 verify (NIL_IS_ZERO
);
119 static emacs_value
const module_nil
= 0;
121 /* Convenience macros for non-local exit handling. */
123 /* FIXME: The following implementation for non-local exit handling
124 does not support recovery from stack overflow, see sysdep.c. */
126 /* Emacs uses setjmp and longjmp for non-local exits, but
127 module frames cannot be skipped because they are in general
128 not prepared for long jumps (e.g., the behavior in C++ is undefined
129 if objects with nontrivial destructors would be skipped).
130 Therefore, catch all non-local exits. There are two kinds of
131 non-local exits: `signal' and `throw'. The macros in this section
132 can be used to catch both. Use macros to avoid additional variants
133 of `internal_condition_case' etc., and to avoid worrying about
134 passing information to the handler functions. */
136 /* Place this macro at the beginning of a function returning a number
137 or a pointer to handle non-local exits. The function must have an
138 ENV parameter. The function will return the specified value if a
139 signal or throw is caught. */
140 // TODO: Have Fsignal check for CATCHER_ALL so we only have to install
142 #define MODULE_HANDLE_NONLOCAL_EXIT(retval) \
143 MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval); \
144 MODULE_SETJMP (CATCHER_ALL, module_handle_throw, retval)
146 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
147 MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \
148 internal_handler_##handlertype, \
149 internal_cleanup_##handlertype)
151 /* It is very important that pushing the handler doesn't itself raise
152 a signal. Install the cleanup only after the handler has been
153 pushed. Use __attribute__ ((cleanup)) to avoid
154 non-local-exit-prone manual cleanup.
156 The do-while forces uses of the macro to be followed by a semicolon.
157 This macro cannot enclose its entire body inside a do-while, as the
158 code after the macro may longjmp back into the macro, which means
159 its local variable C must stay live in later code. */
161 // TODO: Make backtraces work if this macros is used.
163 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
164 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
166 struct handler *c = push_handler_nosignal (Qt, handlertype); \
169 module_out_of_memory (env); \
172 verify (module_has_cleanup); \
173 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
174 if (sys_setjmp (c->jmp)) \
176 (handlerfunc) (env, c->val); \
182 /* Function environments. */
184 /* A function environment is an auxiliary structure used by
185 `module_make_function' to store information about a module
186 function. It is stored in a save pointer and retrieved by
187 `internal--module-call'. Its members correspond to the arguments
188 given to `module_make_function'. */
190 struct module_fun_env
192 ptrdiff_t min_arity
, max_arity
;
198 /* Implementation of runtime and environment functions.
200 These should abide by the following rules:
202 1. The first argument should always be a pointer to emacs_env.
204 2. Each function should first call check_main_thread. Note that
205 this function is a no-op unless Emacs was built with
208 3. The very next thing each function should do is check that the
209 emacs_env object does not have a non-local exit indication set,
210 by calling module_non_local_exit_check. If that returns
211 anything but emacs_funcall_exit_return, the function should do
212 nothing and return immediately with an error indication, without
213 clobbering the existing error indication in emacs_env. This is
214 needed for correct reporting of Lisp errors to the Emacs Lisp
217 4. Any function that needs to call Emacs facilities, such as
218 encoding or decoding functions, or 'intern', or 'make_string',
219 should protect itself from signals and 'throw' in the called
220 Emacs functions, by placing the macro
221 MODULE_HANDLE_NONLOCAL_EXIT right after the above 2 tests.
223 5. Do NOT use 'eassert' for checking validity of user code in the
224 module. Instead, make those checks part of the code, and if the
225 check fails, call 'module_non_local_exit_signal_1' or
226 'module_non_local_exit_throw_1' to report the error. This is
227 because using 'eassert' in these situations will abort Emacs
228 instead of reporting the error back to Lisp, and also because
229 'eassert' is compiled to nothing in the release version. */
231 /* Use MODULE_FUNCTION_BEGIN to implement steps 2 through 4 for most
232 environment functions. On error it will return its argument, which
233 should be a sentinel value. */
235 #define MODULE_FUNCTION_BEGIN(error_retval) \
236 check_main_thread (); \
237 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
238 return error_retval; \
239 MODULE_HANDLE_NONLOCAL_EXIT (error_retval)
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
->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 MODULE_FUNCTION_BEGIN (module_nil
);
259 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
260 Lisp_Object new_obj
= value_to_lisp (ref
);
262 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
266 Lisp_Object value
= HASH_VALUE (h
, i
);
267 EMACS_INT refcount
= XFASTINT (value
) + 1;
268 if (refcount
> MOST_POSITIVE_FIXNUM
)
270 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
273 value
= make_natnum (refcount
);
274 set_hash_value_slot (h
, i
, value
);
278 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
281 return lisp_to_value (new_obj
);
285 module_free_global_ref (emacs_env
*env
, emacs_value ref
)
287 /* TODO: This probably never signals. */
288 /* FIXME: Wait a minute. Shouldn't this function report an error if
289 the hash lookup fails? */
290 MODULE_FUNCTION_BEGIN ();
291 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
292 Lisp_Object obj
= value_to_lisp (ref
);
294 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
298 Lisp_Object value
= HASH_VALUE (h
, i
);
299 EMACS_INT refcount
= XFASTINT (value
) - 1;
302 value
= make_natnum (refcount
);
303 set_hash_value_slot (h
, i
, value
);
306 hash_remove_from_table (h
, value
);
310 static enum emacs_funcall_exit
311 module_non_local_exit_check (emacs_env
*env
)
313 check_main_thread ();
314 return env
->private_members
->pending_non_local_exit
;
318 module_non_local_exit_clear (emacs_env
*env
)
320 check_main_thread ();
321 env
->private_members
->pending_non_local_exit
= emacs_funcall_exit_return
;
324 static enum emacs_funcall_exit
325 module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
)
327 check_main_thread ();
328 struct emacs_env_private
*p
= env
->private_members
;
329 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
331 /* FIXME: lisp_to_value can exit non-locally. */
332 *sym
= lisp_to_value (p
->non_local_exit_symbol
);
333 *data
= lisp_to_value (p
->non_local_exit_data
);
335 return p
->pending_non_local_exit
;
338 /* Like for `signal', DATA must be a list. */
340 module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
)
342 check_main_thread ();
343 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
344 module_non_local_exit_signal_1 (env
, value_to_lisp (sym
),
345 value_to_lisp (data
));
349 module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
)
351 check_main_thread ();
352 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
353 module_non_local_exit_throw_1 (env
, value_to_lisp (tag
),
354 value_to_lisp (value
));
357 /* A module function is lambda function that calls
358 `internal--module-call', passing the function pointer of the module
359 function along with the module emacs_env pointer as arguments.
361 (function (lambda (&rest arglist)
362 (internal--module-call envobj arglist))) */
365 module_make_function (emacs_env
*env
, ptrdiff_t min_arity
, ptrdiff_t max_arity
,
366 emacs_subr subr
, const char *documentation
,
369 MODULE_FUNCTION_BEGIN (module_nil
);
371 if (! (0 <= min_arity
373 ? max_arity
== emacs_variadic_function
374 : min_arity
<= max_arity
)))
375 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
377 /* FIXME: This should be freed when envobj is GC'd. */
378 struct module_fun_env
*envptr
= xmalloc (sizeof *envptr
);
379 envptr
->min_arity
= min_arity
;
380 envptr
->max_arity
= max_arity
;
384 Lisp_Object envobj
= make_save_ptr (envptr
);
387 ? code_convert_string_norecord (build_unibyte_string (documentation
),
390 /* FIXME: Use a bytecompiled object, or even better a subr. */
391 Lisp_Object ret
= list4 (Qlambda
,
392 list2 (Qand_rest
, Qargs
),
395 list2 (Qfunction
, Qinternal_module_call
),
399 return lisp_to_value (ret
);
403 module_funcall (emacs_env
*env
, emacs_value fun
, ptrdiff_t nargs
,
406 MODULE_FUNCTION_BEGIN (module_nil
);
408 /* Make a new Lisp_Object array starting with the function as the
409 first arg, because that's what Ffuncall takes. */
410 Lisp_Object
*newargs
;
412 SAFE_ALLOCA_LISP (newargs
, nargs
+ 1);
413 newargs
[0] = value_to_lisp (fun
);
414 for (ptrdiff_t i
= 0; i
< nargs
; i
++)
415 newargs
[1 + i
] = value_to_lisp (args
[i
]);
416 emacs_value result
= lisp_to_value (Ffuncall (nargs
+ 1, newargs
));
422 module_intern (emacs_env
*env
, const char *name
)
424 MODULE_FUNCTION_BEGIN (module_nil
);
425 return lisp_to_value (intern (name
));
429 module_type_of (emacs_env
*env
, emacs_value value
)
431 MODULE_FUNCTION_BEGIN (module_nil
);
432 return lisp_to_value (Ftype_of (value_to_lisp (value
)));
436 module_is_not_nil (emacs_env
*env
, emacs_value value
)
438 check_main_thread ();
439 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
441 return ! NILP (value_to_lisp (value
));
445 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
447 check_main_thread ();
448 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
450 return EQ (value_to_lisp (a
), value_to_lisp (b
));
454 module_extract_integer (emacs_env
*env
, emacs_value n
)
456 MODULE_FUNCTION_BEGIN (0);
457 Lisp_Object l
= value_to_lisp (n
);
460 module_wrong_type (env
, Qintegerp
, l
);
467 module_make_integer (emacs_env
*env
, intmax_t n
)
469 MODULE_FUNCTION_BEGIN (module_nil
);
470 if (! (MOST_NEGATIVE_FIXNUM
<= n
&& n
<= MOST_POSITIVE_FIXNUM
))
472 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
475 return lisp_to_value (make_number (n
));
479 module_extract_float (emacs_env
*env
, emacs_value f
)
481 MODULE_FUNCTION_BEGIN (0);
482 Lisp_Object lisp
= value_to_lisp (f
);
485 module_wrong_type (env
, Qfloatp
, lisp
);
488 return XFLOAT_DATA (lisp
);
492 module_make_float (emacs_env
*env
, double d
)
494 MODULE_FUNCTION_BEGIN (module_nil
);
495 return lisp_to_value (make_float (d
));
499 module_copy_string_contents (emacs_env
*env
, emacs_value value
, char *buffer
,
502 MODULE_FUNCTION_BEGIN (false);
503 Lisp_Object lisp_str
= value_to_lisp (value
);
504 if (! STRINGP (lisp_str
))
506 module_wrong_type (env
, Qstringp
, lisp_str
);
510 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
511 ptrdiff_t raw_size
= SBYTES (lisp_str_utf8
);
512 if (raw_size
== PTRDIFF_MAX
)
514 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
517 ptrdiff_t required_buf_size
= raw_size
+ 1;
519 eassert (length
!= NULL
);
523 *length
= required_buf_size
;
527 eassert (*length
>= 0);
529 if (*length
< required_buf_size
)
531 *length
= required_buf_size
;
532 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, Qnil
);
536 *length
= required_buf_size
;
537 memcpy (buffer
, SDATA (lisp_str_utf8
), raw_size
+ 1);
543 module_make_string (emacs_env
*env
, const char *str
, ptrdiff_t length
)
545 MODULE_FUNCTION_BEGIN (module_nil
);
546 if (length
> STRING_BYTES_BOUND
)
548 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
551 Lisp_Object lstr
= make_unibyte_string (str
, length
);
552 return lisp_to_value (code_convert_string_norecord (lstr
, Qutf_8
, false));
556 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
558 MODULE_FUNCTION_BEGIN (module_nil
);
559 return lisp_to_value (make_user_ptr (fin
, ptr
));
563 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
565 MODULE_FUNCTION_BEGIN (NULL
);
566 Lisp_Object lisp
= value_to_lisp (uptr
);
567 if (! USER_PTRP (lisp
))
569 module_wrong_type (env
, Quser_ptr
, lisp
);
572 return XUSER_PTR (lisp
)->p
;
576 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
578 /* FIXME: This function should return bool because it can fail. */
579 MODULE_FUNCTION_BEGIN ();
580 check_main_thread ();
581 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
583 Lisp_Object lisp
= value_to_lisp (uptr
);
584 if (! USER_PTRP (lisp
))
585 module_wrong_type (env
, Quser_ptr
, lisp
);
586 XUSER_PTR (lisp
)->p
= ptr
;
589 static emacs_finalizer_function
590 module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
592 MODULE_FUNCTION_BEGIN (NULL
);
593 Lisp_Object lisp
= value_to_lisp (uptr
);
594 if (! USER_PTRP (lisp
))
596 module_wrong_type (env
, Quser_ptr
, lisp
);
599 return XUSER_PTR (lisp
)->finalizer
;
603 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
604 emacs_finalizer_function fin
)
606 /* FIXME: This function should return bool because it can fail. */
607 MODULE_FUNCTION_BEGIN ();
608 Lisp_Object lisp
= value_to_lisp (uptr
);
609 if (! USER_PTRP (lisp
))
610 module_wrong_type (env
, Quser_ptr
, lisp
);
611 XUSER_PTR (lisp
)->finalizer
= fin
;
615 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
617 /* FIXME: This function should return bool because it can fail. */
618 MODULE_FUNCTION_BEGIN ();
619 Lisp_Object lvec
= value_to_lisp (vec
);
620 if (! VECTORP (lvec
))
622 module_wrong_type (env
, Qvectorp
, lvec
);
625 if (! (0 <= i
&& i
< ASIZE (lvec
)))
627 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
628 module_args_out_of_range (env
, lvec
, make_number (i
));
630 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
633 ASET (lvec
, i
, value_to_lisp (val
));
637 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
639 MODULE_FUNCTION_BEGIN (module_nil
);
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 return lisp_to_value (AREF (lvec
, i
));
658 module_vec_size (emacs_env
*env
, emacs_value vec
)
660 /* FIXME: Return a sentinel value (e.g., -1) on error. */
661 MODULE_FUNCTION_BEGIN (0);
662 Lisp_Object lvec
= value_to_lisp (vec
);
663 if (! VECTORP (lvec
))
665 module_wrong_type (env
, Qvectorp
, lvec
);
674 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
675 doc
: /* Load module FILE. */)
678 dynlib_handle_ptr handle
;
679 emacs_init_function module_init
;
683 handle
= dynlib_open (SSDATA (file
));
685 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
687 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
689 error ("Module %s is not GPL compatible", SDATA (file
));
691 module_init
= (emacs_init_function
) dynlib_func (handle
, "emacs_module_init");
693 error ("Module %s does not have an init function.", SDATA (file
));
695 struct emacs_runtime_private rt
; /* Includes the public emacs_env. */
696 struct emacs_env_private priv
;
697 initialize_environment (&rt
.pub
, &priv
);
698 struct emacs_runtime pub
=
701 .private_members
= &rt
,
702 .get_environment
= module_get_environment
704 int r
= module_init (&pub
);
705 finalize_environment (&priv
);
709 if (! (MOST_NEGATIVE_FIXNUM
<= r
&& r
<= MOST_POSITIVE_FIXNUM
))
710 xsignal0 (Qoverflow_error
);
711 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
717 DEFUN ("internal--module-call", Finternal_module_call
, Sinternal_module_call
, 1, MANY
, 0,
718 doc
: /* Internal function to call a module function.
719 ENVOBJ is a save pointer to a module_fun_env structure.
720 ARGLIST is a list of arguments passed to SUBRPTR.
721 usage: (module-call ENVOBJ &rest ARGLIST) */)
722 (ptrdiff_t nargs
, Lisp_Object
*arglist
)
724 Lisp_Object envobj
= arglist
[0];
725 /* FIXME: Rather than use a save_value, we should create a new object type.
726 Making save_value visible to Lisp is wrong. */
727 CHECK_TYPE (SAVE_VALUEP (envobj
), Qsave_value_p
, envobj
);
728 struct Lisp_Save_Value
*save_value
= XSAVE_VALUE (envobj
);
729 CHECK_TYPE (save_type (save_value
, 0) == SAVE_POINTER
, Qsave_pointer_p
, envobj
);
730 /* FIXME: We have no reason to believe that XSAVE_POINTER (envobj, 0)
731 is a module_fun_env pointer. If some other part of Emacs also
732 exports save_value objects to Elisp, than we may be getting here this
733 other kind of save_value which will likely hold something completely
734 different in this field. */
735 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
736 EMACS_INT len
= nargs
- 1;
737 eassume (0 <= envptr
->min_arity
);
738 if (! (envptr
->min_arity
<= len
739 && len
<= (envptr
->max_arity
< 0 ? PTRDIFF_MAX
: envptr
->max_arity
)))
740 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
744 struct emacs_env_private priv
;
745 initialize_environment (&pub
, &priv
);
750 args
= (emacs_value
*) arglist
+ 1;
753 args
= SAFE_ALLOCA (len
* sizeof *args
);
754 for (ptrdiff_t i
= 0; i
< len
; i
++)
755 args
[i
] = lisp_to_value (arglist
[i
+ 1]);
758 emacs_value ret
= envptr
->subr (&pub
, len
, args
, envptr
->data
);
761 eassert (&priv
== pub
.private_members
);
763 switch (priv
.pending_non_local_exit
)
765 case emacs_funcall_exit_return
:
766 finalize_environment (&priv
);
767 return value_to_lisp (ret
);
768 case emacs_funcall_exit_signal
:
770 Lisp_Object symbol
= priv
.non_local_exit_symbol
;
771 Lisp_Object data
= priv
.non_local_exit_data
;
772 finalize_environment (&priv
);
773 xsignal (symbol
, data
);
775 case emacs_funcall_exit_throw
:
777 Lisp_Object tag
= priv
.non_local_exit_symbol
;
778 Lisp_Object value
= priv
.non_local_exit_data
;
779 finalize_environment (&priv
);
788 /* Helper functions. */
791 check_main_thread (void)
794 eassert (pthread_equal (pthread_self (), main_thread
));
795 #elif defined WINDOWSNT
796 eassert (GetCurrentThreadId () == main_thread
);
801 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
804 struct emacs_env_private
*p
= env
->private_members
;
805 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
807 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
808 p
->non_local_exit_symbol
= sym
;
809 p
->non_local_exit_data
= data
;
814 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
817 struct emacs_env_private
*p
= env
->private_members
;
818 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
820 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
821 p
->non_local_exit_symbol
= tag
;
822 p
->non_local_exit_data
= value
;
826 /* Module version of `wrong_type_argument'. */
828 module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
)
830 module_non_local_exit_signal_1 (env
, Qwrong_type_argument
,
831 list2 (predicate
, value
));
834 /* Signal an out-of-memory condition to the caller. */
836 module_out_of_memory (emacs_env
*env
)
838 /* TODO: Reimplement this so it works even if memory-signal-data has
840 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
841 XCDR (Vmemory_signal_data
));
844 /* Signal arguments are out of range. */
846 module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
)
848 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, list2 (a1
, a2
));
852 /* Value conversion. */
854 /* Unique Lisp_Object used to mark those emacs_values which are really
855 just containers holding a Lisp_Object that does not fit as an emacs_value,
856 either because it is an integer out of range, or is not properly aligned.
857 Used only if !plain_values. */
858 static Lisp_Object ltv_mark
;
860 /* Convert V to the corresponding internal object O, such that
861 V == lisp_to_value_bits (O). Never fails. */
863 value_to_lisp_bits (emacs_value v
)
865 intptr_t i
= (intptr_t) v
;
866 if (plain_values
|| USE_LSB_TAG
)
869 /* With wide EMACS_INT and when tag bits are the most significant,
870 reassembling integers differs from reassembling pointers in two
871 ways. First, save and restore the least-significant bits of the
872 integer, not the most-significant bits. Second, sign-extend the
873 integer when restoring, but zero-extend pointers because that
874 makes TAG_PTR faster. */
876 EMACS_UINT tag
= i
& (GCALIGNMENT
- 1);
877 EMACS_UINT untagged
= i
- tag
;
882 bool negative
= tag
& 1;
883 EMACS_UINT sign_extension
884 = negative
? VALMASK
& ~(INTPTR_MAX
>> INTTYPEBITS
): 0;
886 intptr_t all_but_sign
= u
>> GCTYPEBITS
;
887 untagged
= sign_extension
+ all_but_sign
;
892 return XIL ((tag
<< VALBITS
) + untagged
);
895 /* If V was computed from lisp_to_value (O), then return O.
896 Exits non-locally only if the stack overflows. */
898 value_to_lisp (emacs_value v
)
900 Lisp_Object o
= value_to_lisp_bits (v
);
901 if (! plain_values
&& CONSP (o
) && EQ (XCDR (o
), ltv_mark
))
906 /* Attempt to convert O to an emacs_value. Do not do any checking or
907 or allocate any storage; the caller should prevent or detect
908 any resulting bit pattern that is not a valid emacs_value. */
910 lisp_to_value_bits (Lisp_Object o
)
912 EMACS_UINT u
= XLI (o
);
914 /* Compress U into the space of a pointer, possibly losing information. */
915 uintptr_t p
= (plain_values
|| USE_LSB_TAG
917 : (INTEGERP (o
) ? u
<< VALBITS
: u
& VALMASK
) + XTYPE (o
));
918 return (emacs_value
) p
;
921 #ifndef HAVE_STRUCT_ATTRIBUTE_ALIGNED
922 enum { HAVE_STRUCT_ATTRIBUTE_ALIGNED
= 0 };
925 /* Convert O to an emacs_value. Allocate storage if needed; this can
926 signal if memory is exhausted. Must be an injective function. */
928 lisp_to_value (Lisp_Object o
)
930 emacs_value v
= lisp_to_value_bits (o
);
932 if (! EQ (o
, value_to_lisp_bits (v
)))
934 /* Package the incompressible object pointer inside a pair
935 that is compressible. */
936 Lisp_Object pair
= Fcons (o
, ltv_mark
);
938 if (! HAVE_STRUCT_ATTRIBUTE_ALIGNED
)
940 /* Keep calling Fcons until it returns a compressible pair.
941 This shouldn't take long. */
942 while ((intptr_t) XCONS (pair
) & (GCALIGNMENT
- 1))
943 pair
= Fcons (o
, pair
);
945 /* Plant the mark. The garbage collector will eventually
946 reclaim any just-allocated incompressible pairs. */
947 XSETCDR (pair
, ltv_mark
);
950 v
= (emacs_value
) ((intptr_t) XCONS (pair
) + Lisp_Cons
);
953 eassert (EQ (o
, value_to_lisp (v
)));
958 /* Environment lifetime management. */
960 /* Must be called before the environment can be used. */
962 initialize_environment (emacs_env
*env
, struct emacs_env_private
*priv
)
964 priv
->pending_non_local_exit
= emacs_funcall_exit_return
;
965 env
->size
= sizeof *env
;
966 env
->private_members
= priv
;
967 env
->make_global_ref
= module_make_global_ref
;
968 env
->free_global_ref
= module_free_global_ref
;
969 env
->non_local_exit_check
= module_non_local_exit_check
;
970 env
->non_local_exit_clear
= module_non_local_exit_clear
;
971 env
->non_local_exit_get
= module_non_local_exit_get
;
972 env
->non_local_exit_signal
= module_non_local_exit_signal
;
973 env
->non_local_exit_throw
= module_non_local_exit_throw
;
974 env
->make_function
= module_make_function
;
975 env
->funcall
= module_funcall
;
976 env
->intern
= module_intern
;
977 env
->type_of
= module_type_of
;
978 env
->is_not_nil
= module_is_not_nil
;
980 env
->extract_integer
= module_extract_integer
;
981 env
->make_integer
= module_make_integer
;
982 env
->extract_float
= module_extract_float
;
983 env
->make_float
= module_make_float
;
984 env
->copy_string_contents
= module_copy_string_contents
;
985 env
->make_string
= module_make_string
;
986 env
->make_user_ptr
= module_make_user_ptr
;
987 env
->get_user_ptr
= module_get_user_ptr
;
988 env
->set_user_ptr
= module_set_user_ptr
;
989 env
->get_user_finalizer
= module_get_user_finalizer
;
990 env
->set_user_finalizer
= module_set_user_finalizer
;
991 env
->vec_set
= module_vec_set
;
992 env
->vec_get
= module_vec_get
;
993 env
->vec_size
= module_vec_size
;
994 Vmodule_environments
= Fcons (make_save_ptr (env
), Vmodule_environments
);
997 /* Must be called before the lifetime of the environment object
1000 finalize_environment (struct emacs_env_private
*env
)
1002 Vmodule_environments
= XCDR (Vmodule_environments
);
1006 /* Non-local exit handling. */
1008 /* Must be called after setting up a handler immediately before
1009 returning from the function. See the comments in lisp.h and the
1010 code in eval.c for details. The macros below arrange for this
1011 function to be called automatically. DUMMY is ignored. */
1013 module_reset_handlerlist (const int *dummy
)
1015 handlerlist
= handlerlist
->next
;
1018 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
1019 stored in the environment. Set the pending non-local exit flag. */
1021 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
1023 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
1026 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
1027 stored in the environment. Set the pending non-local exit flag. */
1029 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
1031 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
1035 /* Function environments. */
1037 /* Return a string object that contains a user-friendly
1038 representation of the function environment. */
1040 module_format_fun_env (const struct module_fun_env
*env
)
1042 /* Try to print a function name if possible. */
1043 const char *path
, *sym
;
1044 static char const noaddr_format
[] = "#<module function at %p>";
1045 char buffer
[sizeof noaddr_format
+ INT_STRLEN_BOUND (intptr_t) + 256];
1047 ptrdiff_t bufsize
= sizeof buffer
;
1049 = (dynlib_addr (env
->subr
, &path
, &sym
)
1050 ? exprintf (&buf
, &bufsize
, buffer
, -1,
1051 "#<module function %s from %s>", sym
, path
)
1052 : sprintf (buffer
, noaddr_format
, env
->subr
));
1053 Lisp_Object unibyte_result
= make_unibyte_string (buffer
, size
);
1056 return code_convert_string_norecord (unibyte_result
, Qutf_8
, false);
1060 /* Segment initializer. */
1063 syms_of_module (void)
1066 ltv_mark
= Fcons (Qnil
, Qnil
);
1067 eassert (NILP (value_to_lisp (module_nil
)));
1069 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
1070 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
1071 doc
: /* Module global reference table. */);
1074 = make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
1075 make_float (DEFAULT_REHASH_SIZE
),
1076 make_float (DEFAULT_REHASH_THRESHOLD
),
1078 Funintern (Qmodule_refs_hash
, Qnil
);
1080 DEFSYM (Qmodule_environments
, "module-environments");
1081 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1082 doc
: /* List of active module environments. */);
1083 Vmodule_environments
= Qnil
;
1084 /* Unintern `module-environments' because it is only used
1086 Funintern (Qmodule_environments
, Qnil
);
1088 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1089 Fput (Qmodule_load_failed
, Qerror_conditions
,
1090 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1091 Fput (Qmodule_load_failed
, Qerror_message
,
1092 build_pure_c_string ("Module load failed"));
1094 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1095 Fput (Qinvalid_module_call
, Qerror_conditions
,
1096 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1097 Fput (Qinvalid_module_call
, Qerror_message
,
1098 build_pure_c_string ("Invalid module call"));
1100 DEFSYM (Qinvalid_arity
, "invalid-arity");
1101 Fput (Qinvalid_arity
, Qerror_conditions
,
1102 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1103 Fput (Qinvalid_arity
, Qerror_message
,
1104 build_pure_c_string ("Invalid function arity"));
1106 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1107 code or modules should not access it. */
1108 Funintern (Qmodule_refs_hash
, Qnil
);
1110 DEFSYM (Qsave_value_p
, "save-value-p");
1111 DEFSYM (Qsave_pointer_p
, "save-pointer-p");
1113 defsubr (&Smodule_load
);
1115 DEFSYM (Qinternal_module_call
, "internal--module-call");
1116 defsubr (&Sinternal_module_call
);
1119 /* Unlike syms_of_module, this initializer is called even from an
1120 initialized (dumped) Emacs. */
1125 /* It is not guaranteed that dynamic initializers run in the main thread,
1126 therefore detect the main thread here. */
1128 main_thread
= pthread_self ();
1129 #elif defined WINDOWSNT
1130 /* The 'main' function already recorded the main thread's thread ID,
1131 so we need just to use it . */
1132 main_thread
= dwMainThreadId
;