]> code.delx.au - gnu-emacs/blob - src/emacs-module.c
More emacs-module.c fixes for wide ints
[gnu-emacs] / src / emacs-module.c
1 /* emacs-module.c - Module loading and runtime implementation
2
3 Copyright (C) 2015 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
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.
11
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.
16
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/>. */
19
20 #include <config.h>
21
22 #include "emacs-module.h"
23
24 #include <stdbool.h>
25 #include <stddef.h>
26 #include <stdint.h>
27 #include <stdio.h>
28 #include <string.h>
29
30 #include "lisp.h"
31 #include "dynlib.h"
32 #include "coding.h"
33 #include "verify.h"
34
35 \f
36 /* Feature tests. */
37
38 /* True if __attribute__ ((cleanup (...))) works, false otherwise. */
39 #ifdef HAVE_VAR_ATTRIBUTE_CLEANUP
40 enum { module_has_cleanup = true };
41 #else
42 enum { module_has_cleanup = false };
43 #endif
44
45 /* Handle to the main thread. Used to verify that modules call us in
46 the right thread. */
47 #ifdef HAVE_THREADS_H
48 # include <threads.h>
49 static thrd_t main_thread;
50 #elif defined HAVE_PTHREAD
51 # include <pthread.h>
52 static pthread_t main_thread;
53 #elif defined WINDOWSNT
54 #include <windows.h>
55 #include "w32term.h"
56 static DWORD main_thread;
57 #endif
58
59 \f
60 /* Private runtime and environment members. */
61
62 /* The private part of an environment stores the current non local exit state
63 and holds the `emacs_value' objects allocated during the lifetime
64 of the environment. */
65 struct emacs_env_private
66 {
67 enum emacs_funcall_exit pending_non_local_exit;
68
69 /* Dedicated storage for non-local exit symbol and data so that
70 storage is always available for them, even in an out-of-memory
71 situation. */
72 Lisp_Object non_local_exit_symbol, non_local_exit_data;
73 };
74
75 /* The private parts of an `emacs_runtime' object contain the initial
76 environment. */
77 struct emacs_runtime_private
78 {
79 /* FIXME: Ideally, we would just define "struct emacs_runtime_private"
80 * as a synonym of "emacs_env", but I don't know how to do that in C. */
81 emacs_env pub;
82 };
83 \f
84
85 /* Forward declarations. */
86
87 struct module_fun_env;
88
89 static Lisp_Object module_format_fun_env (const struct module_fun_env *);
90 static Lisp_Object value_to_lisp (emacs_value);
91 static emacs_value lisp_to_value (Lisp_Object);
92 static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *);
93 static void check_main_thread (void);
94 static void finalize_environment (struct emacs_env_private *);
95 static void initialize_environment (emacs_env *, struct emacs_env_private *priv);
96 static void module_args_out_of_range (emacs_env *, Lisp_Object, Lisp_Object);
97 static void module_handle_signal (emacs_env *, Lisp_Object);
98 static void module_handle_throw (emacs_env *, Lisp_Object);
99 static void module_non_local_exit_signal_1 (emacs_env *, Lisp_Object, Lisp_Object);
100 static void module_non_local_exit_throw_1 (emacs_env *, Lisp_Object, Lisp_Object);
101 static void module_out_of_memory (emacs_env *);
102 static void module_reset_handlerlist (const int *);
103 static void module_wrong_type (emacs_env *, Lisp_Object, Lisp_Object);
104
105 /* We used to return NULL when emacs_value was a different type from
106 Lisp_Object, but nowadays we just use Qnil instead. */
107 static emacs_value module_nil;
108 \f
109 /* Convenience macros for non-local exit handling. */
110
111 /* Emacs uses setjmp and longjmp for non-local exits, but
112 module frames cannot be skipped because they are in general
113 not prepared for long jumps (e.g., the behavior in C++ is undefined
114 if objects with nontrivial destructors would be skipped).
115 Therefore, catch all non-local exits. There are two kinds of
116 non-local exits: `signal' and `throw'. The macros in this section
117 can be used to catch both. Use macros to avoid additional variants
118 of `internal_condition_case' etc., and to avoid worrying about
119 passing information to the handler functions. */
120
121 /* Place this macro at the beginning of a function returning a number
122 or a pointer to handle non-local exits. The function must have an
123 ENV parameter. The function will return the specified value if a
124 signal or throw is caught. */
125 // TODO: Have Fsignal check for CATCHER_ALL so we only have to install
126 // one handler.
127 #define MODULE_HANDLE_NONLOCAL_EXIT(retval) \
128 MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval); \
129 MODULE_SETJMP (CATCHER_ALL, module_handle_throw, retval)
130
131 #define MODULE_SETJMP(handlertype, handlerfunc, retval) \
132 MODULE_SETJMP_1 (handlertype, handlerfunc, retval, \
133 internal_handler_##handlertype, \
134 internal_cleanup_##handlertype)
135
136 /* It is very important that pushing the handler doesn't itself raise
137 a signal. Install the cleanup only after the handler has been
138 pushed. Use __attribute__ ((cleanup)) to avoid
139 non-local-exit-prone manual cleanup.
140
141 The do-while forces uses of the macro to be followed by a semicolon.
142 This macro cannot enclose its entire body inside a do-while, as the
143 code after the macro may longjmp back into the macro, which means
144 its local variable C must stay live in later code. */
145
146 // TODO: Make backtraces work if this macros is used.
147
148 #define MODULE_SETJMP_1(handlertype, handlerfunc, retval, c, dummy) \
149 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
150 return retval; \
151 struct handler *c = push_handler_nosignal (Qt, handlertype); \
152 if (!c) \
153 { \
154 module_out_of_memory (env); \
155 return retval; \
156 } \
157 verify (module_has_cleanup); \
158 int dummy __attribute__ ((cleanup (module_reset_handlerlist))); \
159 if (sys_setjmp (c->jmp)) \
160 { \
161 (handlerfunc) (env, c->val); \
162 return retval; \
163 } \
164 do { } while (false)
165
166 \f
167 /* Function environments. */
168
169 /* A function environment is an auxiliary structure used by
170 `module_make_function' to store information about a module
171 function. It is stored in a save pointer and retrieved by
172 `internal--module-call'. Its members correspond to the arguments
173 given to `module_make_function'. */
174
175 struct module_fun_env
176 {
177 ptrdiff_t min_arity, max_arity;
178 emacs_subr subr;
179 void *data;
180 };
181
182 \f
183 /* Implementation of runtime and environment functions.
184
185 These should abide by the following rules:
186
187 1. The first argument should always be a pointer to emacs_env.
188
189 2. Each function should first call check_main_thread. Note that
190 this function is a no-op unless Emacs was built with
191 --enable-checking.
192
193 3. The very next thing each function should do is check that the
194 emacs_env object does not have a non-local exit indication set,
195 by calling module_non_local_exit_check. If that returns
196 anything but emacs_funcall_exit_return, the function should do
197 nothing and return immediately with an error indication, without
198 clobbering the existing error indication in emacs_env. This is
199 needed for correct reporting of Lisp errors to the Emacs Lisp
200 interpreter.
201
202 4. Any function that needs to call Emacs facilities, such as
203 encoding or decoding functions, or 'intern', or 'make_string',
204 should protect itself from signals and 'throw' in the called
205 Emacs functions, by placing the macro
206 MODULE_HANDLE_NONLOCAL_EXIT right after the above 2 tests.
207
208 5. Do NOT use 'eassert' for checking validity of user code in the
209 module. Instead, make those checks part of the code, and if the
210 check fails, call 'module_non_local_exit_signal_1' or
211 'module_non_local_exit_throw_1' to report the error. This is
212 because using 'eassert' in these situations will abort Emacs
213 instead of reporting the error back to Lisp, and also because
214 'eassert' is compiled to nothing in the release version. */
215
216 /* Use MODULE_FUNCTION_BEGIN to implement steps 2 through 4 for most
217 environment functions. On error it will return its argument, which
218 should be a sentinel value. */
219
220 #define MODULE_FUNCTION_BEGIN(error_retval) \
221 check_main_thread (); \
222 if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \
223 return error_retval; \
224 MODULE_HANDLE_NONLOCAL_EXIT (error_retval)
225
226 /* Catch signals and throws only if the code can actually signal or
227 throw. If checking is enabled, abort if the current thread is not
228 the Emacs main thread. */
229
230 static emacs_env *
231 module_get_environment (struct emacs_runtime *ert)
232 {
233 check_main_thread ();
234 return &ert->private_members->pub;
235 }
236
237 /* To make global refs (GC-protected global values) keep a hash that
238 maps global Lisp objects to reference counts. */
239
240 static emacs_value
241 module_make_global_ref (emacs_env *env, emacs_value ref)
242 {
243 MODULE_FUNCTION_BEGIN (module_nil);
244 struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
245 Lisp_Object new_obj = value_to_lisp (ref);
246 EMACS_UINT hashcode;
247 ptrdiff_t i = hash_lookup (h, new_obj, &hashcode);
248
249 if (i >= 0)
250 {
251 Lisp_Object value = HASH_VALUE (h, i);
252 EMACS_INT refcount = XFASTINT (value) + 1;
253 if (refcount > MOST_POSITIVE_FIXNUM)
254 {
255 module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
256 return module_nil;
257 }
258 value = make_natnum (refcount);
259 set_hash_value_slot (h, i, value);
260 }
261 else
262 {
263 hash_put (h, new_obj, make_natnum (1), hashcode);
264 }
265
266 return lisp_to_value (new_obj);
267 }
268
269 static void
270 module_free_global_ref (emacs_env *env, emacs_value ref)
271 {
272 /* TODO: This probably never signals. */
273 /* FIXME: Wait a minute. Shouldn't this function report an error if
274 the hash lookup fails? */
275 MODULE_FUNCTION_BEGIN ();
276 struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
277 Lisp_Object obj = value_to_lisp (ref);
278 EMACS_UINT hashcode;
279 ptrdiff_t i = hash_lookup (h, obj, &hashcode);
280
281 if (i >= 0)
282 {
283 Lisp_Object value = HASH_VALUE (h, i);
284 EMACS_INT refcount = XFASTINT (value) - 1;
285 if (refcount > 0)
286 {
287 value = make_natnum (refcount);
288 set_hash_value_slot (h, i, value);
289 }
290 else
291 hash_remove_from_table (h, value);
292 }
293 }
294
295 static enum emacs_funcall_exit
296 module_non_local_exit_check (emacs_env *env)
297 {
298 check_main_thread ();
299 return env->private_members->pending_non_local_exit;
300 }
301
302 static void
303 module_non_local_exit_clear (emacs_env *env)
304 {
305 check_main_thread ();
306 env->private_members->pending_non_local_exit = emacs_funcall_exit_return;
307 }
308
309 static enum emacs_funcall_exit
310 module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data)
311 {
312 check_main_thread ();
313 struct emacs_env_private *p = env->private_members;
314 if (p->pending_non_local_exit != emacs_funcall_exit_return)
315 {
316 *sym = lisp_to_value (p->non_local_exit_symbol);
317 *data = lisp_to_value (p->non_local_exit_data);
318 }
319 return p->pending_non_local_exit;
320 }
321
322 /* Like for `signal', DATA must be a list. */
323 static void
324 module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data)
325 {
326 check_main_thread ();
327 if (module_non_local_exit_check (env) == emacs_funcall_exit_return)
328 module_non_local_exit_signal_1 (env, value_to_lisp (sym),
329 value_to_lisp (data));
330 }
331
332 static void
333 module_non_local_exit_throw (emacs_env *env, emacs_value tag, emacs_value value)
334 {
335 check_main_thread ();
336 if (module_non_local_exit_check (env) == emacs_funcall_exit_return)
337 module_non_local_exit_throw_1 (env, value_to_lisp (tag),
338 value_to_lisp (value));
339 }
340
341 /* A module function is lambda function that calls
342 `internal--module-call', passing the function pointer of the module
343 function along with the module emacs_env pointer as arguments.
344
345 (function (lambda (&rest arglist)
346 (internal--module-call envobj arglist))) */
347
348 static emacs_value
349 module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity,
350 emacs_subr subr, const char *documentation,
351 void *data)
352 {
353 MODULE_FUNCTION_BEGIN (module_nil);
354
355 if (! (0 <= min_arity
356 && (max_arity < 0
357 ? max_arity == emacs_variadic_function
358 : min_arity <= max_arity)))
359 xsignal2 (Qinvalid_arity, make_number (min_arity), make_number (max_arity));
360
361 /* FIXME: This should be freed when envobj is GC'd. */
362 struct module_fun_env *envptr = xmalloc (sizeof *envptr);
363 envptr->min_arity = min_arity;
364 envptr->max_arity = max_arity;
365 envptr->subr = subr;
366 envptr->data = data;
367
368 Lisp_Object envobj = make_save_ptr (envptr);
369 Lisp_Object doc
370 = (documentation
371 ? code_convert_string_norecord (build_unibyte_string (documentation),
372 Qutf_8, false)
373 : Qnil);
374 /* FIXME: Use a bytecompiled object, or even better a subr. */
375 Lisp_Object ret = list4 (Qlambda,
376 list2 (Qand_rest, Qargs),
377 doc,
378 list4 (Qapply,
379 list2 (Qfunction, Qinternal_module_call),
380 envobj,
381 Qargs));
382
383 return lisp_to_value (ret);
384 }
385
386 static emacs_value
387 module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs,
388 emacs_value args[])
389 {
390 MODULE_FUNCTION_BEGIN (module_nil);
391
392 /* Make a new Lisp_Object array starting with the function as the
393 first arg, because that's what Ffuncall takes. */
394 Lisp_Object *newargs;
395 USE_SAFE_ALLOCA;
396 SAFE_ALLOCA_LISP (newargs, nargs + 1);
397 newargs[0] = value_to_lisp (fun);
398 for (ptrdiff_t i = 0; i < nargs; i++)
399 newargs[1 + i] = value_to_lisp (args[i]);
400 emacs_value result = lisp_to_value (Ffuncall (nargs + 1, newargs));
401 SAFE_FREE ();
402 return result;
403 }
404
405 static emacs_value
406 module_intern (emacs_env *env, const char *name)
407 {
408 MODULE_FUNCTION_BEGIN (module_nil);
409 return lisp_to_value (intern (name));
410 }
411
412 static emacs_value
413 module_type_of (emacs_env *env, emacs_value value)
414 {
415 MODULE_FUNCTION_BEGIN (module_nil);
416 return lisp_to_value (Ftype_of (value_to_lisp (value)));
417 }
418
419 static bool
420 module_is_not_nil (emacs_env *env, emacs_value value)
421 {
422 check_main_thread ();
423 if (module_non_local_exit_check (env) != emacs_funcall_exit_return)
424 return false;
425 return ! NILP (value_to_lisp (value));
426 }
427
428 static bool
429 module_eq (emacs_env *env, emacs_value a, emacs_value b)
430 {
431 check_main_thread ();
432 if (module_non_local_exit_check (env) != emacs_funcall_exit_return)
433 return false;
434 return EQ (value_to_lisp (a), value_to_lisp (b));
435 }
436
437 static intmax_t
438 module_extract_integer (emacs_env *env, emacs_value n)
439 {
440 MODULE_FUNCTION_BEGIN (0);
441 Lisp_Object l = value_to_lisp (n);
442 if (! INTEGERP (l))
443 {
444 module_wrong_type (env, Qintegerp, l);
445 return 0;
446 }
447 return XINT (l);
448 }
449
450 static emacs_value
451 module_make_integer (emacs_env *env, intmax_t n)
452 {
453 MODULE_FUNCTION_BEGIN (module_nil);
454 if (! (MOST_NEGATIVE_FIXNUM <= n && n <= MOST_POSITIVE_FIXNUM))
455 {
456 module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
457 return module_nil;
458 }
459 return lisp_to_value (make_number (n));
460 }
461
462 static double
463 module_extract_float (emacs_env *env, emacs_value f)
464 {
465 MODULE_FUNCTION_BEGIN (0);
466 Lisp_Object lisp = value_to_lisp (f);
467 if (! FLOATP (lisp))
468 {
469 module_wrong_type (env, Qfloatp, lisp);
470 return 0;
471 }
472 return XFLOAT_DATA (lisp);
473 }
474
475 static emacs_value
476 module_make_float (emacs_env *env, double d)
477 {
478 MODULE_FUNCTION_BEGIN (module_nil);
479 return lisp_to_value (make_float (d));
480 }
481
482 static bool
483 module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer,
484 ptrdiff_t *length)
485 {
486 MODULE_FUNCTION_BEGIN (false);
487 Lisp_Object lisp_str = value_to_lisp (value);
488 if (! STRINGP (lisp_str))
489 {
490 module_wrong_type (env, Qstringp, lisp_str);
491 return false;
492 }
493
494 Lisp_Object lisp_str_utf8 = ENCODE_UTF_8 (lisp_str);
495 ptrdiff_t raw_size = SBYTES (lisp_str_utf8);
496 if (raw_size == PTRDIFF_MAX)
497 {
498 module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
499 return false;
500 }
501 ptrdiff_t required_buf_size = raw_size + 1;
502
503 eassert (length != NULL);
504
505 if (buffer == NULL)
506 {
507 *length = required_buf_size;
508 return true;
509 }
510
511 eassert (*length >= 0);
512
513 if (*length < required_buf_size)
514 {
515 *length = required_buf_size;
516 module_non_local_exit_signal_1 (env, Qargs_out_of_range, Qnil);
517 return false;
518 }
519
520 *length = required_buf_size;
521 memcpy (buffer, SDATA (lisp_str_utf8), raw_size + 1);
522
523 return true;
524 }
525
526 static emacs_value
527 module_make_string (emacs_env *env, const char *str, ptrdiff_t length)
528 {
529 MODULE_FUNCTION_BEGIN (module_nil);
530 if (length > STRING_BYTES_BOUND)
531 {
532 module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
533 return module_nil;
534 }
535 Lisp_Object lstr = make_unibyte_string (str, length);
536 return lisp_to_value (code_convert_string_norecord (lstr, Qutf_8, false));
537 }
538
539 static emacs_value
540 module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr)
541 {
542 MODULE_FUNCTION_BEGIN (module_nil);
543 return lisp_to_value (make_user_ptr (fin, ptr));
544 }
545
546 static void *
547 module_get_user_ptr (emacs_env *env, emacs_value uptr)
548 {
549 MODULE_FUNCTION_BEGIN (NULL);
550 Lisp_Object lisp = value_to_lisp (uptr);
551 if (! USER_PTRP (lisp))
552 {
553 module_wrong_type (env, Quser_ptr, lisp);
554 return NULL;
555 }
556 return XUSER_PTR (lisp)->p;
557 }
558
559 static void
560 module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr)
561 {
562 // FIXME: This function should return bool because it can fail.
563 MODULE_FUNCTION_BEGIN ();
564 check_main_thread ();
565 if (module_non_local_exit_check (env) != emacs_funcall_exit_return)
566 return;
567 Lisp_Object lisp = value_to_lisp (uptr);
568 if (! USER_PTRP (lisp))
569 module_wrong_type (env, Quser_ptr, lisp);
570 XUSER_PTR (lisp)->p = ptr;
571 }
572
573 static emacs_finalizer_function
574 module_get_user_finalizer (emacs_env *env, emacs_value uptr)
575 {
576 MODULE_FUNCTION_BEGIN (NULL);
577 Lisp_Object lisp = value_to_lisp (uptr);
578 if (! USER_PTRP (lisp))
579 {
580 module_wrong_type (env, Quser_ptr, lisp);
581 return NULL;
582 }
583 return XUSER_PTR (lisp)->finalizer;
584 }
585
586 static void
587 module_set_user_finalizer (emacs_env *env, emacs_value uptr,
588 emacs_finalizer_function fin)
589 {
590 // FIXME: This function should return bool because it can fail.
591 MODULE_FUNCTION_BEGIN ();
592 Lisp_Object lisp = value_to_lisp (uptr);
593 if (! USER_PTRP (lisp))
594 module_wrong_type (env, Quser_ptr, lisp);
595 XUSER_PTR (lisp)->finalizer = fin;
596 }
597
598 static void
599 module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val)
600 {
601 // FIXME: This function should return bool because it can fail.
602 MODULE_FUNCTION_BEGIN ();
603 Lisp_Object lvec = value_to_lisp (vec);
604 if (! VECTORP (lvec))
605 {
606 module_wrong_type (env, Qvectorp, lvec);
607 return;
608 }
609 if (! (0 <= i && i < ASIZE (lvec)))
610 {
611 if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM)
612 module_args_out_of_range (env, lvec, make_number (i));
613 else
614 module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
615 return;
616 }
617 ASET (lvec, i, value_to_lisp (val));
618 }
619
620 static emacs_value
621 module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i)
622 {
623 MODULE_FUNCTION_BEGIN (module_nil);
624 Lisp_Object lvec = value_to_lisp (vec);
625 if (! VECTORP (lvec))
626 {
627 module_wrong_type (env, Qvectorp, lvec);
628 return module_nil;
629 }
630 if (! (0 <= i && i < ASIZE (lvec)))
631 {
632 if (MOST_NEGATIVE_FIXNUM <= i && i <= MOST_POSITIVE_FIXNUM)
633 module_args_out_of_range (env, lvec, make_number (i));
634 else
635 module_non_local_exit_signal_1 (env, Qoverflow_error, Qnil);
636 return module_nil;
637 }
638 return lisp_to_value (AREF (lvec, i));
639 }
640
641 static ptrdiff_t
642 module_vec_size (emacs_env *env, emacs_value vec)
643 {
644 // FIXME: Return a sentinel value (e.g., -1) on error.
645 MODULE_FUNCTION_BEGIN (0);
646 Lisp_Object lvec = value_to_lisp (vec);
647 if (! VECTORP (lvec))
648 {
649 module_wrong_type (env, Qvectorp, lvec);
650 return 0;
651 }
652 return ASIZE (lvec);
653 }
654
655 \f
656 /* Subroutines. */
657
658 DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0,
659 doc: /* Load module FILE. */)
660 (Lisp_Object file)
661 {
662 dynlib_handle_ptr handle;
663 emacs_init_function module_init;
664 void *gpl_sym;
665
666 CHECK_STRING (file);
667 handle = dynlib_open (SSDATA (file));
668 if (!handle)
669 error ("Cannot load file %s: %s", SDATA (file), dynlib_error ());
670
671 gpl_sym = dynlib_sym (handle, "plugin_is_GPL_compatible");
672 if (!gpl_sym)
673 error ("Module %s is not GPL compatible", SDATA (file));
674
675 module_init = (emacs_init_function) dynlib_func (handle, "emacs_module_init");
676 if (!module_init)
677 error ("Module %s does not have an init function.", SDATA (file));
678
679 struct emacs_runtime_private rt; /* Includes the public emacs_env. */
680 struct emacs_env_private priv;
681 initialize_environment (&rt.pub, &priv);
682 struct emacs_runtime pub =
683 {
684 .size = sizeof pub,
685 .private_members = &rt,
686 .get_environment = module_get_environment
687 };
688 int r = module_init (&pub);
689 finalize_environment (&priv);
690
691 if (r != 0)
692 {
693 if (! (MOST_NEGATIVE_FIXNUM <= r && r <= MOST_POSITIVE_FIXNUM))
694 xsignal0 (Qoverflow_error);
695 xsignal2 (Qmodule_load_failed, file, make_number (r));
696 }
697
698 return Qt;
699 }
700
701 DEFUN ("internal--module-call", Finternal_module_call, Sinternal_module_call, 1, MANY, 0,
702 doc: /* Internal function to call a module function.
703 ENVOBJ is a save pointer to a module_fun_env structure.
704 ARGLIST is a list of arguments passed to SUBRPTR.
705 usage: (module-call ENVOBJ &rest ARGLIST) */)
706 (ptrdiff_t nargs, Lisp_Object *arglist)
707 {
708 Lisp_Object envobj = arglist[0];
709 /* FIXME: Rather than use a save_value, we should create a new object type.
710 Making save_value visible to Lisp is wrong. */
711 CHECK_TYPE (SAVE_VALUEP (envobj), Qsave_value_p, envobj);
712 struct Lisp_Save_Value *save_value = XSAVE_VALUE (envobj);
713 CHECK_TYPE (save_type (save_value, 0) == SAVE_POINTER, Qsave_pointer_p, envobj);
714 /* FIXME: We have no reason to believe that XSAVE_POINTER (envobj, 0)
715 is a module_fun_env pointer. If some other part of Emacs also
716 exports save_value objects to Elisp, than we may be getting here this
717 other kind of save_value which will likely hold something completely
718 different in this field. */
719 struct module_fun_env *envptr = XSAVE_POINTER (envobj, 0);
720 EMACS_INT len = nargs - 1;
721 eassume (0 <= envptr->min_arity);
722 if (! (envptr->min_arity <= len
723 && len <= (envptr->max_arity < 0 ? PTRDIFF_MAX : envptr->max_arity)))
724 xsignal2 (Qwrong_number_of_arguments, module_format_fun_env (envptr),
725 make_number (len));
726
727 emacs_env pub;
728 struct emacs_env_private priv;
729 initialize_environment (&pub, &priv);
730
731 USE_SAFE_ALLOCA;
732 #ifdef WIDE_EMACS_INT
733 emacs_value *args = SAFE_ALLOCA (len * sizeof *args);
734
735 for (ptrdiff_t i = 0; i < len; i++)
736 args[i] = lisp_to_value (arglist[i + 1]);
737 #else
738 /* BEWARE! Here, we assume that Lisp_Object and
739 * emacs_value have the exact same representation. */
740 emacs_value *args = (emacs_value*) arglist + 1;
741 #endif
742
743 emacs_value ret = envptr->subr (&pub, len, args, envptr->data);
744 SAFE_FREE();
745
746 eassert (&priv == pub.private_members);
747
748 switch (priv.pending_non_local_exit)
749 {
750 case emacs_funcall_exit_return:
751 finalize_environment (&priv);
752 return value_to_lisp (ret);
753 case emacs_funcall_exit_signal:
754 {
755 Lisp_Object symbol = priv.non_local_exit_symbol;
756 Lisp_Object data = priv.non_local_exit_data;
757 finalize_environment (&priv);
758 xsignal (symbol, data);
759 }
760 case emacs_funcall_exit_throw:
761 {
762 Lisp_Object tag = priv.non_local_exit_symbol;
763 Lisp_Object value = priv.non_local_exit_data;
764 finalize_environment (&priv);
765 Fthrow (tag, value);
766 }
767 default:
768 eassume (false);
769 }
770 }
771
772 \f
773 /* Helper functions. */
774
775 static void
776 check_main_thread (void)
777 {
778 #ifdef HAVE_THREADS_H
779 eassert (thrd_equal (thdr_current (), main_thread));
780 #elif defined HAVE_PTHREAD
781 eassert (pthread_equal (pthread_self (), main_thread));
782 #elif defined WINDOWSNT
783 eassert (GetCurrentThreadId () == main_thread);
784 #endif
785 }
786
787 static void
788 module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym,
789 Lisp_Object data)
790 {
791 struct emacs_env_private *p = env->private_members;
792 if (p->pending_non_local_exit == emacs_funcall_exit_return)
793 {
794 p->pending_non_local_exit = emacs_funcall_exit_signal;
795 p->non_local_exit_symbol = sym;
796 p->non_local_exit_data = data;
797 }
798 }
799
800 static void
801 module_non_local_exit_throw_1 (emacs_env *env, Lisp_Object tag,
802 Lisp_Object value)
803 {
804 struct emacs_env_private *p = env->private_members;
805 if (p->pending_non_local_exit == emacs_funcall_exit_return)
806 {
807 p->pending_non_local_exit = emacs_funcall_exit_throw;
808 p->non_local_exit_symbol = tag;
809 p->non_local_exit_data = value;
810 }
811 }
812
813 /* Module version of `wrong_type_argument'. */
814 static void
815 module_wrong_type (emacs_env *env, Lisp_Object predicate, Lisp_Object value)
816 {
817 module_non_local_exit_signal_1 (env, Qwrong_type_argument,
818 list2 (predicate, value));
819 }
820
821 /* Signal an out-of-memory condition to the caller. */
822 static void
823 module_out_of_memory (emacs_env *env)
824 {
825 /* TODO: Reimplement this so it works even if memory-signal-data has
826 been modified. */
827 module_non_local_exit_signal_1 (env, XCAR (Vmemory_signal_data),
828 XCDR (Vmemory_signal_data));
829 }
830
831 /* Signal arguments are out of range. */
832 static void
833 module_args_out_of_range (emacs_env *env, Lisp_Object a1, Lisp_Object a2)
834 {
835 module_non_local_exit_signal_1 (env, Qargs_out_of_range, list2 (a1, a2));
836 }
837
838 \f
839 /* Value conversion. */
840
841 #ifdef WIDE_EMACS_INT
842 /* Unique Lisp_Object used to mark those emacs_values which are really
843 just containers holding a Lisp_Object that's too large for emacs_value. */
844 static Lisp_Object ltv_mark;
845 #endif
846
847 /* Convert an `emacs_value' to the corresponding internal object.
848 Never fails. */
849 static Lisp_Object
850 value_to_lisp (emacs_value v)
851 {
852 #ifdef WIDE_EMACS_INT
853 uintptr_t tmp = (uintptr_t)v;
854 unsigned tag = tmp & ((1 << GCTYPEBITS) - 1);
855 Lisp_Object o;
856 switch (tag)
857 {
858 case_Lisp_Int:
859 o = make_lisp_ptr ((void *)((tmp - tag) >> GCTYPEBITS), tag); break;
860 default:
861 o = make_lisp_ptr ((void *)(tmp - tag), tag);
862 }
863 /* eassert (lisp_to_value (o) == v); */
864 if (CONSP (o) && EQ (XCDR (o), ltv_mark))
865 return XCAR (o);
866 else
867 return o;
868 #else
869 Lisp_Object o = XIL ((EMACS_INT) v);
870 /* Check the assumption made elsewhere that Lisp_Object and emacs_value
871 share the same underlying bit representation. */
872 eassert (EQ (o, *(Lisp_Object*)&v));
873 /* eassert (lisp_to_value (o) == v); */
874 return o;
875 #endif
876 }
877
878 /* Convert an internal object to an `emacs_value'. Allocate storage
879 from the environment; return NULL if allocation fails. */
880 static emacs_value
881 lisp_to_value (Lisp_Object o)
882 {
883 #ifdef WIDE_EMACS_INT
884 /* We need to compress the EMACS_INT into the space of a pointer.
885 For most objects, this is just a question of shuffling the tags around.
886 But in some cases (e.g. large integers) this can't be done, so we
887 should allocate a special object to hold the extra data. */
888 Lisp_Object orig = o;
889 int tag = XTYPE (o);
890 switch (tag)
891 {
892 case_Lisp_Int:
893 {
894 EMACS_UINT ui = (EMACS_UINT) XINT (o);
895 if (ui <= (SIZE_MAX >> GCTYPEBITS))
896 {
897 uintptr_t uv = (uintptr_t) ui;
898 emacs_value v = (emacs_value) ((uv << GCTYPEBITS) | tag);
899 eassert (EQ (value_to_lisp (v), o));
900 return v;
901 }
902 else
903 {
904 o = Fcons (o, ltv_mark);
905 tag = Lisp_Cons;
906 }
907 } /* FALLTHROUGH */
908 default:
909 {
910 void *ptr = XUNTAG (o, tag);
911 if (((uintptr_t)ptr) & ((1 << GCTYPEBITS) - 1))
912 { /* Pointer is not properly aligned! */
913 eassert (!CONSP (o)); /* Cons cells have to always be aligned! */
914 o = Fcons (o, ltv_mark);
915 ptr = XUNTAG (o, tag);
916 }
917 emacs_value v = (emacs_value) (((uintptr_t) ptr) | tag);
918 eassert (EQ (value_to_lisp (v), orig));
919 return v;
920 }
921 }
922 #else
923 emacs_value v = (emacs_value) XLI (o);
924
925 /* Check the assumption made elsewhere that Lisp_Object and emacs_value
926 share the same underlying bit representation. */
927 eassert (v == *(emacs_value*)&o);
928 eassert (EQ (value_to_lisp (v), o));
929 return v;
930 #endif
931 }
932
933 \f
934 /* Memory management. */
935
936 /* Mark all objects allocated from local environments so that they
937 don't get garbage-collected. */
938 void
939 mark_modules (void)
940 {
941 }
942
943 \f
944 /* Environment lifetime management. */
945
946 /* Must be called before the environment can be used. */
947 static void
948 initialize_environment (emacs_env *env, struct emacs_env_private *priv)
949 {
950 priv->pending_non_local_exit = emacs_funcall_exit_return;
951 env->size = sizeof *env;
952 env->private_members = priv;
953 env->make_global_ref = module_make_global_ref;
954 env->free_global_ref = module_free_global_ref;
955 env->non_local_exit_check = module_non_local_exit_check;
956 env->non_local_exit_clear = module_non_local_exit_clear;
957 env->non_local_exit_get = module_non_local_exit_get;
958 env->non_local_exit_signal = module_non_local_exit_signal;
959 env->non_local_exit_throw = module_non_local_exit_throw;
960 env->make_function = module_make_function;
961 env->funcall = module_funcall;
962 env->intern = module_intern;
963 env->type_of = module_type_of;
964 env->is_not_nil = module_is_not_nil;
965 env->eq = module_eq;
966 env->extract_integer = module_extract_integer;
967 env->make_integer = module_make_integer;
968 env->extract_float = module_extract_float;
969 env->make_float = module_make_float;
970 env->copy_string_contents = module_copy_string_contents;
971 env->make_string = module_make_string;
972 env->make_user_ptr = module_make_user_ptr;
973 env->get_user_ptr = module_get_user_ptr;
974 env->set_user_ptr = module_set_user_ptr;
975 env->get_user_finalizer = module_get_user_finalizer;
976 env->set_user_finalizer = module_set_user_finalizer;
977 env->vec_set = module_vec_set;
978 env->vec_get = module_vec_get;
979 env->vec_size = module_vec_size;
980 Vmodule_environments = Fcons (make_save_ptr (env), Vmodule_environments);
981 }
982
983 /* Must be called before the lifetime of the environment object
984 ends. */
985 static void
986 finalize_environment (struct emacs_env_private *env)
987 {
988 Vmodule_environments = XCDR (Vmodule_environments);
989 }
990
991 \f
992 /* Non-local exit handling. */
993
994 /* Must be called after setting up a handler immediately before
995 returning from the function. See the comments in lisp.h and the
996 code in eval.c for details. The macros below arrange for this
997 function to be called automatically. DUMMY is ignored. */
998 static void
999 module_reset_handlerlist (const int *dummy)
1000 {
1001 handlerlist = handlerlist->next;
1002 }
1003
1004 /* Called on `signal'. ERR is a pair (SYMBOL . DATA), which gets
1005 stored in the environment. Set the pending non-local exit flag. */
1006 static void
1007 module_handle_signal (emacs_env *env, Lisp_Object err)
1008 {
1009 module_non_local_exit_signal_1 (env, XCAR (err), XCDR (err));
1010 }
1011
1012 /* Called on `throw'. TAG_VAL is a pair (TAG . VALUE), which gets
1013 stored in the environment. Set the pending non-local exit flag. */
1014 static void
1015 module_handle_throw (emacs_env *env, Lisp_Object tag_val)
1016 {
1017 module_non_local_exit_throw_1 (env, XCAR (tag_val), XCDR (tag_val));
1018 }
1019
1020 \f
1021 /* Function environments. */
1022
1023 /* Return a string object that contains a user-friendly
1024 representation of the function environment. */
1025 static Lisp_Object
1026 module_format_fun_env (const struct module_fun_env *env)
1027 {
1028 /* Try to print a function name if possible. */
1029 const char *path, *sym;
1030 static char const noaddr_format[] = "#<module function at %p>";
1031 char buffer[sizeof noaddr_format + INT_STRLEN_BOUND (intptr_t) + 256];
1032 char *buf = buffer;
1033 ptrdiff_t bufsize = sizeof buffer;
1034 ptrdiff_t size
1035 = (dynlib_addr (env->subr, &path, &sym)
1036 ? exprintf (&buf, &bufsize, buffer, -1,
1037 "#<module function %s from %s>", sym, path)
1038 : sprintf (buffer, noaddr_format, env->subr));
1039 Lisp_Object unibyte_result = make_unibyte_string (buffer, size);
1040 if (buf != buffer)
1041 xfree (buf);
1042 return code_convert_string_norecord (unibyte_result, Qutf_8, false);
1043 }
1044
1045 \f
1046 /* Segment initializer. */
1047
1048 void
1049 syms_of_module (void)
1050 {
1051 module_nil = lisp_to_value (Qnil);
1052 #ifdef WIDE_EMACS_INT
1053 ltv_mark = Fcons (Qnil, Qnil);
1054 #endif
1055
1056 DEFSYM (Qmodule_refs_hash, "module-refs-hash");
1057 DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash,
1058 doc: /* Module global reference table. */);
1059
1060 Vmodule_refs_hash
1061 = make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE),
1062 make_float (DEFAULT_REHASH_SIZE),
1063 make_float (DEFAULT_REHASH_THRESHOLD),
1064 Qnil);
1065 Funintern (Qmodule_refs_hash, Qnil);
1066
1067 DEFSYM (Qmodule_environments, "module-environments");
1068 DEFVAR_LISP ("module-environments", Vmodule_environments,
1069 doc: /* List of active module environments. */);
1070 Vmodule_environments = Qnil;
1071 /* Unintern `module-environments' because it is only used
1072 internally. */
1073 Funintern (Qmodule_environments, Qnil);
1074
1075 DEFSYM (Qmodule_load_failed, "module-load-failed");
1076 Fput (Qmodule_load_failed, Qerror_conditions,
1077 listn (CONSTYPE_PURE, 2, Qmodule_load_failed, Qerror));
1078 Fput (Qmodule_load_failed, Qerror_message,
1079 build_pure_c_string ("Module load failed"));
1080
1081 DEFSYM (Qinvalid_module_call, "invalid-module-call");
1082 Fput (Qinvalid_module_call, Qerror_conditions,
1083 listn (CONSTYPE_PURE, 2, Qinvalid_module_call, Qerror));
1084 Fput (Qinvalid_module_call, Qerror_message,
1085 build_pure_c_string ("Invalid module call"));
1086
1087 DEFSYM (Qinvalid_arity, "invalid-arity");
1088 Fput (Qinvalid_arity, Qerror_conditions,
1089 listn (CONSTYPE_PURE, 2, Qinvalid_arity, Qerror));
1090 Fput (Qinvalid_arity, Qerror_message,
1091 build_pure_c_string ("Invalid function arity"));
1092
1093 /* Unintern `module-refs-hash' because it is internal-only and Lisp
1094 code or modules should not access it. */
1095 Funintern (Qmodule_refs_hash, Qnil);
1096
1097 DEFSYM (Qsave_value_p, "save-value-p");
1098 DEFSYM (Qsave_pointer_p, "save-pointer-p");
1099
1100 defsubr (&Smodule_load);
1101
1102 DEFSYM (Qinternal_module_call, "internal--module-call");
1103 defsubr (&Sinternal_module_call);
1104 }
1105
1106 /* Unlike syms_of_module, this initializer is called even from an
1107 initialized (dumped) Emacs. */
1108
1109 void
1110 module_init (void)
1111 {
1112 /* It is not guaranteed that dynamic initializers run in the main thread,
1113 therefore detect the main thread here. */
1114 #ifdef HAVE_THREADS_H
1115 main_thread = thrd_current ();
1116 #elif defined HAVE_PTHREAD
1117 main_thread = pthread_self ();
1118 #elif defined WINDOWSNT
1119 /* The 'main' function already recorded the main thread's thread ID,
1120 so we need just to use it . */
1121 main_thread = dwMainThreadId;
1122 #endif
1123 }