diff options
| author | Philipp Stephani | 2017-06-05 13:29:14 +0200 |
|---|---|---|
| committer | Philipp Stephani | 2017-06-12 15:22:27 +0200 |
| commit | cf97132764572928adc77fd555d04a9f41cd3cfc (patch) | |
| tree | 65f707de87b811caec7b08f96938059859cf001c /src/emacs-module.c | |
| parent | b49dd3b047bf07994d9577e08daba55f143a8bb1 (diff) | |
| download | emacs-cf97132764572928adc77fd555d04a9f41cd3cfc.tar.gz emacs-cf97132764572928adc77fd555d04a9f41cd3cfc.zip | |
Implement module assertions for users
Add a new command-line option '-module-assertions' that users can
enable developing or debugging a module. If this option is present,
Emacs performs additional checks to verify that modules fulfill their
requirements. These checks are expensive and crash Emacs if modules
are invalid, so disable them by default.
This is a command-line option instead of an ordinary variable because
changing it while Emacs is running would cause data structure
imbalances.
* src/emacs.c (main): New command line option '-module-assertions'.
* src/emacs-module.c (module_assert_main_thread)
(module_assert_runtime, module_assert_env, module_assert_value):
New functions to assert module requirements.
(syms_of_module): New uninterned variable 'module-runtimes'.
(init_module_assertions, in_main_thread, module_abort): New helper
functions.
(initialize_environment): Initialize value list. If assertions are
enabled, use a heap-allocated environment object.
(finalize_environment): Add assertion that environment list is never
empty.
(finalize_runtime_unwind): Pop module runtime object stack.
(value_to_lisp): Assert that the value is valid.
(lisp_to_value): Record new value if assertions are enabled.
(mark_modules): Mark allocated object list.
(MODULE_FUNCTION_BEGIN_NO_CATCH)
(module_non_local_exit_check, module_non_local_exit_clear)
(module_non_local_exit_get, module_non_local_exit_signal)
(module_non_local_exit_throw): Assert thread and environment.
(module_get_environment): Assert thread and runtime.
(module_make_function, module_funcall, module_intern)
(module_funcall, module_make_integer, module_make_float)
(module_make_string, module_make_user_ptr, module_vec_get)
(funcall_module, Fmodule_load): Adapt callers.
(module_make_global_ref): If assertions are enabled, use the global
environment to store global values.
(module_free_global_ref): Remove value from global value list.
* test/Makefile.in (EMACSOPT): Enable module assertions when testing
modules.
* test/data/emacs-module/mod-test.c (Fmod_test_invalid_store)
(Fmod_test_invalid_load): New functions to test module assertions.
(emacs_module_init): Bind the new functions.
* test/src/emacs-module-tests.el (mod-test-emacs): New constant for
the Emacs binary file.
(mod-test-file): New constant for the test module file name.
(module--test-assertions): New unit test.
Diffstat (limited to 'src/emacs-module.c')
| -rw-r--r-- | src/emacs-module.c | 331 |
1 files changed, 268 insertions, 63 deletions
diff --git a/src/emacs-module.c b/src/emacs-module.c index adb09c0c506..2602398d814 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c | |||
| @@ -21,9 +21,11 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ | |||
| 21 | 21 | ||
| 22 | #include "emacs-module.h" | 22 | #include "emacs-module.h" |
| 23 | 23 | ||
| 24 | #include <stdarg.h> | ||
| 24 | #include <stddef.h> | 25 | #include <stddef.h> |
| 25 | #include <stdint.h> | 26 | #include <stdint.h> |
| 26 | #include <stdio.h> | 27 | #include <stdio.h> |
| 28 | #include <stdnoreturn.h> | ||
| 27 | 29 | ||
| 28 | #include "lisp.h" | 30 | #include "lisp.h" |
| 29 | #include "dynlib.h" | 31 | #include "dynlib.h" |
| @@ -35,6 +37,17 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */ | |||
| 35 | #include <intprops.h> | 37 | #include <intprops.h> |
| 36 | #include <verify.h> | 38 | #include <verify.h> |
| 37 | 39 | ||
| 40 | /* We use different strategies for allocating the user-visible objects | ||
| 41 | (struct emacs_runtime, emacs_env, emacs_value), depending on | ||
| 42 | whether the user supplied the -module-assertions flag. If | ||
| 43 | assertions are disabled, all objects are allocated from the stack. | ||
| 44 | If assertions are enabled, all objects are allocated from the free | ||
| 45 | store, and objects are never freed; this guarantees that they all | ||
| 46 | have different addresses. We use that for checking which objects | ||
| 47 | are live. Without unique addresses, we might consider some dead | ||
| 48 | objects live because their addresses would have been reused in the | ||
| 49 | meantime. */ | ||
| 50 | |||
| 38 | 51 | ||
| 39 | /* Feature tests. */ | 52 | /* Feature tests. */ |
| 40 | 53 | ||
| @@ -78,25 +91,31 @@ struct emacs_env_private | |||
| 78 | storage is always available for them, even in an out-of-memory | 91 | storage is always available for them, even in an out-of-memory |
| 79 | situation. */ | 92 | situation. */ |
| 80 | Lisp_Object non_local_exit_symbol, non_local_exit_data; | 93 | Lisp_Object non_local_exit_symbol, non_local_exit_data; |
| 94 | |||
| 95 | /* List of values allocated from this environment. The code uses | ||
| 96 | this only if the user gave the -module-assertions command-line | ||
| 97 | option. */ | ||
| 98 | Lisp_Object values; | ||
| 81 | }; | 99 | }; |
| 82 | 100 | ||
| 83 | /* The private parts of an `emacs_runtime' object contain the initial | 101 | /* The private parts of an `emacs_runtime' object contain the initial |
| 84 | environment. */ | 102 | environment. */ |
| 85 | struct emacs_runtime_private | 103 | struct emacs_runtime_private |
| 86 | { | 104 | { |
| 87 | emacs_env pub; | 105 | emacs_env *env; |
| 88 | }; | 106 | }; |
| 89 | 107 | ||
| 90 | 108 | ||
| 91 | /* Forward declarations. */ | 109 | /* Forward declarations. */ |
| 92 | 110 | ||
| 93 | struct module_fun_env; | ||
| 94 | |||
| 95 | static Lisp_Object value_to_lisp (emacs_value); | 111 | static Lisp_Object value_to_lisp (emacs_value); |
| 96 | static emacs_value lisp_to_value (Lisp_Object); | 112 | static emacs_value lisp_to_value (emacs_env *, Lisp_Object); |
| 97 | static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *); | 113 | static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *); |
| 98 | static void check_thread (void); | 114 | static void module_assert_thread (void); |
| 99 | static void initialize_environment (emacs_env *, struct emacs_env_private *); | 115 | static void module_assert_runtime (struct emacs_runtime *); |
| 116 | static void module_assert_env (emacs_env *); | ||
| 117 | static noreturn void module_abort (const char *format, ...) ATTRIBUTE_FORMAT_PRINTF(1, 2); | ||
| 118 | static emacs_env *initialize_environment (emacs_env *, struct emacs_env_private *); | ||
| 100 | static void finalize_environment (emacs_env *); | 119 | static void finalize_environment (emacs_env *); |
| 101 | static void finalize_environment_unwind (void *); | 120 | static void finalize_environment_unwind (void *); |
| 102 | static void finalize_runtime_unwind (void *); | 121 | static void finalize_runtime_unwind (void *); |
| @@ -113,6 +132,10 @@ static void module_reset_handlerlist (struct handler *const *); | |||
| 113 | code should not assume this. */ | 132 | code should not assume this. */ |
| 114 | verify (NIL_IS_ZERO); | 133 | verify (NIL_IS_ZERO); |
| 115 | static emacs_value const module_nil = 0; | 134 | static emacs_value const module_nil = 0; |
| 135 | |||
| 136 | static bool module_assertions = false; | ||
| 137 | static emacs_env *global_env; | ||
| 138 | static struct emacs_env_private global_env_private; | ||
| 116 | 139 | ||
| 117 | /* Convenience macros for non-local exit handling. */ | 140 | /* Convenience macros for non-local exit handling. */ |
| 118 | 141 | ||
| @@ -216,7 +239,8 @@ static emacs_value const module_nil = 0; | |||
| 216 | 239 | ||
| 217 | #define MODULE_FUNCTION_BEGIN_NO_CATCH(error_retval) \ | 240 | #define MODULE_FUNCTION_BEGIN_NO_CATCH(error_retval) \ |
| 218 | do { \ | 241 | do { \ |
| 219 | check_thread (); \ | 242 | module_assert_thread (); \ |
| 243 | module_assert_env (env); \ | ||
| 220 | if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \ | 244 | if (module_non_local_exit_check (env) != emacs_funcall_exit_return) \ |
| 221 | return error_retval; \ | 245 | return error_retval; \ |
| 222 | } while (false) | 246 | } while (false) |
| @@ -242,9 +266,9 @@ CHECK_USER_PTR (Lisp_Object obj) | |||
| 242 | static emacs_env * | 266 | static emacs_env * |
| 243 | module_get_environment (struct emacs_runtime *ert) | 267 | module_get_environment (struct emacs_runtime *ert) |
| 244 | { | 268 | { |
| 245 | emacs_env *env = &ert->private_members->pub; | 269 | module_assert_thread (); |
| 246 | check_thread (); | 270 | module_assert_runtime (ert); |
| 247 | return env; | 271 | return ert->private_members->env; |
| 248 | } | 272 | } |
| 249 | 273 | ||
| 250 | /* To make global refs (GC-protected global values) keep a hash that | 274 | /* To make global refs (GC-protected global values) keep a hash that |
| @@ -273,7 +297,7 @@ module_make_global_ref (emacs_env *env, emacs_value ref) | |||
| 273 | hash_put (h, new_obj, make_natnum (1), hashcode); | 297 | hash_put (h, new_obj, make_natnum (1), hashcode); |
| 274 | } | 298 | } |
| 275 | 299 | ||
| 276 | return lisp_to_value (new_obj); | 300 | return lisp_to_value (module_assertions ? global_env : env, new_obj); |
| 277 | } | 301 | } |
| 278 | 302 | ||
| 279 | static void | 303 | static void |
| @@ -300,32 +324,59 @@ module_free_global_ref (emacs_env *env, emacs_value ref) | |||
| 300 | else | 324 | else |
| 301 | hash_remove_from_table (h, value); | 325 | hash_remove_from_table (h, value); |
| 302 | } | 326 | } |
| 327 | |||
| 328 | if (module_assertions) | ||
| 329 | { | ||
| 330 | Lisp_Object globals = global_env_private.values; | ||
| 331 | Lisp_Object prev = Qnil; | ||
| 332 | ptrdiff_t count = 0; | ||
| 333 | for (Lisp_Object tail = global_env_private.values; CONSP (tail); | ||
| 334 | tail = XCDR (tail)) | ||
| 335 | { | ||
| 336 | emacs_value global = XSAVE_POINTER (XCAR (globals), 0); | ||
| 337 | if (global == ref) | ||
| 338 | { | ||
| 339 | if (NILP (prev)) | ||
| 340 | global_env_private.values = XCDR (globals); | ||
| 341 | else | ||
| 342 | XSETCDR (prev, XCDR (globals)); | ||
| 343 | return; | ||
| 344 | } | ||
| 345 | ++count; | ||
| 346 | prev = globals; | ||
| 347 | } | ||
| 348 | module_abort ("Global value was not found in list of %td globals", | ||
| 349 | count); | ||
| 350 | } | ||
| 303 | } | 351 | } |
| 304 | 352 | ||
| 305 | static enum emacs_funcall_exit | 353 | static enum emacs_funcall_exit |
| 306 | module_non_local_exit_check (emacs_env *env) | 354 | module_non_local_exit_check (emacs_env *env) |
| 307 | { | 355 | { |
| 308 | check_thread (); | 356 | module_assert_thread (); |
| 357 | module_assert_env (env); | ||
| 309 | return env->private_members->pending_non_local_exit; | 358 | return env->private_members->pending_non_local_exit; |
| 310 | } | 359 | } |
| 311 | 360 | ||
| 312 | static void | 361 | static void |
| 313 | module_non_local_exit_clear (emacs_env *env) | 362 | module_non_local_exit_clear (emacs_env *env) |
| 314 | { | 363 | { |
| 315 | check_thread (); | 364 | module_assert_thread (); |
| 365 | module_assert_env (env); | ||
| 316 | env->private_members->pending_non_local_exit = emacs_funcall_exit_return; | 366 | env->private_members->pending_non_local_exit = emacs_funcall_exit_return; |
| 317 | } | 367 | } |
| 318 | 368 | ||
| 319 | static enum emacs_funcall_exit | 369 | static enum emacs_funcall_exit |
| 320 | module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) | 370 | module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) |
| 321 | { | 371 | { |
| 322 | check_thread (); | 372 | module_assert_thread (); |
| 373 | module_assert_env (env); | ||
| 323 | struct emacs_env_private *p = env->private_members; | 374 | struct emacs_env_private *p = env->private_members; |
| 324 | if (p->pending_non_local_exit != emacs_funcall_exit_return) | 375 | if (p->pending_non_local_exit != emacs_funcall_exit_return) |
| 325 | { | 376 | { |
| 326 | /* FIXME: lisp_to_value can exit non-locally. */ | 377 | /* FIXME: lisp_to_value can exit non-locally. */ |
| 327 | *sym = lisp_to_value (p->non_local_exit_symbol); | 378 | *sym = lisp_to_value (env, p->non_local_exit_symbol); |
| 328 | *data = lisp_to_value (p->non_local_exit_data); | 379 | *data = lisp_to_value (env, p->non_local_exit_data); |
| 329 | } | 380 | } |
| 330 | return p->pending_non_local_exit; | 381 | return p->pending_non_local_exit; |
| 331 | } | 382 | } |
| @@ -334,7 +385,8 @@ module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) | |||
| 334 | static void | 385 | static void |
| 335 | module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data) | 386 | module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data) |
| 336 | { | 387 | { |
| 337 | check_thread (); | 388 | module_assert_thread (); |
| 389 | module_assert_env (env); | ||
| 338 | if (module_non_local_exit_check (env) == emacs_funcall_exit_return) | 390 | if (module_non_local_exit_check (env) == emacs_funcall_exit_return) |
| 339 | module_non_local_exit_signal_1 (env, value_to_lisp (sym), | 391 | module_non_local_exit_signal_1 (env, value_to_lisp (sym), |
| 340 | value_to_lisp (data)); | 392 | value_to_lisp (data)); |
| @@ -343,7 +395,8 @@ module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data) | |||
| 343 | static void | 395 | static void |
| 344 | module_non_local_exit_throw (emacs_env *env, emacs_value tag, emacs_value value) | 396 | module_non_local_exit_throw (emacs_env *env, emacs_value tag, emacs_value value) |
| 345 | { | 397 | { |
| 346 | check_thread (); | 398 | module_assert_thread (); |
| 399 | module_assert_env (env); | ||
| 347 | if (module_non_local_exit_check (env) == emacs_funcall_exit_return) | 400 | if (module_non_local_exit_check (env) == emacs_funcall_exit_return) |
| 348 | module_non_local_exit_throw_1 (env, value_to_lisp (tag), | 401 | module_non_local_exit_throw_1 (env, value_to_lisp (tag), |
| 349 | value_to_lisp (value)); | 402 | value_to_lisp (value)); |
| @@ -393,7 +446,7 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, | |||
| 393 | XSET_MODULE_FUNCTION (result, function); | 446 | XSET_MODULE_FUNCTION (result, function); |
| 394 | eassert (MODULE_FUNCTIONP (result)); | 447 | eassert (MODULE_FUNCTIONP (result)); |
| 395 | 448 | ||
| 396 | return lisp_to_value (result); | 449 | return lisp_to_value (env, result); |
| 397 | } | 450 | } |
| 398 | 451 | ||
| 399 | static emacs_value | 452 | static emacs_value |
| @@ -413,7 +466,7 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, | |||
| 413 | newargs[0] = value_to_lisp (fun); | 466 | newargs[0] = value_to_lisp (fun); |
| 414 | for (ptrdiff_t i = 0; i < nargs; i++) | 467 | for (ptrdiff_t i = 0; i < nargs; i++) |
| 415 | newargs[1 + i] = value_to_lisp (args[i]); | 468 | newargs[1 + i] = value_to_lisp (args[i]); |
| 416 | emacs_value result = lisp_to_value (Ffuncall (nargs1, newargs)); | 469 | emacs_value result = lisp_to_value (env, Ffuncall (nargs1, newargs)); |
| 417 | SAFE_FREE (); | 470 | SAFE_FREE (); |
| 418 | return result; | 471 | return result; |
| 419 | } | 472 | } |
| @@ -422,14 +475,14 @@ static emacs_value | |||
| 422 | module_intern (emacs_env *env, const char *name) | 475 | module_intern (emacs_env *env, const char *name) |
| 423 | { | 476 | { |
| 424 | MODULE_FUNCTION_BEGIN (module_nil); | 477 | MODULE_FUNCTION_BEGIN (module_nil); |
| 425 | return lisp_to_value (intern (name)); | 478 | return lisp_to_value (env, intern (name)); |
| 426 | } | 479 | } |
| 427 | 480 | ||
| 428 | static emacs_value | 481 | static emacs_value |
| 429 | module_type_of (emacs_env *env, emacs_value value) | 482 | module_type_of (emacs_env *env, emacs_value value) |
| 430 | { | 483 | { |
| 431 | MODULE_FUNCTION_BEGIN (module_nil); | 484 | MODULE_FUNCTION_BEGIN (module_nil); |
| 432 | return lisp_to_value (Ftype_of (value_to_lisp (value))); | 485 | return lisp_to_value (env, Ftype_of (value_to_lisp (value))); |
| 433 | } | 486 | } |
| 434 | 487 | ||
| 435 | static bool | 488 | static bool |
| @@ -461,7 +514,7 @@ module_make_integer (emacs_env *env, intmax_t n) | |||
| 461 | MODULE_FUNCTION_BEGIN (module_nil); | 514 | MODULE_FUNCTION_BEGIN (module_nil); |
| 462 | if (FIXNUM_OVERFLOW_P (n)) | 515 | if (FIXNUM_OVERFLOW_P (n)) |
| 463 | xsignal0 (Qoverflow_error); | 516 | xsignal0 (Qoverflow_error); |
| 464 | return lisp_to_value (make_number (n)); | 517 | return lisp_to_value (env, make_number (n)); |
| 465 | } | 518 | } |
| 466 | 519 | ||
| 467 | static double | 520 | static double |
| @@ -477,7 +530,7 @@ static emacs_value | |||
| 477 | module_make_float (emacs_env *env, double d) | 530 | module_make_float (emacs_env *env, double d) |
| 478 | { | 531 | { |
| 479 | MODULE_FUNCTION_BEGIN (module_nil); | 532 | MODULE_FUNCTION_BEGIN (module_nil); |
| 480 | return lisp_to_value (make_float (d)); | 533 | return lisp_to_value (env, make_float (d)); |
| 481 | } | 534 | } |
| 482 | 535 | ||
| 483 | static bool | 536 | static bool |
| @@ -519,14 +572,15 @@ module_make_string (emacs_env *env, const char *str, ptrdiff_t length) | |||
| 519 | if (! (0 <= length && length <= STRING_BYTES_BOUND)) | 572 | if (! (0 <= length && length <= STRING_BYTES_BOUND)) |
| 520 | xsignal0 (Qoverflow_error); | 573 | xsignal0 (Qoverflow_error); |
| 521 | AUTO_STRING_WITH_LEN (lstr, str, length); | 574 | AUTO_STRING_WITH_LEN (lstr, str, length); |
| 522 | return lisp_to_value (code_convert_string_norecord (lstr, Qutf_8, false)); | 575 | return lisp_to_value (env, |
| 576 | code_convert_string_norecord (lstr, Qutf_8, false)); | ||
| 523 | } | 577 | } |
| 524 | 578 | ||
| 525 | static emacs_value | 579 | static emacs_value |
| 526 | module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) | 580 | module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) |
| 527 | { | 581 | { |
| 528 | MODULE_FUNCTION_BEGIN (module_nil); | 582 | MODULE_FUNCTION_BEGIN (module_nil); |
| 529 | return lisp_to_value (make_user_ptr (fin, ptr)); | 583 | return lisp_to_value (env, make_user_ptr (fin, ptr)); |
| 530 | } | 584 | } |
| 531 | 585 | ||
| 532 | static void * | 586 | static void * |
| @@ -593,7 +647,7 @@ module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) | |||
| 593 | MODULE_FUNCTION_BEGIN (module_nil); | 647 | MODULE_FUNCTION_BEGIN (module_nil); |
| 594 | Lisp_Object lvec = value_to_lisp (vec); | 648 | Lisp_Object lvec = value_to_lisp (vec); |
| 595 | check_vec_index (lvec, i); | 649 | check_vec_index (lvec, i); |
| 596 | return lisp_to_value (AREF (lvec, i)); | 650 | return lisp_to_value (env, AREF (lvec, i)); |
| 597 | } | 651 | } |
| 598 | 652 | ||
| 599 | static ptrdiff_t | 653 | static ptrdiff_t |
| @@ -655,19 +709,27 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, | |||
| 655 | if (!module_init) | 709 | if (!module_init) |
| 656 | xsignal1 (Qmissing_module_init_function, file); | 710 | xsignal1 (Qmissing_module_init_function, file); |
| 657 | 711 | ||
| 658 | struct emacs_runtime_private rt; /* Includes the public emacs_env. */ | 712 | struct emacs_runtime rt_pub; |
| 659 | struct emacs_env_private priv; | 713 | struct emacs_runtime_private rt_priv; |
| 660 | initialize_environment (&rt.pub, &priv); | 714 | emacs_env env_pub; |
| 661 | struct emacs_runtime pub = | 715 | struct emacs_env_private env_priv; |
| 662 | { | 716 | rt_priv.env = initialize_environment (&env_pub, &env_priv); |
| 663 | .size = sizeof pub, | 717 | |
| 664 | .private_members = &rt, | 718 | /* If we should use module assertions, reallocate the runtime object |
| 665 | .get_environment = module_get_environment | 719 | from the free store, but never free it. That way the addresses |
| 666 | }; | 720 | for two different runtime objects are guaranteed to be distinct, |
| 721 | which we can use for checking the liveness of runtime | ||
| 722 | pointers. */ | ||
| 723 | struct emacs_runtime *rt = module_assertions ? xmalloc (sizeof *rt) : &rt_pub; | ||
| 724 | rt->size = sizeof *rt; | ||
| 725 | rt->private_members = &rt_priv; | ||
| 726 | rt->get_environment = module_get_environment; | ||
| 727 | |||
| 728 | Vmodule_runtimes = Fcons (make_save_ptr (rt), Vmodule_runtimes); | ||
| 667 | ptrdiff_t count = SPECPDL_INDEX (); | 729 | ptrdiff_t count = SPECPDL_INDEX (); |
| 668 | record_unwind_protect_ptr (finalize_runtime_unwind, &pub); | 730 | record_unwind_protect_ptr (finalize_runtime_unwind, rt); |
| 669 | 731 | ||
| 670 | int r = module_init (&pub); | 732 | int r = module_init (rt); |
| 671 | 733 | ||
| 672 | /* Process the quit flag first, so that quitting doesn't get | 734 | /* Process the quit flag first, so that quitting doesn't get |
| 673 | overridden by other non-local exits. */ | 735 | overridden by other non-local exits. */ |
| @@ -680,7 +742,7 @@ DEFUN ("module-load", Fmodule_load, Smodule_load, 1, 1, 0, | |||
| 680 | xsignal2 (Qmodule_init_failed, file, make_number (r)); | 742 | xsignal2 (Qmodule_init_failed, file, make_number (r)); |
| 681 | } | 743 | } |
| 682 | 744 | ||
| 683 | module_signal_or_throw (&priv); | 745 | module_signal_or_throw (&env_priv); |
| 684 | return unbind_to (count, Qt); | 746 | return unbind_to (count, Qt); |
| 685 | } | 747 | } |
| 686 | 748 | ||
| @@ -695,25 +757,25 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist) | |||
| 695 | 757 | ||
| 696 | emacs_env pub; | 758 | emacs_env pub; |
| 697 | struct emacs_env_private priv; | 759 | struct emacs_env_private priv; |
| 698 | initialize_environment (&pub, &priv); | 760 | emacs_env *env = initialize_environment (&pub, &priv); |
| 699 | ptrdiff_t count = SPECPDL_INDEX (); | 761 | ptrdiff_t count = SPECPDL_INDEX (); |
| 700 | record_unwind_protect_ptr (finalize_environment_unwind, &pub); | 762 | record_unwind_protect_ptr (finalize_environment_unwind, env); |
| 701 | 763 | ||
| 702 | USE_SAFE_ALLOCA; | 764 | USE_SAFE_ALLOCA; |
| 703 | ATTRIBUTE_MAY_ALIAS emacs_value *args; | 765 | ATTRIBUTE_MAY_ALIAS emacs_value *args; |
| 704 | if (plain_values) | 766 | if (plain_values && ! module_assertions) |
| 705 | args = (emacs_value *) arglist; | 767 | args = (emacs_value *) arglist; |
| 706 | else | 768 | else |
| 707 | { | 769 | { |
| 708 | args = SAFE_ALLOCA (nargs * sizeof *args); | 770 | args = SAFE_ALLOCA (nargs * sizeof *args); |
| 709 | for (ptrdiff_t i = 0; i < nargs; i++) | 771 | for (ptrdiff_t i = 0; i < nargs; i++) |
| 710 | args[i] = lisp_to_value (arglist[i]); | 772 | args[i] = lisp_to_value (env, arglist[i]); |
| 711 | } | 773 | } |
| 712 | 774 | ||
| 713 | emacs_value ret = func->subr (&pub, nargs, args, func->data); | 775 | emacs_value ret = func->subr (env, nargs, args, func->data); |
| 714 | SAFE_FREE (); | 776 | SAFE_FREE (); |
| 715 | 777 | ||
| 716 | eassert (&priv == pub.private_members); | 778 | eassert (&priv == env->private_members); |
| 717 | 779 | ||
| 718 | /* Process the quit flag first, so that quitting doesn't get | 780 | /* Process the quit flag first, so that quitting doesn't get |
| 719 | overridden by other non-local exits. */ | 781 | overridden by other non-local exits. */ |
| @@ -735,18 +797,59 @@ module_function_arity (const struct Lisp_Module_Function *const function) | |||
| 735 | 797 | ||
| 736 | /* Helper functions. */ | 798 | /* Helper functions. */ |
| 737 | 799 | ||
| 738 | static void | 800 | static bool |
| 739 | check_thread (void) | 801 | in_current_thread (void) |
| 740 | { | 802 | { |
| 741 | eassert (current_thread != NULL); | 803 | if (current_thread == NULL) |
| 804 | return false; | ||
| 742 | #ifdef HAVE_PTHREAD | 805 | #ifdef HAVE_PTHREAD |
| 743 | eassert (pthread_equal (pthread_self (), current_thread->thread_id)); | 806 | return pthread_equal (pthread_self (), current_thread->thread_id); |
| 744 | #elif defined WINDOWSNT | 807 | #elif defined WINDOWSNT |
| 745 | eassert (GetCurrentThreadId () == current_thread->thread_id); | 808 | return GetCurrentThreadId () == current_thread->thread_id; |
| 746 | #endif | 809 | #endif |
| 747 | } | 810 | } |
| 748 | 811 | ||
| 749 | static void | 812 | static void |
| 813 | module_assert_thread (void) | ||
| 814 | { | ||
| 815 | if (! module_assertions || in_current_thread ()) | ||
| 816 | return; | ||
| 817 | module_abort ("Module function called from outside the current Lisp thread"); | ||
| 818 | } | ||
| 819 | |||
| 820 | static void | ||
| 821 | module_assert_runtime (struct emacs_runtime *ert) | ||
| 822 | { | ||
| 823 | if (! module_assertions) | ||
| 824 | return; | ||
| 825 | ptrdiff_t count = 0; | ||
| 826 | for (Lisp_Object tail = Vmodule_runtimes; CONSP (tail); tail = XCDR (tail)) | ||
| 827 | { | ||
| 828 | if (XSAVE_POINTER (XCAR (tail), 0) == ert) | ||
| 829 | return; | ||
| 830 | ++count; | ||
| 831 | } | ||
| 832 | module_abort ("Runtime pointer not found in list of %td runtimes", count); | ||
| 833 | } | ||
| 834 | |||
| 835 | static void | ||
| 836 | module_assert_env (emacs_env *env) | ||
| 837 | { | ||
| 838 | if (! module_assertions) | ||
| 839 | return; | ||
| 840 | ptrdiff_t count = 0; | ||
| 841 | for (Lisp_Object tail = Vmodule_environments; CONSP (tail); | ||
| 842 | tail = XCDR (tail)) | ||
| 843 | { | ||
| 844 | if (XSAVE_POINTER (XCAR (tail), 0) == env) | ||
| 845 | return; | ||
| 846 | ++count; | ||
| 847 | } | ||
| 848 | module_abort ("Environment pointer not found in list of %td environments", | ||
| 849 | count); | ||
| 850 | } | ||
| 851 | |||
| 852 | static void | ||
| 750 | module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym, | 853 | module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym, |
| 751 | Lisp_Object data) | 854 | Lisp_Object data) |
| 752 | { | 855 | { |
| @@ -785,6 +888,14 @@ module_out_of_memory (emacs_env *env) | |||
| 785 | 888 | ||
| 786 | /* Value conversion. */ | 889 | /* Value conversion. */ |
| 787 | 890 | ||
| 891 | /* We represent Lisp objects differently depending on whether the user | ||
| 892 | gave -module-assertions. If assertions are disabled, emacs_value | ||
| 893 | objects are Lisp_Objects cast to emacs_value. If assertions are | ||
| 894 | enabled, emacs_value objects are pointers to Lisp_Object objects | ||
| 895 | allocated from the free store; they are never freed, which ensures | ||
| 896 | that their addresses are unique and can be used for liveness | ||
| 897 | checking. */ | ||
| 898 | |||
| 788 | /* Unique Lisp_Object used to mark those emacs_values which are really | 899 | /* Unique Lisp_Object used to mark those emacs_values which are really |
| 789 | just containers holding a Lisp_Object that does not fit as an emacs_value, | 900 | just containers holding a Lisp_Object that does not fit as an emacs_value, |
| 790 | either because it is an integer out of range, or is not properly aligned. | 901 | either because it is an integer out of range, or is not properly aligned. |
| @@ -831,6 +942,32 @@ value_to_lisp_bits (emacs_value v) | |||
| 831 | static Lisp_Object | 942 | static Lisp_Object |
| 832 | value_to_lisp (emacs_value v) | 943 | value_to_lisp (emacs_value v) |
| 833 | { | 944 | { |
| 945 | if (module_assertions) | ||
| 946 | { | ||
| 947 | /* Check the liveness of the value by iterating over all live | ||
| 948 | environments. */ | ||
| 949 | void *vptr = v; | ||
| 950 | ATTRIBUTE_MAY_ALIAS Lisp_Object *optr = vptr; | ||
| 951 | ptrdiff_t num_environments = 0; | ||
| 952 | ptrdiff_t num_values = 0; | ||
| 953 | for (Lisp_Object environments = Vmodule_environments; | ||
| 954 | CONSP (environments); environments = XCDR (environments)) | ||
| 955 | { | ||
| 956 | emacs_env *env = XSAVE_POINTER (XCAR (environments), 0); | ||
| 957 | for (Lisp_Object values = env->private_members->values; | ||
| 958 | CONSP (values); values = XCDR (values)) | ||
| 959 | { | ||
| 960 | Lisp_Object *p = XSAVE_POINTER (XCAR (values), 0); | ||
| 961 | if (p == optr) | ||
| 962 | return *p; | ||
| 963 | ++num_values; | ||
| 964 | } | ||
| 965 | ++num_environments; | ||
| 966 | } | ||
| 967 | module_abort ("Emacs value not found in %td values of %td environments", | ||
| 968 | num_values, num_environments); | ||
| 969 | } | ||
| 970 | |||
| 834 | Lisp_Object o = value_to_lisp_bits (v); | 971 | Lisp_Object o = value_to_lisp_bits (v); |
| 835 | if (! plain_values && CONSP (o) && EQ (XCDR (o), ltv_mark)) | 972 | if (! plain_values && CONSP (o) && EQ (XCDR (o), ltv_mark)) |
| 836 | o = XCAR (o); | 973 | o = XCAR (o); |
| @@ -859,8 +996,23 @@ enum { HAVE_STRUCT_ATTRIBUTE_ALIGNED = 0 }; | |||
| 859 | /* Convert O to an emacs_value. Allocate storage if needed; this can | 996 | /* Convert O to an emacs_value. Allocate storage if needed; this can |
| 860 | signal if memory is exhausted. Must be an injective function. */ | 997 | signal if memory is exhausted. Must be an injective function. */ |
| 861 | static emacs_value | 998 | static emacs_value |
| 862 | lisp_to_value (Lisp_Object o) | 999 | lisp_to_value (emacs_env *env, Lisp_Object o) |
| 863 | { | 1000 | { |
| 1001 | if (module_assertions) | ||
| 1002 | { | ||
| 1003 | /* Add the new value to the list of values allocated from this | ||
| 1004 | environment. The value is actually a pointer to the | ||
| 1005 | Lisp_Object cast to emacs_value. We make a copy of the | ||
| 1006 | object on the free store to guarantee unique addresses. */ | ||
| 1007 | ATTRIBUTE_MAY_ALIAS Lisp_Object *optr = xmalloc (sizeof o); | ||
| 1008 | *optr = o; | ||
| 1009 | void *vptr = optr; | ||
| 1010 | ATTRIBUTE_MAY_ALIAS emacs_value ret = vptr; | ||
| 1011 | struct emacs_env_private *priv = env->private_members; | ||
| 1012 | priv->values = Fcons (make_save_ptr (ret), priv->values); | ||
| 1013 | return ret; | ||
| 1014 | } | ||
| 1015 | |||
| 864 | emacs_value v = lisp_to_value_bits (o); | 1016 | emacs_value v = lisp_to_value_bits (o); |
| 865 | 1017 | ||
| 866 | if (! EQ (o, value_to_lisp_bits (v))) | 1018 | if (! EQ (o, value_to_lisp_bits (v))) |
| @@ -891,12 +1043,20 @@ lisp_to_value (Lisp_Object o) | |||
| 891 | 1043 | ||
| 892 | /* Environment lifetime management. */ | 1044 | /* Environment lifetime management. */ |
| 893 | 1045 | ||
| 894 | /* Must be called before the environment can be used. */ | 1046 | /* Must be called before the environment can be used. Returns another |
| 895 | static void | 1047 | pointer that callers should use instead of the ENV argument. If |
| 1048 | module assertions are disabled, the return value is ENV. If module | ||
| 1049 | assertions are enabled, the return value points to a heap-allocated | ||
| 1050 | object. That object is never freed to guarantee unique | ||
| 1051 | addresses. */ | ||
| 1052 | static emacs_env * | ||
| 896 | initialize_environment (emacs_env *env, struct emacs_env_private *priv) | 1053 | initialize_environment (emacs_env *env, struct emacs_env_private *priv) |
| 897 | { | 1054 | { |
| 1055 | if (module_assertions) | ||
| 1056 | env = xmalloc (sizeof *env); | ||
| 1057 | |||
| 898 | priv->pending_non_local_exit = emacs_funcall_exit_return; | 1058 | priv->pending_non_local_exit = emacs_funcall_exit_return; |
| 899 | priv->non_local_exit_symbol = priv->non_local_exit_data = Qnil; | 1059 | priv->values = priv->non_local_exit_symbol = priv->non_local_exit_data = Qnil; |
| 900 | env->size = sizeof *env; | 1060 | env->size = sizeof *env; |
| 901 | env->private_members = priv; | 1061 | env->private_members = priv; |
| 902 | env->make_global_ref = module_make_global_ref; | 1062 | env->make_global_ref = module_make_global_ref; |
| @@ -928,6 +1088,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) | |||
| 928 | env->vec_size = module_vec_size; | 1088 | env->vec_size = module_vec_size; |
| 929 | env->should_quit = module_should_quit; | 1089 | env->should_quit = module_should_quit; |
| 930 | Vmodule_environments = Fcons (make_save_ptr (env), Vmodule_environments); | 1090 | Vmodule_environments = Fcons (make_save_ptr (env), Vmodule_environments); |
| 1091 | return env; | ||
| 931 | } | 1092 | } |
| 932 | 1093 | ||
| 933 | /* Must be called before the lifetime of the environment object | 1094 | /* Must be called before the lifetime of the environment object |
| @@ -937,6 +1098,9 @@ finalize_environment (emacs_env *env) | |||
| 937 | { | 1098 | { |
| 938 | eassert (XSAVE_POINTER (XCAR (Vmodule_environments), 0) == env); | 1099 | eassert (XSAVE_POINTER (XCAR (Vmodule_environments), 0) == env); |
| 939 | Vmodule_environments = XCDR (Vmodule_environments); | 1100 | Vmodule_environments = XCDR (Vmodule_environments); |
| 1101 | if (module_assertions) | ||
| 1102 | /* There is always at least the global environment. */ | ||
| 1103 | eassert (CONSP (Vmodule_environments)); | ||
| 940 | } | 1104 | } |
| 941 | 1105 | ||
| 942 | static void | 1106 | static void |
| @@ -949,20 +1113,23 @@ static void | |||
| 949 | finalize_runtime_unwind (void* raw_ert) | 1113 | finalize_runtime_unwind (void* raw_ert) |
| 950 | { | 1114 | { |
| 951 | struct emacs_runtime *ert = raw_ert; | 1115 | struct emacs_runtime *ert = raw_ert; |
| 952 | finalize_environment (&ert->private_members->pub); | 1116 | eassert (XSAVE_POINTER (XCAR (Vmodule_runtimes), 0) == ert); |
| 1117 | Vmodule_runtimes = XCDR (Vmodule_runtimes); | ||
| 1118 | finalize_environment (ert->private_members->env); | ||
| 953 | } | 1119 | } |
| 954 | 1120 | ||
| 955 | void | 1121 | void |
| 956 | mark_modules (void) | 1122 | mark_modules (void) |
| 957 | { | 1123 | { |
| 958 | Lisp_Object tail = Vmodule_environments; | 1124 | for (Lisp_Object tail = Vmodule_environments; CONSP (tail); |
| 959 | FOR_EACH_TAIL_SAFE (tail) | 1125 | tail = XCDR (tail)) |
| 960 | { | 1126 | { |
| 961 | emacs_env *env = XSAVE_POINTER (XCAR (tail), 0); | 1127 | emacs_env *env = XSAVE_POINTER (XCAR (tail), 0); |
| 962 | struct emacs_env_private *priv = env->private_members; | 1128 | struct emacs_env_private *priv = env->private_members; |
| 963 | mark_object (priv->non_local_exit_symbol); | 1129 | mark_object (priv->non_local_exit_symbol); |
| 964 | mark_object (priv->non_local_exit_data); | 1130 | mark_object (priv->non_local_exit_data); |
| 965 | } | 1131 | mark_object (priv->values); |
| 1132 | } | ||
| 966 | } | 1133 | } |
| 967 | 1134 | ||
| 968 | 1135 | ||
| @@ -997,6 +1164,36 @@ module_handle_throw (emacs_env *env, Lisp_Object tag_val) | |||
| 997 | } | 1164 | } |
| 998 | 1165 | ||
| 999 | 1166 | ||
| 1167 | /* Support for assertions. */ | ||
| 1168 | void | ||
| 1169 | init_module_assertions (bool enable) | ||
| 1170 | { | ||
| 1171 | module_assertions = enable; | ||
| 1172 | if (enable) | ||
| 1173 | { | ||
| 1174 | /* We use a hidden environment for storing the globals. This | ||
| 1175 | environment is never freed. */ | ||
| 1176 | emacs_env env; | ||
| 1177 | global_env = initialize_environment (&env, &global_env_private); | ||
| 1178 | eassert (global_env != &env); | ||
| 1179 | } | ||
| 1180 | } | ||
| 1181 | |||
| 1182 | static noreturn void | ||
| 1183 | ATTRIBUTE_FORMAT_PRINTF(1, 2) | ||
| 1184 | module_abort (const char *format, ...) | ||
| 1185 | { | ||
| 1186 | fputs ("Emacs module assertion: ", stderr); | ||
| 1187 | va_list args; | ||
| 1188 | va_start (args, format); | ||
| 1189 | vfprintf (stderr, format, args); | ||
| 1190 | va_end (args); | ||
| 1191 | putc ('\n', stderr); | ||
| 1192 | fflush (stderr); | ||
| 1193 | emacs_abort (); | ||
| 1194 | } | ||
| 1195 | |||
| 1196 | |||
| 1000 | /* Segment initializer. */ | 1197 | /* Segment initializer. */ |
| 1001 | 1198 | ||
| 1002 | void | 1199 | void |
| @@ -1016,6 +1213,14 @@ syms_of_module (void) | |||
| 1016 | Qnil, false); | 1213 | Qnil, false); |
| 1017 | Funintern (Qmodule_refs_hash, Qnil); | 1214 | Funintern (Qmodule_refs_hash, Qnil); |
| 1018 | 1215 | ||
| 1216 | DEFSYM (Qmodule_runtimes, "module-runtimes"); | ||
| 1217 | DEFVAR_LISP ("module-runtimes", Vmodule_runtimes, | ||
| 1218 | doc: /* List of active module runtimes. */); | ||
| 1219 | Vmodule_runtimes = Qnil; | ||
| 1220 | /* Unintern `module-runtimes' because it is only used | ||
| 1221 | internally. */ | ||
| 1222 | Funintern (Qmodule_runtimes, Qnil); | ||
| 1223 | |||
| 1019 | DEFSYM (Qmodule_environments, "module-environments"); | 1224 | DEFSYM (Qmodule_environments, "module-environments"); |
| 1020 | DEFVAR_LISP ("module-environments", Vmodule_environments, | 1225 | DEFVAR_LISP ("module-environments", Vmodule_environments, |
| 1021 | doc: /* List of active module environments. */); | 1226 | doc: /* List of active module environments. */); |