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)
245 CHECK_USER_PTR (Lisp_Object obj
)
247 CHECK_TYPE (USER_PTRP (obj
), Quser_ptrp
, lisp
);
250 /* Catch signals and throws only if the code can actually signal or
251 throw. If checking is enabled, abort if the current thread is not
252 the Emacs main thread. */
255 module_get_environment (struct emacs_runtime
*ert
)
257 check_main_thread ();
258 return &ert
->private_members
->pub
;
261 /* To make global refs (GC-protected global values) keep a hash that
262 maps global Lisp objects to reference counts. */
265 module_make_global_ref (emacs_env
*env
, emacs_value ref
)
267 MODULE_FUNCTION_BEGIN (module_nil
);
268 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
269 Lisp_Object new_obj
= value_to_lisp (ref
);
271 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
275 Lisp_Object value
= HASH_VALUE (h
, i
);
276 EMACS_INT refcount
= XFASTINT (value
) + 1;
277 if (MOST_POSITIVE_FIXNUM
< refcount
)
278 xsignal0 (Qoverflow_error
);
279 value
= make_natnum (refcount
);
280 set_hash_value_slot (h
, i
, value
);
284 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
287 return lisp_to_value (new_obj
);
291 module_free_global_ref (emacs_env
*env
, emacs_value ref
)
293 /* TODO: This probably never signals. */
294 /* FIXME: Wait a minute. Shouldn't this function report an error if
295 the hash lookup fails? */
296 MODULE_FUNCTION_BEGIN ();
297 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
298 Lisp_Object obj
= value_to_lisp (ref
);
300 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
304 Lisp_Object value
= HASH_VALUE (h
, i
);
305 EMACS_INT refcount
= XFASTINT (value
) - 1;
308 value
= make_natnum (refcount
);
309 set_hash_value_slot (h
, i
, value
);
312 hash_remove_from_table (h
, value
);
316 static enum emacs_funcall_exit
317 module_non_local_exit_check (emacs_env
*env
)
319 check_main_thread ();
320 return env
->private_members
->pending_non_local_exit
;
324 module_non_local_exit_clear (emacs_env
*env
)
326 check_main_thread ();
327 env
->private_members
->pending_non_local_exit
= emacs_funcall_exit_return
;
330 static enum emacs_funcall_exit
331 module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
)
333 check_main_thread ();
334 struct emacs_env_private
*p
= env
->private_members
;
335 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
337 /* FIXME: lisp_to_value can exit non-locally. */
338 *sym
= lisp_to_value (p
->non_local_exit_symbol
);
339 *data
= lisp_to_value (p
->non_local_exit_data
);
341 return p
->pending_non_local_exit
;
344 /* Like for `signal', DATA must be a list. */
346 module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
)
348 check_main_thread ();
349 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
350 module_non_local_exit_signal_1 (env
, value_to_lisp (sym
),
351 value_to_lisp (data
));
355 module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
)
357 check_main_thread ();
358 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
359 module_non_local_exit_throw_1 (env
, value_to_lisp (tag
),
360 value_to_lisp (value
));
363 /* A module function is lambda function that calls
364 `internal--module-call', passing the function pointer of the module
365 function along with the module emacs_env pointer as arguments.
367 (function (lambda (&rest arglist)
368 (internal--module-call envobj arglist))) */
371 module_make_function (emacs_env
*env
, ptrdiff_t min_arity
, ptrdiff_t max_arity
,
372 emacs_subr subr
, const char *documentation
,
375 MODULE_FUNCTION_BEGIN (module_nil
);
377 if (! (0 <= min_arity
379 ? max_arity
== emacs_variadic_function
380 : min_arity
<= max_arity
)))
381 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
383 /* FIXME: This should be freed when envobj is GC'd. */
384 struct module_fun_env
*envptr
= xmalloc (sizeof *envptr
);
385 envptr
->min_arity
= min_arity
;
386 envptr
->max_arity
= max_arity
;
390 Lisp_Object envobj
= make_save_ptr (envptr
);
393 ? code_convert_string_norecord (build_unibyte_string (documentation
),
396 /* FIXME: Use a bytecompiled object, or even better a subr. */
397 Lisp_Object ret
= list4 (Qlambda
,
398 list2 (Qand_rest
, Qargs
),
401 list2 (Qfunction
, Qinternal_module_call
),
405 return lisp_to_value (ret
);
409 module_funcall (emacs_env
*env
, emacs_value fun
, ptrdiff_t nargs
,
412 MODULE_FUNCTION_BEGIN (module_nil
);
414 /* Make a new Lisp_Object array starting with the function as the
415 first arg, because that's what Ffuncall takes. */
416 Lisp_Object
*newargs
;
418 if (nargs
== PTRDIFF_MAX
)
419 xsignal0 (Qoverflow_error
);
420 SAFE_ALLOCA_LISP (newargs
, nargs
+ 1);
421 newargs
[0] = value_to_lisp (fun
);
422 for (ptrdiff_t i
= 0; i
< nargs
; i
++)
423 newargs
[1 + i
] = value_to_lisp (args
[i
]);
424 emacs_value result
= lisp_to_value (Ffuncall (nargs
+ 1, newargs
));
430 module_intern (emacs_env
*env
, const char *name
)
432 MODULE_FUNCTION_BEGIN (module_nil
);
433 return lisp_to_value (intern (name
));
437 module_type_of (emacs_env
*env
, emacs_value value
)
439 MODULE_FUNCTION_BEGIN (module_nil
);
440 return lisp_to_value (Ftype_of (value_to_lisp (value
)));
444 module_is_not_nil (emacs_env
*env
, emacs_value value
)
446 check_main_thread ();
447 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
449 return ! NILP (value_to_lisp (value
));
453 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
455 check_main_thread ();
456 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
458 return EQ (value_to_lisp (a
), value_to_lisp (b
));
462 module_extract_integer (emacs_env
*env
, emacs_value n
)
464 MODULE_FUNCTION_BEGIN (0);
465 Lisp_Object l
= value_to_lisp (n
);
471 module_make_integer (emacs_env
*env
, intmax_t n
)
473 MODULE_FUNCTION_BEGIN (module_nil
);
474 if (FIXNUM_OVERFLOW_P (n
))
475 xsignal0 (Qoverflow_error
);
476 return lisp_to_value (make_number (n
));
480 module_extract_float (emacs_env
*env
, emacs_value f
)
482 MODULE_FUNCTION_BEGIN (0);
483 Lisp_Object lisp
= value_to_lisp (f
);
484 CHECK_TYPE (FLOATP (lisp
), Qfloatp
, lisp
);
485 return XFLOAT_DATA (lisp
);
489 module_make_float (emacs_env
*env
, double d
)
491 MODULE_FUNCTION_BEGIN (module_nil
);
492 return lisp_to_value (make_float (d
));
496 module_copy_string_contents (emacs_env
*env
, emacs_value value
, char *buffer
,
499 MODULE_FUNCTION_BEGIN (false);
500 Lisp_Object lisp_str
= value_to_lisp (value
);
501 CHECK_STRING (lisp_str
);
503 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
504 ptrdiff_t raw_size
= SBYTES (lisp_str_utf8
);
505 ptrdiff_t required_buf_size
= raw_size
+ 1;
507 eassert (length
!= NULL
);
511 *length
= required_buf_size
;
515 eassert (*length
>= 0);
517 if (*length
< required_buf_size
)
519 *length
= required_buf_size
;
520 xsignal0 (Qargs_out_of_range
);
523 *length
= required_buf_size
;
524 memcpy (buffer
, SDATA (lisp_str_utf8
), raw_size
+ 1);
530 module_make_string (emacs_env
*env
, const char *str
, ptrdiff_t length
)
532 MODULE_FUNCTION_BEGIN (module_nil
);
533 Lisp_Object lstr
= make_unibyte_string (str
, length
);
534 return lisp_to_value (code_convert_string_norecord (lstr
, Qutf_8
, false));
538 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
540 MODULE_FUNCTION_BEGIN (module_nil
);
541 return lisp_to_value (make_user_ptr (fin
, ptr
));
545 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
547 MODULE_FUNCTION_BEGIN (NULL
);
548 Lisp_Object lisp
= value_to_lisp (uptr
);
549 CHECK_USER_PTR (lisp
);
550 return XUSER_PTR (lisp
)->p
;
554 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
556 /* FIXME: This function should return bool because it can fail. */
557 MODULE_FUNCTION_BEGIN ();
558 Lisp_Object lisp
= value_to_lisp (uptr
);
559 CHECK_USER_PTR (lisp
);
560 XUSER_PTR (lisp
)->p
= ptr
;
563 static emacs_finalizer_function
564 module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
566 MODULE_FUNCTION_BEGIN (NULL
);
567 Lisp_Object lisp
= value_to_lisp (uptr
);
568 CHECK_USER_PTR (lisp
);
569 return XUSER_PTR (lisp
)->finalizer
;
573 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
574 emacs_finalizer_function fin
)
576 /* FIXME: This function should return bool because it can fail. */
577 MODULE_FUNCTION_BEGIN ();
578 Lisp_Object lisp
= value_to_lisp (uptr
);
579 CHECK_USER_PTR (lisp
);
580 XUSER_PTR (lisp
)->finalizer
= fin
;
584 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
586 /* FIXME: This function should return bool because it can fail. */
587 MODULE_FUNCTION_BEGIN ();
588 Lisp_Object lvec
= value_to_lisp (vec
);
590 CHECK_RANGED_INTEGER (make_number (i
), 0, ASIZE (lvec
) - 1);
591 ASET (lvec
, i
, value_to_lisp (val
));
595 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
597 MODULE_FUNCTION_BEGIN (module_nil
);
598 Lisp_Object lvec
= value_to_lisp (vec
);
600 CHECK_RANGED_INTEGER (make_number (i
), 0, ASIZE (lvec
) - 1);
601 return lisp_to_value (AREF (lvec
, i
));
605 module_vec_size (emacs_env
*env
, emacs_value vec
)
607 /* FIXME: Return a sentinel value (e.g., -1) on error. */
608 MODULE_FUNCTION_BEGIN (0);
609 Lisp_Object lvec
= value_to_lisp (vec
);
617 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
618 doc
: /* Load module FILE. */)
621 dynlib_handle_ptr handle
;
622 emacs_init_function module_init
;
626 handle
= dynlib_open (SSDATA (file
));
628 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
630 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
632 error ("Module %s is not GPL compatible", SDATA (file
));
634 module_init
= (emacs_init_function
) dynlib_func (handle
, "emacs_module_init");
636 error ("Module %s does not have an init function.", SDATA (file
));
638 struct emacs_runtime_private rt
; /* Includes the public emacs_env. */
639 struct emacs_env_private priv
;
640 initialize_environment (&rt
.pub
, &priv
);
641 struct emacs_runtime pub
=
644 .private_members
= &rt
,
645 .get_environment
= module_get_environment
647 int r
= module_init (&pub
);
648 finalize_environment (&priv
);
652 if (! (MOST_NEGATIVE_FIXNUM
<= r
&& r
<= MOST_POSITIVE_FIXNUM
))
653 xsignal0 (Qoverflow_error
);
654 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
660 DEFUN ("internal--module-call", Finternal_module_call
, Sinternal_module_call
, 1, MANY
, 0,
661 doc
: /* Internal function to call a module function.
662 ENVOBJ is a save pointer to a module_fun_env structure.
663 ARGLIST is a list of arguments passed to SUBRPTR.
664 usage: (module-call ENVOBJ &rest ARGLIST) */)
665 (ptrdiff_t nargs
, Lisp_Object
*arglist
)
667 Lisp_Object envobj
= arglist
[0];
668 /* FIXME: Rather than use a save_value, we should create a new object type.
669 Making save_value visible to Lisp is wrong. */
670 CHECK_TYPE (SAVE_VALUEP (envobj
), Qsave_value_p
, envobj
);
671 struct Lisp_Save_Value
*save_value
= XSAVE_VALUE (envobj
);
672 CHECK_TYPE (save_type (save_value
, 0) == SAVE_POINTER
, Qsave_pointer_p
, envobj
);
673 /* FIXME: We have no reason to believe that XSAVE_POINTER (envobj, 0)
674 is a module_fun_env pointer. If some other part of Emacs also
675 exports save_value objects to Elisp, than we may be getting here this
676 other kind of save_value which will likely hold something completely
677 different in this field. */
678 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
679 EMACS_INT len
= nargs
- 1;
680 eassume (0 <= envptr
->min_arity
);
681 if (! (envptr
->min_arity
<= len
682 && len
<= (envptr
->max_arity
< 0 ? PTRDIFF_MAX
: envptr
->max_arity
)))
683 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
687 struct emacs_env_private priv
;
688 initialize_environment (&pub
, &priv
);
693 args
= (emacs_value
*) arglist
+ 1;
696 args
= SAFE_ALLOCA (len
* sizeof *args
);
697 for (ptrdiff_t i
= 0; i
< len
; i
++)
698 args
[i
] = lisp_to_value (arglist
[i
+ 1]);
701 emacs_value ret
= envptr
->subr (&pub
, len
, args
, envptr
->data
);
704 eassert (&priv
== pub
.private_members
);
706 switch (priv
.pending_non_local_exit
)
708 case emacs_funcall_exit_return
:
709 finalize_environment (&priv
);
710 return value_to_lisp (ret
);
711 case emacs_funcall_exit_signal
:
713 Lisp_Object symbol
= priv
.non_local_exit_symbol
;
714 Lisp_Object data
= priv
.non_local_exit_data
;
715 finalize_environment (&priv
);
716 xsignal (symbol
, data
);
718 case emacs_funcall_exit_throw
:
720 Lisp_Object tag
= priv
.non_local_exit_symbol
;
721 Lisp_Object value
= priv
.non_local_exit_data
;
722 finalize_environment (&priv
);
731 /* Helper functions. */
734 check_main_thread (void)
737 eassert (pthread_equal (pthread_self (), main_thread
));
738 #elif defined WINDOWSNT
739 eassert (GetCurrentThreadId () == main_thread
);
744 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
747 struct emacs_env_private
*p
= env
->private_members
;
748 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
750 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
751 p
->non_local_exit_symbol
= sym
;
752 p
->non_local_exit_data
= data
;
757 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
760 struct emacs_env_private
*p
= env
->private_members
;
761 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
763 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
764 p
->non_local_exit_symbol
= tag
;
765 p
->non_local_exit_data
= value
;
769 /* Signal an out-of-memory condition to the caller. */
771 module_out_of_memory (emacs_env
*env
)
773 /* TODO: Reimplement this so it works even if memory-signal-data has
775 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
776 XCDR (Vmemory_signal_data
));
780 /* Value conversion. */
782 /* Unique Lisp_Object used to mark those emacs_values which are really
783 just containers holding a Lisp_Object that does not fit as an emacs_value,
784 either because it is an integer out of range, or is not properly aligned.
785 Used only if !plain_values. */
786 static Lisp_Object ltv_mark
;
788 /* Convert V to the corresponding internal object O, such that
789 V == lisp_to_value_bits (O). Never fails. */
791 value_to_lisp_bits (emacs_value v
)
793 intptr_t i
= (intptr_t) v
;
794 if (plain_values
|| USE_LSB_TAG
)
797 /* With wide EMACS_INT and when tag bits are the most significant,
798 reassembling integers differs from reassembling pointers in two
799 ways. First, save and restore the least-significant bits of the
800 integer, not the most-significant bits. Second, sign-extend the
801 integer when restoring, but zero-extend pointers because that
802 makes TAG_PTR faster. */
804 EMACS_UINT tag
= i
& (GCALIGNMENT
- 1);
805 EMACS_UINT untagged
= i
- tag
;
810 bool negative
= tag
& 1;
811 EMACS_UINT sign_extension
812 = negative
? VALMASK
& ~(INTPTR_MAX
>> INTTYPEBITS
): 0;
814 intptr_t all_but_sign
= u
>> GCTYPEBITS
;
815 untagged
= sign_extension
+ all_but_sign
;
820 return XIL ((tag
<< VALBITS
) + untagged
);
823 /* If V was computed from lisp_to_value (O), then return O.
824 Exits non-locally only if the stack overflows. */
826 value_to_lisp (emacs_value v
)
828 Lisp_Object o
= value_to_lisp_bits (v
);
829 if (! plain_values
&& CONSP (o
) && EQ (XCDR (o
), ltv_mark
))
834 /* Attempt to convert O to an emacs_value. Do not do any checking or
835 or allocate any storage; the caller should prevent or detect
836 any resulting bit pattern that is not a valid emacs_value. */
838 lisp_to_value_bits (Lisp_Object o
)
840 EMACS_UINT u
= XLI (o
);
842 /* Compress U into the space of a pointer, possibly losing information. */
843 uintptr_t p
= (plain_values
|| USE_LSB_TAG
845 : (INTEGERP (o
) ? u
<< VALBITS
: u
& VALMASK
) + XTYPE (o
));
846 return (emacs_value
) p
;
849 #ifndef HAVE_STRUCT_ATTRIBUTE_ALIGNED
850 enum { HAVE_STRUCT_ATTRIBUTE_ALIGNED
= 0 };
853 /* Convert O to an emacs_value. Allocate storage if needed; this can
854 signal if memory is exhausted. Must be an injective function. */
856 lisp_to_value (Lisp_Object o
)
858 emacs_value v
= lisp_to_value_bits (o
);
860 if (! EQ (o
, value_to_lisp_bits (v
)))
862 /* Package the incompressible object pointer inside a pair
863 that is compressible. */
864 Lisp_Object pair
= Fcons (o
, ltv_mark
);
866 if (! HAVE_STRUCT_ATTRIBUTE_ALIGNED
)
868 /* Keep calling Fcons until it returns a compressible pair.
869 This shouldn't take long. */
870 while ((intptr_t) XCONS (pair
) & (GCALIGNMENT
- 1))
871 pair
= Fcons (o
, pair
);
873 /* Plant the mark. The garbage collector will eventually
874 reclaim any just-allocated incompressible pairs. */
875 XSETCDR (pair
, ltv_mark
);
878 v
= (emacs_value
) ((intptr_t) XCONS (pair
) + Lisp_Cons
);
881 eassert (EQ (o
, value_to_lisp (v
)));
886 /* Environment lifetime management. */
888 /* Must be called before the environment can be used. */
890 initialize_environment (emacs_env
*env
, struct emacs_env_private
*priv
)
892 priv
->pending_non_local_exit
= emacs_funcall_exit_return
;
893 env
->size
= sizeof *env
;
894 env
->private_members
= priv
;
895 env
->make_global_ref
= module_make_global_ref
;
896 env
->free_global_ref
= module_free_global_ref
;
897 env
->non_local_exit_check
= module_non_local_exit_check
;
898 env
->non_local_exit_clear
= module_non_local_exit_clear
;
899 env
->non_local_exit_get
= module_non_local_exit_get
;
900 env
->non_local_exit_signal
= module_non_local_exit_signal
;
901 env
->non_local_exit_throw
= module_non_local_exit_throw
;
902 env
->make_function
= module_make_function
;
903 env
->funcall
= module_funcall
;
904 env
->intern
= module_intern
;
905 env
->type_of
= module_type_of
;
906 env
->is_not_nil
= module_is_not_nil
;
908 env
->extract_integer
= module_extract_integer
;
909 env
->make_integer
= module_make_integer
;
910 env
->extract_float
= module_extract_float
;
911 env
->make_float
= module_make_float
;
912 env
->copy_string_contents
= module_copy_string_contents
;
913 env
->make_string
= module_make_string
;
914 env
->make_user_ptr
= module_make_user_ptr
;
915 env
->get_user_ptr
= module_get_user_ptr
;
916 env
->set_user_ptr
= module_set_user_ptr
;
917 env
->get_user_finalizer
= module_get_user_finalizer
;
918 env
->set_user_finalizer
= module_set_user_finalizer
;
919 env
->vec_set
= module_vec_set
;
920 env
->vec_get
= module_vec_get
;
921 env
->vec_size
= module_vec_size
;
922 Vmodule_environments
= Fcons (make_save_ptr (env
), Vmodule_environments
);
925 /* Must be called before the lifetime of the environment object
928 finalize_environment (struct emacs_env_private
*env
)
930 Vmodule_environments
= XCDR (Vmodule_environments
);
934 /* Non-local exit handling. */
936 /* Must be called after setting up a handler immediately before
937 returning from the function. See the comments in lisp.h and the
938 code in eval.c for details. The macros below arrange for this
939 function to be called automatically. DUMMY is ignored. */
941 module_reset_handlerlist (const int *dummy
)
943 handlerlist
= handlerlist
->next
;
946 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
947 stored in the environment. Set the pending non-local exit flag. */
949 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
951 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
954 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
955 stored in the environment. Set the pending non-local exit flag. */
957 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
959 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
963 /* Function environments. */
965 /* Return a string object that contains a user-friendly
966 representation of the function environment. */
968 module_format_fun_env (const struct module_fun_env
*env
)
970 /* Try to print a function name if possible. */
971 const char *path
, *sym
;
972 static char const noaddr_format
[] = "#<module function at %p>";
973 char buffer
[sizeof noaddr_format
+ INT_STRLEN_BOUND (intptr_t) + 256];
975 ptrdiff_t bufsize
= sizeof buffer
;
977 = (dynlib_addr (env
->subr
, &path
, &sym
)
978 ? exprintf (&buf
, &bufsize
, buffer
, -1,
979 "#<module function %s from %s>", sym
, path
)
980 : sprintf (buffer
, noaddr_format
, env
->subr
));
981 Lisp_Object unibyte_result
= make_unibyte_string (buffer
, size
);
984 return code_convert_string_norecord (unibyte_result
, Qutf_8
, false);
988 /* Segment initializer. */
991 syms_of_module (void)
994 ltv_mark
= Fcons (Qnil
, Qnil
);
995 eassert (NILP (value_to_lisp (module_nil
)));
997 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
998 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
999 doc
: /* Module global reference table. */);
1002 = make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
1003 make_float (DEFAULT_REHASH_SIZE
),
1004 make_float (DEFAULT_REHASH_THRESHOLD
),
1006 Funintern (Qmodule_refs_hash
, Qnil
);
1008 DEFSYM (Qmodule_environments
, "module-environments");
1009 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1010 doc
: /* List of active module environments. */);
1011 Vmodule_environments
= Qnil
;
1012 /* Unintern `module-environments' because it is only used
1014 Funintern (Qmodule_environments
, Qnil
);
1016 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1017 Fput (Qmodule_load_failed
, Qerror_conditions
,
1018 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1019 Fput (Qmodule_load_failed
, Qerror_message
,
1020 build_pure_c_string ("Module load failed"));
1022 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1023 Fput (Qinvalid_module_call
, Qerror_conditions
,
1024 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1025 Fput (Qinvalid_module_call
, Qerror_message
,
1026 build_pure_c_string ("Invalid module call"));
1028 DEFSYM (Qinvalid_arity
, "invalid-arity");
1029 Fput (Qinvalid_arity
, Qerror_conditions
,
1030 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1031 Fput (Qinvalid_arity
, Qerror_message
,
1032 build_pure_c_string ("Invalid function arity"));
1034 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1035 code or modules should not access it. */
1036 Funintern (Qmodule_refs_hash
, Qnil
);
1038 DEFSYM (Qsave_value_p
, "save-value-p");
1039 DEFSYM (Qsave_pointer_p
, "save-pointer-p");
1041 defsubr (&Smodule_load
);
1043 DEFSYM (Qinternal_module_call
, "internal--module-call");
1044 defsubr (&Sinternal_module_call
);
1047 /* Unlike syms_of_module, this initializer is called even from an
1048 initialized (dumped) Emacs. */
1053 /* It is not guaranteed that dynamic initializers run in the main thread,
1054 therefore detect the main thread here. */
1056 main_thread
= pthread_self ();
1057 #elif defined WINDOWSNT
1058 /* The 'main' function already recorded the main thread's thread ID,
1059 so we need just to use it . */
1060 main_thread
= dwMainThreadId
;