1 /* emacs-module.c - Module loading and runtime implementation
3 Copyright (C) 2015 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include "emacs-module.h"
38 /* True if __attribute__ ((cleanup (...))) works, false otherwise. */
39 #ifdef HAVE_VAR_ATTRIBUTE_CLEANUP
40 enum { module_has_cleanup
= true };
42 enum { module_has_cleanup
= false };
45 /* Handle to the main thread. Used to verify that modules call us in
49 static 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 /* Emacs uses setjmp and longjmp for non-local exits, but
124 module frames cannot be skipped because they are in general
125 not prepared for long jumps (e.g., the behavior in C++ is undefined
126 if objects with nontrivial destructors would be skipped).
127 Therefore, catch all non-local exits. There are two kinds of
128 non-local exits: `signal' and `throw'. The macros in this section
129 can be used to catch both. Use macros to avoid additional variants
130 of `internal_condition_case' etc., and to avoid worrying about
131 passing information to the handler functions. */
133 /* Place this macro at the beginning of a function returning a number
134 or a pointer to handle non-local exits. The function must have an
135 ENV parameter. The function will return the specified value if a
136 signal or throw is caught. */
137 // TODO: Have Fsignal check for CATCHER_ALL so we only have to install
139 #define MODULE_HANDLE_NONLOCAL_EXIT(retval) \
140 MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval); \
141 MODULE_SETJMP (CATCHER_ALL, module_handle_throw, retval)
143 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
144 MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \
145 internal_handler_##handlertype, \
146 internal_cleanup_##handlertype)
148 /* It is very important that pushing the handler doesn't itself raise
149 a signal. Install the cleanup only after the handler has been
150 pushed. Use __attribute__ ((cleanup)) to avoid
151 non-local-exit-prone manual cleanup.
153 The do-while forces uses of the macro to be followed by a semicolon.
154 This macro cannot enclose its entire body inside a do-while, as the
155 code after the macro may longjmp back into the macro, which means
156 its local variable C must stay live in later code. */
158 // TODO: Make backtraces work if this macros is used.
160 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
161 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
163 struct handler *c = push_handler_nosignal (Qt, handlertype); \
166 module_out_of_memory (env); \
169 verify (module_has_cleanup); \
170 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
171 if (sys_setjmp (c->jmp)) \
173 (handlerfunc) (env, c->val); \
179 /* Function environments. */
181 /* A function environment is an auxiliary structure used by
182 `module_make_function' to store information about a module
183 function. It is stored in a save pointer and retrieved by
184 `internal--module-call'. Its members correspond to the arguments
185 given to `module_make_function'. */
187 struct module_fun_env
189 ptrdiff_t min_arity
, max_arity
;
195 /* Implementation of runtime and environment functions.
197 These should abide by the following rules:
199 1. The first argument should always be a pointer to emacs_env.
201 2. Each function should first call check_main_thread. Note that
202 this function is a no-op unless Emacs was built with
205 3. The very next thing each function should do is check that the
206 emacs_env object does not have a non-local exit indication set,
207 by calling module_non_local_exit_check. If that returns
208 anything but emacs_funcall_exit_return, the function should do
209 nothing and return immediately with an error indication, without
210 clobbering the existing error indication in emacs_env. This is
211 needed for correct reporting of Lisp errors to the Emacs Lisp
214 4. Any function that needs to call Emacs facilities, such as
215 encoding or decoding functions, or 'intern', or 'make_string',
216 should protect itself from signals and 'throw' in the called
217 Emacs functions, by placing the macro
218 MODULE_HANDLE_NONLOCAL_EXIT right after the above 2 tests.
220 5. Do NOT use 'eassert' for checking validity of user code in the
221 module. Instead, make those checks part of the code, and if the
222 check fails, call 'module_non_local_exit_signal_1' or
223 'module_non_local_exit_throw_1' to report the error. This is
224 because using 'eassert' in these situations will abort Emacs
225 instead of reporting the error back to Lisp, and also because
226 'eassert' is compiled to nothing in the release version. */
228 /* Use MODULE_FUNCTION_BEGIN to implement steps 2 through 4 for most
229 environment functions. On error it will return its argument, which
230 should be a sentinel value. */
232 #define MODULE_FUNCTION_BEGIN(error_retval) \
233 check_main_thread (); \
234 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
235 return error_retval; \
236 MODULE_HANDLE_NONLOCAL_EXIT (error_retval)
238 /* Catch signals and throws only if the code can actually signal or
239 throw. If checking is enabled, abort if the current thread is not
240 the Emacs main thread. */
243 module_get_environment (struct emacs_runtime
*ert
)
245 check_main_thread ();
246 return &ert
->private_members
->pub
;
249 /* To make global refs (GC-protected global values) keep a hash that
250 maps global Lisp objects to reference counts. */
253 module_make_global_ref (emacs_env
*env
, emacs_value ref
)
255 MODULE_FUNCTION_BEGIN (module_nil
);
256 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
257 Lisp_Object new_obj
= value_to_lisp (ref
);
259 ptrdiff_t i
= hash_lookup (h
, new_obj
, &hashcode
);
263 Lisp_Object value
= HASH_VALUE (h
, i
);
264 EMACS_INT refcount
= XFASTINT (value
) + 1;
265 if (refcount
> MOST_POSITIVE_FIXNUM
)
267 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
270 value
= make_natnum (refcount
);
271 set_hash_value_slot (h
, i
, value
);
275 hash_put (h
, new_obj
, make_natnum (1), hashcode
);
278 return lisp_to_value (new_obj
);
282 module_free_global_ref (emacs_env
*env
, emacs_value ref
)
284 /* TODO: This probably never signals. */
285 /* FIXME: Wait a minute. Shouldn't this function report an error if
286 the hash lookup fails? */
287 MODULE_FUNCTION_BEGIN ();
288 struct Lisp_Hash_Table
*h
= XHASH_TABLE (Vmodule_refs_hash
);
289 Lisp_Object obj
= value_to_lisp (ref
);
291 ptrdiff_t i
= hash_lookup (h
, obj
, &hashcode
);
295 Lisp_Object value
= HASH_VALUE (h
, i
);
296 EMACS_INT refcount
= XFASTINT (value
) - 1;
299 value
= make_natnum (refcount
);
300 set_hash_value_slot (h
, i
, value
);
303 hash_remove_from_table (h
, value
);
307 static enum emacs_funcall_exit
308 module_non_local_exit_check (emacs_env
*env
)
310 check_main_thread ();
311 return env
->private_members
->pending_non_local_exit
;
315 module_non_local_exit_clear (emacs_env
*env
)
317 check_main_thread ();
318 env
->private_members
->pending_non_local_exit
= emacs_funcall_exit_return
;
321 static enum emacs_funcall_exit
322 module_non_local_exit_get (emacs_env
*env
, emacs_value
*sym
, emacs_value
*data
)
324 check_main_thread ();
325 struct emacs_env_private
*p
= env
->private_members
;
326 if (p
->pending_non_local_exit
!= emacs_funcall_exit_return
)
328 /* FIXME: lisp_to_value can exit non-locally. */
329 *sym
= lisp_to_value (p
->non_local_exit_symbol
);
330 *data
= lisp_to_value (p
->non_local_exit_data
);
332 return p
->pending_non_local_exit
;
335 /* Like for `signal', DATA must be a list. */
337 module_non_local_exit_signal (emacs_env
*env
, emacs_value sym
, emacs_value data
)
339 check_main_thread ();
340 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
341 module_non_local_exit_signal_1 (env
, value_to_lisp (sym
),
342 value_to_lisp (data
));
346 module_non_local_exit_throw (emacs_env
*env
, emacs_value tag
, emacs_value value
)
348 check_main_thread ();
349 if (module_non_local_exit_check (env
) == emacs_funcall_exit_return
)
350 module_non_local_exit_throw_1 (env
, value_to_lisp (tag
),
351 value_to_lisp (value
));
354 /* A module function is lambda function that calls
355 `internal--module-call', passing the function pointer of the module
356 function along with the module emacs_env pointer as arguments.
358 (function (lambda (&rest arglist)
359 (internal--module-call envobj arglist))) */
362 module_make_function (emacs_env
*env
, ptrdiff_t min_arity
, ptrdiff_t max_arity
,
363 emacs_subr subr
, const char *documentation
,
366 MODULE_FUNCTION_BEGIN (module_nil
);
368 if (! (0 <= min_arity
370 ? max_arity
== emacs_variadic_function
371 : min_arity
<= max_arity
)))
372 xsignal2 (Qinvalid_arity
, make_number (min_arity
), make_number (max_arity
));
374 /* FIXME: This should be freed when envobj is GC'd. */
375 struct module_fun_env
*envptr
= xmalloc (sizeof *envptr
);
376 envptr
->min_arity
= min_arity
;
377 envptr
->max_arity
= max_arity
;
381 Lisp_Object envobj
= make_save_ptr (envptr
);
384 ? code_convert_string_norecord (build_unibyte_string (documentation
),
387 /* FIXME: Use a bytecompiled object, or even better a subr. */
388 Lisp_Object ret
= list4 (Qlambda
,
389 list2 (Qand_rest
, Qargs
),
392 list2 (Qfunction
, Qinternal_module_call
),
396 return lisp_to_value (ret
);
400 module_funcall (emacs_env
*env
, emacs_value fun
, ptrdiff_t nargs
,
403 MODULE_FUNCTION_BEGIN (module_nil
);
405 /* Make a new Lisp_Object array starting with the function as the
406 first arg, because that's what Ffuncall takes. */
407 Lisp_Object
*newargs
;
409 SAFE_ALLOCA_LISP (newargs
, nargs
+ 1);
410 newargs
[0] = value_to_lisp (fun
);
411 for (ptrdiff_t i
= 0; i
< nargs
; i
++)
412 newargs
[1 + i
] = value_to_lisp (args
[i
]);
413 emacs_value result
= lisp_to_value (Ffuncall (nargs
+ 1, newargs
));
419 module_intern (emacs_env
*env
, const char *name
)
421 MODULE_FUNCTION_BEGIN (module_nil
);
422 return lisp_to_value (intern (name
));
426 module_type_of (emacs_env
*env
, emacs_value value
)
428 MODULE_FUNCTION_BEGIN (module_nil
);
429 return lisp_to_value (Ftype_of (value_to_lisp (value
)));
433 module_is_not_nil (emacs_env
*env
, emacs_value value
)
435 check_main_thread ();
436 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
438 return ! NILP (value_to_lisp (value
));
442 module_eq (emacs_env
*env
, emacs_value a
, emacs_value b
)
444 check_main_thread ();
445 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
447 return EQ (value_to_lisp (a
), value_to_lisp (b
));
451 module_extract_integer (emacs_env
*env
, emacs_value n
)
453 MODULE_FUNCTION_BEGIN (0);
454 Lisp_Object l
= value_to_lisp (n
);
457 module_wrong_type (env
, Qintegerp
, l
);
464 module_make_integer (emacs_env
*env
, intmax_t n
)
466 MODULE_FUNCTION_BEGIN (module_nil
);
467 if (! (MOST_NEGATIVE_FIXNUM
<= n
&& n
<= MOST_POSITIVE_FIXNUM
))
469 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
472 return lisp_to_value (make_number (n
));
476 module_extract_float (emacs_env
*env
, emacs_value f
)
478 MODULE_FUNCTION_BEGIN (0);
479 Lisp_Object lisp
= value_to_lisp (f
);
482 module_wrong_type (env
, 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 if (! STRINGP (lisp_str
))
503 module_wrong_type (env
, Qstringp
, lisp_str
);
507 Lisp_Object lisp_str_utf8
= ENCODE_UTF_8 (lisp_str
);
508 ptrdiff_t raw_size
= SBYTES (lisp_str_utf8
);
509 if (raw_size
== PTRDIFF_MAX
)
511 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
514 ptrdiff_t required_buf_size
= raw_size
+ 1;
516 eassert (length
!= NULL
);
520 *length
= required_buf_size
;
524 eassert (*length
>= 0);
526 if (*length
< required_buf_size
)
528 *length
= required_buf_size
;
529 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, Qnil
);
533 *length
= required_buf_size
;
534 memcpy (buffer
, SDATA (lisp_str_utf8
), raw_size
+ 1);
540 module_make_string (emacs_env
*env
, const char *str
, ptrdiff_t length
)
542 MODULE_FUNCTION_BEGIN (module_nil
);
543 if (length
> STRING_BYTES_BOUND
)
545 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
548 Lisp_Object lstr
= make_unibyte_string (str
, length
);
549 return lisp_to_value (code_convert_string_norecord (lstr
, Qutf_8
, false));
553 module_make_user_ptr (emacs_env
*env
, emacs_finalizer_function fin
, void *ptr
)
555 MODULE_FUNCTION_BEGIN (module_nil
);
556 return lisp_to_value (make_user_ptr (fin
, ptr
));
560 module_get_user_ptr (emacs_env
*env
, emacs_value uptr
)
562 MODULE_FUNCTION_BEGIN (NULL
);
563 Lisp_Object lisp
= value_to_lisp (uptr
);
564 if (! USER_PTRP (lisp
))
566 module_wrong_type (env
, Quser_ptr
, lisp
);
569 return XUSER_PTR (lisp
)->p
;
573 module_set_user_ptr (emacs_env
*env
, emacs_value uptr
, void *ptr
)
575 /* FIXME: This function should return bool because it can fail. */
576 MODULE_FUNCTION_BEGIN ();
577 check_main_thread ();
578 if (module_non_local_exit_check (env
) != emacs_funcall_exit_return
)
580 Lisp_Object lisp
= value_to_lisp (uptr
);
581 if (! USER_PTRP (lisp
))
582 module_wrong_type (env
, Quser_ptr
, lisp
);
583 XUSER_PTR (lisp
)->p
= ptr
;
586 static emacs_finalizer_function
587 module_get_user_finalizer (emacs_env
*env
, emacs_value uptr
)
589 MODULE_FUNCTION_BEGIN (NULL
);
590 Lisp_Object lisp
= value_to_lisp (uptr
);
591 if (! USER_PTRP (lisp
))
593 module_wrong_type (env
, Quser_ptr
, lisp
);
596 return XUSER_PTR (lisp
)->finalizer
;
600 module_set_user_finalizer (emacs_env
*env
, emacs_value uptr
,
601 emacs_finalizer_function fin
)
603 /* FIXME: This function should return bool because it can fail. */
604 MODULE_FUNCTION_BEGIN ();
605 Lisp_Object lisp
= value_to_lisp (uptr
);
606 if (! USER_PTRP (lisp
))
607 module_wrong_type (env
, Quser_ptr
, lisp
);
608 XUSER_PTR (lisp
)->finalizer
= fin
;
612 module_vec_set (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
, emacs_value val
)
614 /* FIXME: This function should return bool because it can fail. */
615 MODULE_FUNCTION_BEGIN ();
616 Lisp_Object lvec
= value_to_lisp (vec
);
617 if (! VECTORP (lvec
))
619 module_wrong_type (env
, Qvectorp
, lvec
);
622 if (! (0 <= i
&& i
< ASIZE (lvec
)))
624 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
625 module_args_out_of_range (env
, lvec
, make_number (i
));
627 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
630 ASET (lvec
, i
, value_to_lisp (val
));
634 module_vec_get (emacs_env
*env
, emacs_value vec
, ptrdiff_t i
)
636 MODULE_FUNCTION_BEGIN (module_nil
);
637 Lisp_Object lvec
= value_to_lisp (vec
);
638 if (! VECTORP (lvec
))
640 module_wrong_type (env
, Qvectorp
, lvec
);
643 if (! (0 <= i
&& i
< ASIZE (lvec
)))
645 if (MOST_NEGATIVE_FIXNUM
<= i
&& i
<= MOST_POSITIVE_FIXNUM
)
646 module_args_out_of_range (env
, lvec
, make_number (i
));
648 module_non_local_exit_signal_1 (env
, Qoverflow_error
, Qnil
);
651 return lisp_to_value (AREF (lvec
, i
));
655 module_vec_size (emacs_env
*env
, emacs_value vec
)
657 /* FIXME: Return a sentinel value (e.g., -1) on error. */
658 MODULE_FUNCTION_BEGIN (0);
659 Lisp_Object lvec
= value_to_lisp (vec
);
660 if (! VECTORP (lvec
))
662 module_wrong_type (env
, Qvectorp
, lvec
);
671 DEFUN ("module-load", Fmodule_load
, Smodule_load
, 1, 1, 0,
672 doc
: /* Load module FILE. */)
675 dynlib_handle_ptr handle
;
676 emacs_init_function module_init
;
680 handle
= dynlib_open (SSDATA (file
));
682 error ("Cannot load file %s: %s", SDATA (file
), dynlib_error ());
684 gpl_sym
= dynlib_sym (handle
, "plugin_is_GPL_compatible");
686 error ("Module %s is not GPL compatible", SDATA (file
));
688 module_init
= (emacs_init_function
) dynlib_func (handle
, "emacs_module_init");
690 error ("Module %s does not have an init function.", SDATA (file
));
692 struct emacs_runtime_private rt
; /* Includes the public emacs_env. */
693 struct emacs_env_private priv
;
694 initialize_environment (&rt
.pub
, &priv
);
695 struct emacs_runtime pub
=
698 .private_members
= &rt
,
699 .get_environment
= module_get_environment
701 int r
= module_init (&pub
);
702 finalize_environment (&priv
);
706 if (! (MOST_NEGATIVE_FIXNUM
<= r
&& r
<= MOST_POSITIVE_FIXNUM
))
707 xsignal0 (Qoverflow_error
);
708 xsignal2 (Qmodule_load_failed
, file
, make_number (r
));
714 DEFUN ("internal--module-call", Finternal_module_call
, Sinternal_module_call
, 1, MANY
, 0,
715 doc
: /* Internal function to call a module function.
716 ENVOBJ is a save pointer to a module_fun_env structure.
717 ARGLIST is a list of arguments passed to SUBRPTR.
718 usage: (module-call ENVOBJ &rest ARGLIST) */)
719 (ptrdiff_t nargs
, Lisp_Object
*arglist
)
721 Lisp_Object envobj
= arglist
[0];
722 /* FIXME: Rather than use a save_value, we should create a new object type.
723 Making save_value visible to Lisp is wrong. */
724 CHECK_TYPE (SAVE_VALUEP (envobj
), Qsave_value_p
, envobj
);
725 struct Lisp_Save_Value
*save_value
= XSAVE_VALUE (envobj
);
726 CHECK_TYPE (save_type (save_value
, 0) == SAVE_POINTER
, Qsave_pointer_p
, envobj
);
727 /* FIXME: We have no reason to believe that XSAVE_POINTER (envobj, 0)
728 is a module_fun_env pointer. If some other part of Emacs also
729 exports save_value objects to Elisp, than we may be getting here this
730 other kind of save_value which will likely hold something completely
731 different in this field. */
732 struct module_fun_env
*envptr
= XSAVE_POINTER (envobj
, 0);
733 EMACS_INT len
= nargs
- 1;
734 eassume (0 <= envptr
->min_arity
);
735 if (! (envptr
->min_arity
<= len
736 && len
<= (envptr
->max_arity
< 0 ? PTRDIFF_MAX
: envptr
->max_arity
)))
737 xsignal2 (Qwrong_number_of_arguments
, module_format_fun_env (envptr
),
741 struct emacs_env_private priv
;
742 initialize_environment (&pub
, &priv
);
747 args
= (emacs_value
*) arglist
+ 1;
750 args
= SAFE_ALLOCA (len
* sizeof *args
);
751 for (ptrdiff_t i
= 0; i
< len
; i
++)
752 args
[i
] = lisp_to_value (arglist
[i
+ 1]);
755 emacs_value ret
= envptr
->subr (&pub
, len
, args
, envptr
->data
);
758 eassert (&priv
== pub
.private_members
);
760 switch (priv
.pending_non_local_exit
)
762 case emacs_funcall_exit_return
:
763 finalize_environment (&priv
);
764 return value_to_lisp (ret
);
765 case emacs_funcall_exit_signal
:
767 Lisp_Object symbol
= priv
.non_local_exit_symbol
;
768 Lisp_Object data
= priv
.non_local_exit_data
;
769 finalize_environment (&priv
);
770 xsignal (symbol
, data
);
772 case emacs_funcall_exit_throw
:
774 Lisp_Object tag
= priv
.non_local_exit_symbol
;
775 Lisp_Object value
= priv
.non_local_exit_data
;
776 finalize_environment (&priv
);
785 /* Helper functions. */
788 check_main_thread (void)
791 eassert (pthread_equal (pthread_self (), main_thread
));
792 #elif defined WINDOWSNT
793 eassert (GetCurrentThreadId () == main_thread
);
798 module_non_local_exit_signal_1 (emacs_env
*env
, Lisp_Object sym
,
801 struct emacs_env_private
*p
= env
->private_members
;
802 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
804 p
->pending_non_local_exit
= emacs_funcall_exit_signal
;
805 p
->non_local_exit_symbol
= sym
;
806 p
->non_local_exit_data
= data
;
811 module_non_local_exit_throw_1 (emacs_env
*env
, Lisp_Object tag
,
814 struct emacs_env_private
*p
= env
->private_members
;
815 if (p
->pending_non_local_exit
== emacs_funcall_exit_return
)
817 p
->pending_non_local_exit
= emacs_funcall_exit_throw
;
818 p
->non_local_exit_symbol
= tag
;
819 p
->non_local_exit_data
= value
;
823 /* Module version of `wrong_type_argument'. */
825 module_wrong_type (emacs_env
*env
, Lisp_Object predicate
, Lisp_Object value
)
827 module_non_local_exit_signal_1 (env
, Qwrong_type_argument
,
828 list2 (predicate
, value
));
831 /* Signal an out-of-memory condition to the caller. */
833 module_out_of_memory (emacs_env
*env
)
835 /* TODO: Reimplement this so it works even if memory-signal-data has
837 module_non_local_exit_signal_1 (env
, XCAR (Vmemory_signal_data
),
838 XCDR (Vmemory_signal_data
));
841 /* Signal arguments are out of range. */
843 module_args_out_of_range (emacs_env
*env
, Lisp_Object a1
, Lisp_Object a2
)
845 module_non_local_exit_signal_1 (env
, Qargs_out_of_range
, list2 (a1
, a2
));
849 /* Value conversion. */
851 /* Unique Lisp_Object used to mark those emacs_values which are really
852 just containers holding a Lisp_Object that does not fit as an emacs_value,
853 either because it is an integer out of range, or is not properly aligned.
854 Used only if !plain_values. */
855 static Lisp_Object ltv_mark
;
857 /* Convert V to the corresponding internal object O, such that
858 V == lisp_to_value_bits (O). Never fails. */
860 value_to_lisp_bits (emacs_value v
)
862 intptr_t i
= (intptr_t) v
;
863 if (plain_values
|| USE_LSB_TAG
)
866 /* With wide EMACS_INT and when tag bits are the most significant,
867 reassembling integers differs from reassembling pointers in two
868 ways. First, save and restore the least-significant bits of the
869 integer, not the most-significant bits. Second, sign-extend the
870 integer when restoring, but zero-extend pointers because that
871 makes TAG_PTR faster. */
873 EMACS_UINT tag
= i
& (GCALIGNMENT
- 1);
874 EMACS_UINT untagged
= i
- tag
;
879 bool negative
= tag
& 1;
880 EMACS_UINT sign_extension
881 = negative
? VALMASK
& ~(INTPTR_MAX
>> INTTYPEBITS
): 0;
883 intptr_t all_but_sign
= u
>> GCTYPEBITS
;
884 untagged
= sign_extension
+ all_but_sign
;
889 return XIL ((tag
<< VALBITS
) + untagged
);
892 /* If V was computed from lisp_to_value (O), then return O.
893 Exits non-locally only if the stack overflows. */
895 value_to_lisp (emacs_value v
)
897 Lisp_Object o
= value_to_lisp_bits (v
);
898 if (! plain_values
&& CONSP (o
) && EQ (XCDR (o
), ltv_mark
))
903 /* Attempt to convert O to an emacs_value. Do not do any checking or
904 or allocate any storage; the caller should prevent or detect
905 any resulting bit pattern that is not a valid emacs_value. */
907 lisp_to_value_bits (Lisp_Object o
)
909 EMACS_UINT u
= XLI (o
);
911 /* Compress U into the space of a pointer, possibly losing information. */
912 uintptr_t p
= (plain_values
|| USE_LSB_TAG
914 : (INTEGERP (o
) ? u
<< VALBITS
: u
& VALMASK
) + XTYPE (o
));
915 return (emacs_value
) p
;
918 #ifndef HAVE_STRUCT_ATTRIBUTE_ALIGNED
919 enum { HAVE_STRUCT_ATTRIBUTE_ALIGNED
= 0 };
922 /* Convert O to an emacs_value. Allocate storage if needed; this can
923 signal if memory is exhausted. Must be an injective function. */
925 lisp_to_value (Lisp_Object o
)
927 emacs_value v
= lisp_to_value_bits (o
);
929 if (! EQ (o
, value_to_lisp_bits (v
)))
931 /* Package the incompressible object pointer inside a pair
932 that is compressible. */
933 Lisp_Object pair
= Fcons (o
, ltv_mark
);
935 if (! HAVE_STRUCT_ATTRIBUTE_ALIGNED
)
937 /* Keep calling Fcons until it returns a compressible pair.
938 This shouldn't take long. */
939 while ((intptr_t) XCONS (pair
) & (GCALIGNMENT
- 1))
940 pair
= Fcons (o
, pair
);
942 /* Plant the mark. The garbage collector will eventually
943 reclaim any just-allocated incompressible pairs. */
944 XSETCDR (pair
, ltv_mark
);
947 v
= (emacs_value
) ((intptr_t) XCONS (pair
) + Lisp_Cons
);
950 eassert (EQ (o
, value_to_lisp (v
)));
955 /* Environment lifetime management. */
957 /* Must be called before the environment can be used. */
959 initialize_environment (emacs_env
*env
, struct emacs_env_private
*priv
)
961 priv
->pending_non_local_exit
= emacs_funcall_exit_return
;
962 env
->size
= sizeof *env
;
963 env
->private_members
= priv
;
964 env
->make_global_ref
= module_make_global_ref
;
965 env
->free_global_ref
= module_free_global_ref
;
966 env
->non_local_exit_check
= module_non_local_exit_check
;
967 env
->non_local_exit_clear
= module_non_local_exit_clear
;
968 env
->non_local_exit_get
= module_non_local_exit_get
;
969 env
->non_local_exit_signal
= module_non_local_exit_signal
;
970 env
->non_local_exit_throw
= module_non_local_exit_throw
;
971 env
->make_function
= module_make_function
;
972 env
->funcall
= module_funcall
;
973 env
->intern
= module_intern
;
974 env
->type_of
= module_type_of
;
975 env
->is_not_nil
= module_is_not_nil
;
977 env
->extract_integer
= module_extract_integer
;
978 env
->make_integer
= module_make_integer
;
979 env
->extract_float
= module_extract_float
;
980 env
->make_float
= module_make_float
;
981 env
->copy_string_contents
= module_copy_string_contents
;
982 env
->make_string
= module_make_string
;
983 env
->make_user_ptr
= module_make_user_ptr
;
984 env
->get_user_ptr
= module_get_user_ptr
;
985 env
->set_user_ptr
= module_set_user_ptr
;
986 env
->get_user_finalizer
= module_get_user_finalizer
;
987 env
->set_user_finalizer
= module_set_user_finalizer
;
988 env
->vec_set
= module_vec_set
;
989 env
->vec_get
= module_vec_get
;
990 env
->vec_size
= module_vec_size
;
991 Vmodule_environments
= Fcons (make_save_ptr (env
), Vmodule_environments
);
994 /* Must be called before the lifetime of the environment object
997 finalize_environment (struct emacs_env_private
*env
)
999 Vmodule_environments
= XCDR (Vmodule_environments
);
1003 /* Non-local exit handling. */
1005 /* Must be called after setting up a handler immediately before
1006 returning from the function. See the comments in lisp.h and the
1007 code in eval.c for details. The macros below arrange for this
1008 function to be called automatically. DUMMY is ignored. */
1010 module_reset_handlerlist (const int *dummy
)
1012 handlerlist
= handlerlist
->next
;
1015 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
1016 stored in the environment. Set the pending non-local exit flag. */
1018 module_handle_signal (emacs_env
*env
, Lisp_Object err
)
1020 module_non_local_exit_signal_1 (env
, XCAR (err
), XCDR (err
));
1023 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
1024 stored in the environment. Set the pending non-local exit flag. */
1026 module_handle_throw (emacs_env
*env
, Lisp_Object tag_val
)
1028 module_non_local_exit_throw_1 (env
, XCAR (tag_val
), XCDR (tag_val
));
1032 /* Function environments. */
1034 /* Return a string object that contains a user-friendly
1035 representation of the function environment. */
1037 module_format_fun_env (const struct module_fun_env
*env
)
1039 /* Try to print a function name if possible. */
1040 const char *path
, *sym
;
1041 static char const noaddr_format
[] = "#<module function at %p>";
1042 char buffer
[sizeof noaddr_format
+ INT_STRLEN_BOUND (intptr_t) + 256];
1044 ptrdiff_t bufsize
= sizeof buffer
;
1046 = (dynlib_addr (env
->subr
, &path
, &sym
)
1047 ? exprintf (&buf
, &bufsize
, buffer
, -1,
1048 "#<module function %s from %s>", sym
, path
)
1049 : sprintf (buffer
, noaddr_format
, env
->subr
));
1050 Lisp_Object unibyte_result
= make_unibyte_string (buffer
, size
);
1053 return code_convert_string_norecord (unibyte_result
, Qutf_8
, false);
1057 /* Segment initializer. */
1060 syms_of_module (void)
1063 ltv_mark
= Fcons (Qnil
, Qnil
);
1064 eassert (NILP (value_to_lisp (module_nil
)));
1066 DEFSYM (Qmodule_refs_hash
, "module-refs-hash");
1067 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash
,
1068 doc
: /* Module global reference table. */);
1071 = make_hash_table (hashtest_eq
, make_number (DEFAULT_HASH_SIZE
),
1072 make_float (DEFAULT_REHASH_SIZE
),
1073 make_float (DEFAULT_REHASH_THRESHOLD
),
1075 Funintern (Qmodule_refs_hash
, Qnil
);
1077 DEFSYM (Qmodule_environments
, "module-environments");
1078 DEFVAR_LISP ("module-environments", Vmodule_environments
,
1079 doc
: /* List of active module environments. */);
1080 Vmodule_environments
= Qnil
;
1081 /* Unintern `module-environments' because it is only used
1083 Funintern (Qmodule_environments
, Qnil
);
1085 DEFSYM (Qmodule_load_failed
, "module-load-failed");
1086 Fput (Qmodule_load_failed
, Qerror_conditions
,
1087 listn (CONSTYPE_PURE
, 2, Qmodule_load_failed
, Qerror
));
1088 Fput (Qmodule_load_failed
, Qerror_message
,
1089 build_pure_c_string ("Module load failed"));
1091 DEFSYM (Qinvalid_module_call
, "invalid-module-call");
1092 Fput (Qinvalid_module_call
, Qerror_conditions
,
1093 listn (CONSTYPE_PURE
, 2, Qinvalid_module_call
, Qerror
));
1094 Fput (Qinvalid_module_call
, Qerror_message
,
1095 build_pure_c_string ("Invalid module call"));
1097 DEFSYM (Qinvalid_arity
, "invalid-arity");
1098 Fput (Qinvalid_arity
, Qerror_conditions
,
1099 listn (CONSTYPE_PURE
, 2, Qinvalid_arity
, Qerror
));
1100 Fput (Qinvalid_arity
, Qerror_message
,
1101 build_pure_c_string ("Invalid function arity"));
1103 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1104 code or modules should not access it. */
1105 Funintern (Qmodule_refs_hash
, Qnil
);
1107 DEFSYM (Qsave_value_p
, "save-value-p");
1108 DEFSYM (Qsave_pointer_p
, "save-pointer-p");
1110 defsubr (&Smodule_load
);
1112 DEFSYM (Qinternal_module_call
, "internal--module-call");
1113 defsubr (&Sinternal_module_call
);
1116 /* Unlike syms_of_module, this initializer is called even from an
1117 initialized (dumped) Emacs. */
1122 /* It is not guaranteed that dynamic initializers run in the main thread,
1123 therefore detect the main thread here. */
1125 main_thread
= pthread_self ();
1126 #elif defined WINDOWSNT
1127 /* The 'main' function already recorded the main thread's thread ID,
1128 so we need just to use it . */
1129 main_thread
= dwMainThreadId
;