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 #if __has_attribute (cleanup)
39 enum { module_has_cleanup
= true };
41 enum { module_has_cleanup
= false };
44 /* Handle to the main thread. Used to verify that modules call us in
48 static pthread_t main_thread
;
49 #elif defined WINDOWSNT
52 static DWORD main_thread
;
55 /* True if Lisp_Object and emacs_value have the same representation.
56 This is typically true unless WIDE_EMACS_INT. In practice, having
57 the same sizes and alignments and maximums should be a good enough
58 proxy for equality of representation. */
62 = (sizeof (Lisp_Object
) == sizeof (emacs_value
)
63 && alignof (Lisp_Object
) == alignof (emacs_value
)
64 && INTPTR_MAX
== EMACS_INT_MAX
)
67 /* Function prototype for module user-pointer finalizers. These
68 should not throw C++ exceptions, so emacs-module.h declares the
69 corresponding interfaces with EMACS_NOEXCEPT. There is only C code
70 in this module, though, so this constraint is not enforced here. */
71 typedef void (*emacs_finalizer_function
) (void *);
74 /* Private runtime and environment members. */
76 /* The private part of an environment stores the current non local exit state
77 and holds the `emacs_value' objects allocated during the lifetime
78 of the environment. */
79 struct emacs_env_private
81 enum emacs_funcall_exit pending_non_local_exit
;
83 /* Dedicated storage for non-local exit symbol and data so that
84 storage is always available for them, even in an out-of-memory
86 Lisp_Object non_local_exit_symbol
, non_local_exit_data
;
89 /* The private parts of an `emacs_runtime' object contain the initial
91 struct emacs_runtime_private
93 /* FIXME: Ideally, we would just define "struct emacs_runtime_private"
94 as a synonym of "emacs_env", but I don't know how to do that in C. */
99 /* Forward declarations. */
101 struct module_fun_env
;
103 static Lisp_Object
module_format_fun_env (const struct module_fun_env
*);
104 static Lisp_Object
value_to_lisp (emacs_value
);
105 static emacs_value
lisp_to_value (Lisp_Object
);
106 static enum emacs_funcall_exit
module_non_local_exit_check (emacs_env
*);
107 static void check_main_thread (void);
108 static void finalize_environment (struct emacs_env_private
*);
109 static void initialize_environment (emacs_env
*, struct emacs_env_private
*priv
);
110 static void module_handle_signal (emacs_env
*, Lisp_Object
);
111 static void module_handle_throw (emacs_env
*, Lisp_Object
);
112 static void module_non_local_exit_signal_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
113 static void module_non_local_exit_throw_1 (emacs_env
*, Lisp_Object
, Lisp_Object
);
114 static void module_out_of_memory (emacs_env
*);
115 static void module_reset_handlerlist (const int *);
117 /* We used to return NULL when emacs_value was a different type from
118 Lisp_Object, but nowadays we just use Qnil instead. Although they
119 happen to be the same thing in the current implementation, module
120 code should not assume this. */
121 verify (NIL_IS_ZERO
);
122 static emacs_value
const module_nil
= 0;
124 /* Convenience macros for non-local exit handling. */
126 /* FIXME: The following implementation for non-local exit handling
127 does not support recovery from stack overflow, see sysdep.c. */
129 /* Emacs uses setjmp and longjmp for non-local exits, but
130 module frames cannot be skipped because they are in general
131 not prepared for long jumps (e.g., the behavior in C++ is undefined
132 if objects with nontrivial destructors would be skipped).
133 Therefore, catch all non-local exits. There are two kinds of
134 non-local exits: `signal' and `throw'. The macros in this section
135 can be used to catch both. Use macros to avoid additional variants
136 of `internal_condition_case' etc., and to avoid worrying about
137 passing information to the handler functions. */
139 /* Place this macro at the beginning of a function returning a number
140 or a pointer to handle non-local exits. The function must have an
141 ENV parameter. The function will return the specified value if a
142 signal or throw is caught. */
143 // TODO: Have Fsignal check for CATCHER_ALL so we only have to install
145 #define MODULE_HANDLE_NONLOCAL_EXIT(retval) \
146 MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval); \
147 MODULE_SETJMP (CATCHER_ALL, module_handle_throw, retval)
149 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
150 MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \
151 internal_handler_##handlertype, \
152 internal_cleanup_##handlertype)
154 /* It is very important that pushing the handler doesn't itself raise
155 a signal. Install the cleanup only after the handler has been
156 pushed. Use __attribute__ ((cleanup)) to avoid
157 non-local-exit-prone manual cleanup.
159 The do-while forces uses of the macro to be followed by a semicolon.
160 This macro cannot enclose its entire body inside a do-while, as the
161 code after the macro may longjmp back into the macro, which means
162 its local variable C must stay live in later code. */
164 // TODO: Make backtraces work if this macros is used.
166 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
167 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
169 struct handler *c = push_handler_nosignal (Qt, handlertype); \
172 module_out_of_memory (env); \
175 verify (module_has_cleanup); \
176 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
177 if (sys_setjmp (c->jmp)) \
179 (handlerfunc) (env, c->val); \
185 /* Function environments. */
187 /* A function environment is an auxiliary structure used by
188 `module_make_function' to store information about a module
189 function. It is stored in a save pointer and retrieved by
190 `internal--module-call'. Its members correspond to the arguments
191 given to `module_make_function'. */
193 struct module_fun_env
195 ptrdiff_t min_arity
, max_arity
;
201 /* Implementation of runtime and environment functions.
203 These should abide by the following rules:
205 1. The first argument should always be a pointer to emacs_env.
207 2. Each function should first call check_main_thread. Note that
208 this function is a no-op unless Emacs was built with
211 3. The very next thing each function should do is check that the
212 emacs_env object does not have a non-local exit indication set,
213 by calling module_non_local_exit_check. If that returns
214 anything but emacs_funcall_exit_return, the function should do
215 nothing and return immediately with an error indication, without
216 clobbering the existing error indication in emacs_env. This is
217 needed for correct reporting of Lisp errors to the Emacs Lisp
220 4. Any function that needs to call Emacs facilities, such as
221 encoding or decoding functions, or 'intern', or 'make_string',
222 should protect itself from signals and 'throw' in the called
223 Emacs functions, by placing the macro
224 MODULE_HANDLE_NONLOCAL_EXIT right after the above 2 tests.
226 5. Do NOT use 'eassert' for checking validity of user code in the
227 module. Instead, make those checks part of the code, and if the
228 check fails, call 'module_non_local_exit_signal_1' or
229 'module_non_local_exit_throw_1' to report the error. This is
230 because using 'eassert' in these situations will abort Emacs
231 instead of reporting the error back to Lisp, and also because
232 'eassert' is compiled to nothing in the release version. */
234 /* Use MODULE_FUNCTION_BEGIN to implement steps 2 through 4 for most
235 environment functions. On error it will return its argument, which
236 should be a sentinel value. */
238 #define MODULE_FUNCTION_BEGIN(error_retval) \
239 check_main_thread (); \
240 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
241 return error_retval; \
242 MODULE_HANDLE_NONLOCAL_EXIT (error_retval)
244 /* Catch signals and throws only if the code can actually signal or
245 throw. If checking is enabled, abort if the current thread is not
246 the Emacs main thread. */
249 module_get_environment (struct emacs_runtime
*ert
)
251 check_main_thread ();
252 return &ert
->private_members
->pub
;
255 /* To make global refs (GC-protected global values) keep a hash that
256 maps global Lisp objects to reference counts. */
259 module_make_global_ref (emacs_env
*env
, emacs_value ref
)
261 MODULE_FUNCTION_BEGIN (module_nil
);
262 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
263 Lisp_Object new_obj
= value_to_lisp (ref
);
265 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
269 Lisp_Object value
= HASH_VALUE (h
, i
);
270 verify (EMACS_INT_MAX
> MOST_POSITIVE_FIXNUM
);
271 EMACS_INT refcount
= XFASTINT (value
) + 1;
272 if (FIXNUM_OVERFLOW_P (refcount
)) xsignal0 (Qoverflow_error
);
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 if (nargs
== PTRDIFF_MAX
) xsignal0 (Qoverflow_error
);
413 SAFE_ALLOCA_LISP (newargs
, nargs
+ 1);
414 newargs
[0] = value_to_lisp (fun
);
415 for (ptrdiff_t i
= 0; i
< nargs
; i
++)
416 newargs
[1 + i
] = value_to_lisp (args
[i
]);
417 emacs_value result
= lisp_to_value (Ffuncall (nargs
+ 1, newargs
));
423 module_intern (emacs_env
*env
, const char *name
)
425 MODULE_FUNCTION_BEGIN (module_nil
);
426 return lisp_to_value (intern (name
));
430 module_type_of (emacs_env
*env
, emacs_value value
)
432 MODULE_FUNCTION_BEGIN (module_nil
);
433 return lisp_to_value (Ftype_of (value_to_lisp (value
)));
437 module_is_not_nil (emacs_env
*env
, emacs_value value
)
439 check_main_thread ();
440 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
442 return ! NILP (value_to_lisp (value
));
446 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
448 check_main_thread ();
449 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
451 return EQ (value_to_lisp (a
), value_to_lisp (b
));
455 module_extract_integer (emacs_env
*env
, emacs_value n
)
457 MODULE_FUNCTION_BEGIN (0);
458 Lisp_Object l
= value_to_lisp (n
);
464 module_make_integer (emacs_env
*env
, intmax_t n
)
466 MODULE_FUNCTION_BEGIN (module_nil
);
467 if (FIXNUM_OVERFLOW_P (n
)) xsignal0 (Qoverflow_error
);
468 return lisp_to_value (make_number (n
));
472 module_extract_float (emacs_env
*env
, emacs_value f
)
474 MODULE_FUNCTION_BEGIN (0);
475 Lisp_Object lisp
= value_to_lisp (f
);
476 CHECK_TYPE (FLOATP (lisp
), Qfloatp
, lisp
);
477 return XFLOAT_DATA (lisp
);
481 module_make_float (emacs_env
*env
, double d
)
483 MODULE_FUNCTION_BEGIN (module_nil
);
484 return lisp_to_value (make_float (d
));
488 module_copy_string_contents (emacs_env
*env
, emacs_value value
, char *buffer
,
491 MODULE_FUNCTION_BEGIN (false);
492 Lisp_Object lisp_str
= value_to_lisp (value
);
493 CHECK_STRING (lisp_str
);
495 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
496 ptrdiff_t raw_size
= SBYTES (lisp_str_utf8
);
497 if (raw_size
== PTRDIFF_MAX
) xsignal0 (Qoverflow_error
);
498 ptrdiff_t required_buf_size
= raw_size
+ 1;
500 eassert (length
!= NULL
);
504 *length
= required_buf_size
;
508 eassert (*length
>= 0);
510 if (*length
< required_buf_size
)
512 *length
= required_buf_size
;
513 xsignal0 (Qargs_out_of_range
);
516 *length
= required_buf_size
;
517 memcpy (buffer
, SDATA (lisp_str_utf8
), raw_size
+ 1);
523 module_make_string (emacs_env
*env
, const char *str
, ptrdiff_t length
)
525 MODULE_FUNCTION_BEGIN (module_nil
);
526 if (length
> STRING_BYTES_BOUND
) xsignal0 (Qoverflow_error
);
527 Lisp_Object lstr
= make_unibyte_string (str
, length
);
528 return lisp_to_value (code_convert_string_norecord (lstr
, Qutf_8
, false));
532 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
534 MODULE_FUNCTION_BEGIN (module_nil
);
535 return lisp_to_value (make_user_ptr (fin
, ptr
));
539 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
541 MODULE_FUNCTION_BEGIN (NULL
);
542 Lisp_Object lisp
= value_to_lisp (uptr
);
543 CHECK_TYPE (USER_PTRP (lisp
), Quser_ptrp
, lisp
);
544 return XUSER_PTR (lisp
)->p
;
548 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
550 /* FIXME: This function should return bool because it can fail. */
551 MODULE_FUNCTION_BEGIN ();
552 Lisp_Object lisp
= value_to_lisp (uptr
);
553 CHECK_TYPE (USER_PTRP (lisp
), Quser_ptrp
, lisp
);
554 XUSER_PTR (lisp
)->p
= ptr
;
557 static emacs_finalizer_function
558 module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
560 MODULE_FUNCTION_BEGIN (NULL
);
561 Lisp_Object lisp
= value_to_lisp (uptr
);
562 CHECK_TYPE (USER_PTRP (lisp
), Quser_ptrp
, lisp
);
563 return XUSER_PTR (lisp
)->finalizer
;
567 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
568 emacs_finalizer_function fin
)
570 /* FIXME: This function should return bool because it can fail. */
571 MODULE_FUNCTION_BEGIN ();
572 Lisp_Object lisp
= value_to_lisp (uptr
);
573 CHECK_TYPE (USER_PTRP (lisp
), Quser_ptrp
, lisp
);
574 XUSER_PTR (lisp
)->finalizer
= fin
;
578 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
580 /* FIXME: This function should return bool because it can fail. */
581 MODULE_FUNCTION_BEGIN ();
582 Lisp_Object lvec
= value_to_lisp (vec
);
584 if (FIXNUM_OVERFLOW_P (i
)) xsignal0 (Qoverflow_error
);
585 CHECK_RANGED_INTEGER (make_number (i
), 0, ASIZE (lvec
) - 1);
586 ASET (lvec
, i
, value_to_lisp (val
));
590 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
592 MODULE_FUNCTION_BEGIN (module_nil
);
593 Lisp_Object lvec
= value_to_lisp (vec
);
595 if (FIXNUM_OVERFLOW_P (i
)) xsignal0 (Qoverflow_error
);
596 CHECK_RANGED_INTEGER (make_number (i
), 0, ASIZE (lvec
) - 1);
597 return lisp_to_value (AREF (lvec
, i
));
601 module_vec_size (emacs_env
*env
, emacs_value vec
)
603 /* FIXME: Return a sentinel value (e.g., -1) on error. */
604 MODULE_FUNCTION_BEGIN (0);
605 Lisp_Object lvec
= value_to_lisp (vec
);
613 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
614 doc
: /* Load module FILE. */)
617 dynlib_handle_ptr handle
;
618 emacs_init_function module_init
;
622 handle
= dynlib_open (SSDATA (file
));
624 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
626 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
628 error ("Module %s is not GPL compatible", SDATA (file
));
630 module_init
= (emacs_init_function
) dynlib_func (handle
, "emacs_module_init");
632 error ("Module %s does not have an init function.", SDATA (file
));
634 struct emacs_runtime_private rt
; /* Includes the public emacs_env. */
635 struct emacs_env_private priv
;
636 initialize_environment (&rt
.pub
, &priv
);
637 struct emacs_runtime pub
=
640 .private_members
= &rt
,
641 .get_environment
= module_get_environment
643 int r
= module_init (&pub
);
644 finalize_environment (&priv
);
648 if (! (MOST_NEGATIVE_FIXNUM
<= r
&& r
<= MOST_POSITIVE_FIXNUM
))
649 xsignal0 (Qoverflow_error
);
650 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
656 DEFUN ("internal--module-call", Finternal_module_call
, Sinternal_module_call
, 1, MANY
, 0,
657 doc
: /* Internal function to call a module function.
658 ENVOBJ is a save pointer to a module_fun_env structure.
659 ARGLIST is a list of arguments passed to SUBRPTR.
660 usage: (module-call ENVOBJ &rest ARGLIST) */)
661 (ptrdiff_t nargs
, Lisp_Object
*arglist
)
663 Lisp_Object envobj
= arglist
[0];
664 /* FIXME: Rather than use a save_value, we should create a new object type.
665 Making save_value visible to Lisp is wrong. */
666 CHECK_TYPE (SAVE_VALUEP (envobj
), Qsave_value_p
, envobj
);
667 struct Lisp_Save_Value
*save_value
= XSAVE_VALUE (envobj
);
668 CHECK_TYPE (save_type (save_value
, 0) == SAVE_POINTER
, Qsave_pointer_p
, envobj
);
669 /* FIXME: We have no reason to believe that XSAVE_POINTER (envobj, 0)
670 is a module_fun_env pointer. If some other part of Emacs also
671 exports save_value objects to Elisp, than we may be getting here this
672 other kind of save_value which will likely hold something completely
673 different in this field. */
674 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
675 EMACS_INT len
= nargs
- 1;
676 eassume (0 <= envptr
->min_arity
);
677 if (! (envptr
->min_arity
<= len
678 && len
<= (envptr
->max_arity
< 0 ? PTRDIFF_MAX
: envptr
->max_arity
)))
679 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
683 struct emacs_env_private priv
;
684 initialize_environment (&pub
, &priv
);
689 args
= (emacs_value
*) arglist
+ 1;
692 args
= SAFE_ALLOCA (len
* sizeof *args
);
693 for (ptrdiff_t i
= 0; i
< len
; i
++)
694 args
[i
] = lisp_to_value (arglist
[i
+ 1]);
697 emacs_value ret
= envptr
->subr (&pub
, len
, args
, envptr
->data
);
700 eassert (&priv
== pub
.private_members
);
702 switch (priv
.pending_non_local_exit
)
704 case emacs_funcall_exit_return
:
705 finalize_environment (&priv
);
706 return value_to_lisp (ret
);
707 case emacs_funcall_exit_signal
:
709 Lisp_Object symbol
= priv
.non_local_exit_symbol
;
710 Lisp_Object data
= priv
.non_local_exit_data
;
711 finalize_environment (&priv
);
712 xsignal (symbol
, data
);
714 case emacs_funcall_exit_throw
:
716 Lisp_Object tag
= priv
.non_local_exit_symbol
;
717 Lisp_Object value
= priv
.non_local_exit_data
;
718 finalize_environment (&priv
);
727 /* Helper functions. */
730 check_main_thread (void)
733 eassert (pthread_equal (pthread_self (), main_thread
));
734 #elif defined WINDOWSNT
735 eassert (GetCurrentThreadId () == main_thread
);
740 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
743 struct emacs_env_private
*p
= env
->private_members
;
744 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
746 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
747 p
->non_local_exit_symbol
= sym
;
748 p
->non_local_exit_data
= data
;
753 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
756 struct emacs_env_private
*p
= env
->private_members
;
757 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
759 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
760 p
->non_local_exit_symbol
= tag
;
761 p
->non_local_exit_data
= value
;
765 /* Signal an out-of-memory condition to the caller. */
767 module_out_of_memory (emacs_env
*env
)
769 /* TODO: Reimplement this so it works even if memory-signal-data has
771 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
772 XCDR (Vmemory_signal_data
));
776 /* Value conversion. */
778 /* Unique Lisp_Object used to mark those emacs_values which are really
779 just containers holding a Lisp_Object that does not fit as an emacs_value,
780 either because it is an integer out of range, or is not properly aligned.
781 Used only if !plain_values. */
782 static Lisp_Object ltv_mark
;
784 /* Convert V to the corresponding internal object O, such that
785 V == lisp_to_value_bits (O). Never fails. */
787 value_to_lisp_bits (emacs_value v
)
789 intptr_t i
= (intptr_t) v
;
790 if (plain_values
|| USE_LSB_TAG
)
793 /* With wide EMACS_INT and when tag bits are the most significant,
794 reassembling integers differs from reassembling pointers in two
795 ways. First, save and restore the least-significant bits of the
796 integer, not the most-significant bits. Second, sign-extend the
797 integer when restoring, but zero-extend pointers because that
798 makes TAG_PTR faster. */
800 EMACS_UINT tag
= i
& (GCALIGNMENT
- 1);
801 EMACS_UINT untagged
= i
- tag
;
806 bool negative
= tag
& 1;
807 EMACS_UINT sign_extension
808 = negative
? VALMASK
& ~(INTPTR_MAX
>> INTTYPEBITS
): 0;
810 intptr_t all_but_sign
= u
>> GCTYPEBITS
;
811 untagged
= sign_extension
+ all_but_sign
;
816 return XIL ((tag
<< VALBITS
) + untagged
);
819 /* If V was computed from lisp_to_value (O), then return O.
820 Exits non-locally only if the stack overflows. */
822 value_to_lisp (emacs_value v
)
824 Lisp_Object o
= value_to_lisp_bits (v
);
825 if (! plain_values
&& CONSP (o
) && EQ (XCDR (o
), ltv_mark
))
830 /* Attempt to convert O to an emacs_value. Do not do any checking or
831 or allocate any storage; the caller should prevent or detect
832 any resulting bit pattern that is not a valid emacs_value. */
834 lisp_to_value_bits (Lisp_Object o
)
836 EMACS_UINT u
= XLI (o
);
838 /* Compress U into the space of a pointer, possibly losing information. */
839 uintptr_t p
= (plain_values
|| USE_LSB_TAG
841 : (INTEGERP (o
) ? u
<< VALBITS
: u
& VALMASK
) + XTYPE (o
));
842 return (emacs_value
) p
;
845 #ifndef HAVE_STRUCT_ATTRIBUTE_ALIGNED
846 enum { HAVE_STRUCT_ATTRIBUTE_ALIGNED
= 0 };
849 /* Convert O to an emacs_value. Allocate storage if needed; this can
850 signal if memory is exhausted. Must be an injective function. */
852 lisp_to_value (Lisp_Object o
)
854 emacs_value v
= lisp_to_value_bits (o
);
856 if (! EQ (o
, value_to_lisp_bits (v
)))
858 /* Package the incompressible object pointer inside a pair
859 that is compressible. */
860 Lisp_Object pair
= Fcons (o
, ltv_mark
);
862 if (! HAVE_STRUCT_ATTRIBUTE_ALIGNED
)
864 /* Keep calling Fcons until it returns a compressible pair.
865 This shouldn't take long. */
866 while ((intptr_t) XCONS (pair
) & (GCALIGNMENT
- 1))
867 pair
= Fcons (o
, pair
);
869 /* Plant the mark. The garbage collector will eventually
870 reclaim any just-allocated incompressible pairs. */
871 XSETCDR (pair
, ltv_mark
);
874 v
= (emacs_value
) ((intptr_t) XCONS (pair
) + Lisp_Cons
);
877 eassert (EQ (o
, value_to_lisp (v
)));
882 /* Environment lifetime management. */
884 /* Must be called before the environment can be used. */
886 initialize_environment (emacs_env
*env
, struct emacs_env_private
*priv
)
888 priv
->pending_non_local_exit
= emacs_funcall_exit_return
;
889 env
->size
= sizeof *env
;
890 env
->private_members
= priv
;
891 env
->make_global_ref
= module_make_global_ref
;
892 env
->free_global_ref
= module_free_global_ref
;
893 env
->non_local_exit_check
= module_non_local_exit_check
;
894 env
->non_local_exit_clear
= module_non_local_exit_clear
;
895 env
->non_local_exit_get
= module_non_local_exit_get
;
896 env
->non_local_exit_signal
= module_non_local_exit_signal
;
897 env
->non_local_exit_throw
= module_non_local_exit_throw
;
898 env
->make_function
= module_make_function
;
899 env
->funcall
= module_funcall
;
900 env
->intern
= module_intern
;
901 env
->type_of
= module_type_of
;
902 env
->is_not_nil
= module_is_not_nil
;
904 env
->extract_integer
= module_extract_integer
;
905 env
->make_integer
= module_make_integer
;
906 env
->extract_float
= module_extract_float
;
907 env
->make_float
= module_make_float
;
908 env
->copy_string_contents
= module_copy_string_contents
;
909 env
->make_string
= module_make_string
;
910 env
->make_user_ptr
= module_make_user_ptr
;
911 env
->get_user_ptr
= module_get_user_ptr
;
912 env
->set_user_ptr
= module_set_user_ptr
;
913 env
->get_user_finalizer
= module_get_user_finalizer
;
914 env
->set_user_finalizer
= module_set_user_finalizer
;
915 env
->vec_set
= module_vec_set
;
916 env
->vec_get
= module_vec_get
;
917 env
->vec_size
= module_vec_size
;
918 Vmodule_environments
= Fcons (make_save_ptr (env
), Vmodule_environments
);
921 /* Must be called before the lifetime of the environment object
924 finalize_environment (struct emacs_env_private
*env
)
926 Vmodule_environments
= XCDR (Vmodule_environments
);
930 /* Non-local exit handling. */
932 /* Must be called after setting up a handler immediately before
933 returning from the function. See the comments in lisp.h and the
934 code in eval.c for details. The macros below arrange for this
935 function to be called automatically. DUMMY is ignored. */
937 module_reset_handlerlist (const int *dummy
)
939 handlerlist
= handlerlist
->next
;
942 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
943 stored in the environment. Set the pending non-local exit flag. */
945 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
947 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
950 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
951 stored in the environment. Set the pending non-local exit flag. */
953 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
955 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
959 /* Function environments. */
961 /* Return a string object that contains a user-friendly
962 representation of the function environment. */
964 module_format_fun_env (const struct module_fun_env
*env
)
966 /* Try to print a function name if possible. */
967 const char *path
, *sym
;
968 static char const noaddr_format
[] = "#<module function at %p>";
969 char buffer
[sizeof noaddr_format
+ INT_STRLEN_BOUND (intptr_t) + 256];
971 ptrdiff_t bufsize
= sizeof buffer
;
973 = (dynlib_addr (env
->subr
, &path
, &sym
)
974 ? exprintf (&buf
, &bufsize
, buffer
, -1,
975 "#<module function %s from %s>", sym
, path
)
976 : sprintf (buffer
, noaddr_format
, env
->subr
));
977 Lisp_Object unibyte_result
= make_unibyte_string (buffer
, size
);
980 return code_convert_string_norecord (unibyte_result
, Qutf_8
, false);
984 /* Segment initializer. */
987 syms_of_module (void)
990 ltv_mark
= Fcons (Qnil
, Qnil
);
991 eassert (NILP (value_to_lisp (module_nil
)));
993 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
994 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
995 doc
: /* Module global reference table. */);
998 = make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
999 make_float (DEFAULT_REHASH_SIZE
),
1000 make_float (DEFAULT_REHASH_THRESHOLD
),
1002 Funintern (Qmodule_refs_hash
, Qnil
);
1004 DEFSYM (Qmodule_environments
, "module-environments");
1005 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1006 doc
: /* List of active module environments. */);
1007 Vmodule_environments
= Qnil
;
1008 /* Unintern `module-environments' because it is only used
1010 Funintern (Qmodule_environments
, Qnil
);
1012 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1013 Fput (Qmodule_load_failed
, Qerror_conditions
,
1014 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1015 Fput (Qmodule_load_failed
, Qerror_message
,
1016 build_pure_c_string ("Module load failed"));
1018 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1019 Fput (Qinvalid_module_call
, Qerror_conditions
,
1020 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1021 Fput (Qinvalid_module_call
, Qerror_message
,
1022 build_pure_c_string ("Invalid module call"));
1024 DEFSYM (Qinvalid_arity
, "invalid-arity");
1025 Fput (Qinvalid_arity
, Qerror_conditions
,
1026 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1027 Fput (Qinvalid_arity
, Qerror_message
,
1028 build_pure_c_string ("Invalid function arity"));
1030 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1031 code or modules should not access it. */
1032 Funintern (Qmodule_refs_hash
, Qnil
);
1034 DEFSYM (Qsave_value_p
, "save-value-p");
1035 DEFSYM (Qsave_pointer_p
, "save-pointer-p");
1037 defsubr (&Smodule_load
);
1039 DEFSYM (Qinternal_module_call
, "internal--module-call");
1040 defsubr (&Sinternal_module_call
);
1043 /* Unlike syms_of_module, this initializer is called even from an
1044 initialized (dumped) Emacs. */
1049 /* It is not guaranteed that dynamic initializers run in the main thread,
1050 therefore detect the main thread here. */
1052 main_thread
= pthread_self ();
1053 #elif defined WINDOWSNT
1054 /* The 'main' function already recorded the main thread's thread ID,
1055 so we need just to use it . */
1056 main_thread
= dwMainThreadId
;