diff options
| author | Eli Zaretskii | 2019-03-21 21:29:52 +0200 |
|---|---|---|
| committer | Eli Zaretskii | 2019-03-21 21:29:52 +0200 |
| commit | 093d3e78d21d3d6c718997368ef4b31f9884401c (patch) | |
| tree | c0abe35a3b3cfee61fe793feb7684a0cdf3bce00 /src | |
| parent | ee7ad83f20903208404a84b58b7a478b62924570 (diff) | |
| download | emacs-093d3e78d21d3d6c718997368ef4b31f9884401c.tar.gz emacs-093d3e78d21d3d6c718997368ef4b31f9884401c.zip | |
Revert "Revert "Rely on conservative stack scanning to find "emacs_value"s""
This reverts commit ee7ad83f20903208404a84b58b7a478b62924570.
There was no consensus on reverting
3eb93c07f7a60ac9ce8a16f10c3afd5a3a31243a, so doing that will have to
wait until the discussion ends.
Diffstat (limited to 'src')
| -rw-r--r-- | src/emacs-module.c | 373 |
1 files changed, 198 insertions, 175 deletions
diff --git a/src/emacs-module.c b/src/emacs-module.c index df9a491a864..4e2411cb295 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c | |||
| @@ -25,7 +25,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ | |||
| 25 | #include <stddef.h> | 25 | #include <stddef.h> |
| 26 | #include <stdint.h> | 26 | #include <stdint.h> |
| 27 | #include <stdio.h> | 27 | #include <stdio.h> |
| 28 | #include <stdlib.h> | ||
| 29 | 28 | ||
| 30 | #include "lisp.h" | 29 | #include "lisp.h" |
| 31 | #include "dynlib.h" | 30 | #include "dynlib.h" |
| @@ -66,6 +65,18 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ | |||
| 66 | #include "w32term.h" | 65 | #include "w32term.h" |
| 67 | #endif | 66 | #endif |
| 68 | 67 | ||
| 68 | /* True if Lisp_Object and emacs_value have the same representation. | ||
| 69 | This is typically true unless WIDE_EMACS_INT. In practice, having | ||
| 70 | the same sizes and alignments and maximums should be a good enough | ||
| 71 | proxy for equality of representation. */ | ||
| 72 | enum | ||
| 73 | { | ||
| 74 | plain_values | ||
| 75 | = (sizeof (Lisp_Object) == sizeof (emacs_value) | ||
| 76 | && alignof (Lisp_Object) == alignof (emacs_value) | ||
| 77 | && INTPTR_MAX == EMACS_INT_MAX) | ||
| 78 | }; | ||
| 79 | |||
| 69 | /* Function prototype for the module init function. */ | 80 | /* Function prototype for the module init function. */ |
| 70 | typedef int (*emacs_init_function) (struct emacs_runtime *); | 81 | typedef int (*emacs_init_function) (struct emacs_runtime *); |
| 71 | 82 | ||
| @@ -76,43 +87,6 @@ typedef int (*emacs_init_function) (struct emacs_runtime *); | |||
| 76 | typedef void (*emacs_finalizer_function) (void *); | 87 | typedef void (*emacs_finalizer_function) (void *); |
| 77 | 88 | ||
| 78 | 89 | ||
| 79 | /* Memory management. */ | ||
| 80 | |||
| 81 | /* An `emacs_value' is just a pointer to a structure holding an | ||
| 82 | internal Lisp object. */ | ||
| 83 | struct emacs_value_tag { Lisp_Object v; }; | ||
| 84 | |||
| 85 | /* Local value objects use a simple fixed-sized block allocation | ||
| 86 | scheme without explicit deallocation. All local values are | ||
| 87 | deallocated when the lifetime of their environment ends. Keep | ||
| 88 | track of a current frame from which new values are allocated, | ||
| 89 | appending further dynamically-allocated frames if necessary. */ | ||
| 90 | |||
| 91 | enum { value_frame_size = 512 }; | ||
| 92 | |||
| 93 | /* A block from which `emacs_value' object can be allocated. */ | ||
| 94 | struct emacs_value_frame | ||
| 95 | { | ||
| 96 | /* Storage for values. */ | ||
| 97 | struct emacs_value_tag objects[value_frame_size]; | ||
| 98 | |||
| 99 | /* Index of the next free value in `objects'. */ | ||
| 100 | int offset; | ||
| 101 | |||
| 102 | /* Pointer to next frame, if any. */ | ||
| 103 | struct emacs_value_frame *next; | ||
| 104 | }; | ||
| 105 | |||
| 106 | /* A structure that holds an initial frame (so that the first local | ||
| 107 | values require no dynamic allocation) and keeps track of the | ||
| 108 | current frame. */ | ||
| 109 | static struct emacs_value_storage | ||
| 110 | { | ||
| 111 | struct emacs_value_frame initial; | ||
| 112 | struct emacs_value_frame *current; | ||
| 113 | } global_storage; | ||
| 114 | |||
| 115 | |||
| 116 | /* Private runtime and environment members. */ | 90 | /* Private runtime and environment members. */ |
| 117 | 91 | ||
| 118 | /* The private part of an environment stores the current non local exit state | 92 | /* The private part of an environment stores the current non local exit state |
| @@ -125,9 +99,12 @@ struct emacs_env_private | |||
| 125 | /* Dedicated storage for non-local exit symbol and data so that | 99 | /* Dedicated storage for non-local exit symbol and data so that |
| 126 | storage is always available for them, even in an out-of-memory | 100 | storage is always available for them, even in an out-of-memory |
| 127 | situation. */ | 101 | situation. */ |
| 128 | struct emacs_value_tag non_local_exit_symbol, non_local_exit_data; | 102 | Lisp_Object non_local_exit_symbol, non_local_exit_data; |
| 129 | 103 | ||
| 130 | struct emacs_value_storage storage; | 104 | /* List of values allocated from this environment. The code uses |
| 105 | this only if the user gave the -module-assertions command-line | ||
| 106 | option. */ | ||
| 107 | Lisp_Object values; | ||
| 131 | }; | 108 | }; |
| 132 | 109 | ||
| 133 | /* The private parts of an `emacs_runtime' object contain the initial | 110 | /* The private parts of an `emacs_runtime' object contain the initial |
| @@ -141,7 +118,6 @@ struct emacs_runtime_private | |||
| 141 | /* Forward declarations. */ | 118 | /* Forward declarations. */ |
| 142 | 119 | ||
| 143 | static Lisp_Object value_to_lisp (emacs_value); | 120 | static Lisp_Object value_to_lisp (emacs_value); |
| 144 | static emacs_value allocate_emacs_value (emacs_env *, struct emacs_value_storage *, Lisp_Object); | ||
| 145 | static emacs_value lisp_to_value (emacs_env *, Lisp_Object); | 121 | static emacs_value lisp_to_value (emacs_env *, Lisp_Object); |
| 146 | static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *); | 122 | static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *); |
| 147 | static void module_assert_thread (void); | 123 | static void module_assert_thread (void); |
| @@ -163,7 +139,16 @@ static void module_non_local_exit_throw_1 (emacs_env *, | |||
| 163 | static void module_out_of_memory (emacs_env *); | 139 | static void module_out_of_memory (emacs_env *); |
| 164 | static void module_reset_handlerlist (struct handler **); | 140 | static void module_reset_handlerlist (struct handler **); |
| 165 | 141 | ||
| 142 | /* We used to return NULL when emacs_value was a different type from | ||
| 143 | Lisp_Object, but nowadays we just use Qnil instead. Although they | ||
| 144 | happen to be the same thing in the current implementation, module | ||
| 145 | code should not assume this. */ | ||
| 146 | verify (NIL_IS_ZERO); | ||
| 147 | static emacs_value const module_nil = 0; | ||
| 148 | |||
| 166 | static bool module_assertions = false; | 149 | static bool module_assertions = false; |
| 150 | static emacs_env *global_env; | ||
| 151 | static struct emacs_env_private global_env_private; | ||
| 167 | 152 | ||
| 168 | /* Convenience macros for non-local exit handling. */ | 153 | /* Convenience macros for non-local exit handling. */ |
| 169 | 154 | ||
| @@ -308,7 +293,7 @@ module_get_environment (struct emacs_runtime *ert) | |||
| 308 | static emacs_value | 293 | static emacs_value |
| 309 | module_make_global_ref (emacs_env *env, emacs_value ref) | 294 | module_make_global_ref (emacs_env *env, emacs_value ref) |
| 310 | { | 295 | { |
| 311 | MODULE_FUNCTION_BEGIN (NULL); | 296 | MODULE_FUNCTION_BEGIN (module_nil); |
| 312 | struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); | 297 | struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); |
| 313 | Lisp_Object new_obj = value_to_lisp (ref); | 298 | Lisp_Object new_obj = value_to_lisp (ref); |
| 314 | EMACS_UINT hashcode; | 299 | EMACS_UINT hashcode; |
| @@ -328,7 +313,7 @@ module_make_global_ref (emacs_env *env, emacs_value ref) | |||
| 328 | hash_put (h, new_obj, make_fixed_natnum (1), hashcode); | 313 | hash_put (h, new_obj, make_fixed_natnum (1), hashcode); |
| 329 | } | 314 | } |
| 330 | 315 | ||
| 331 | return allocate_emacs_value (env, &global_storage, new_obj); | 316 | return lisp_to_value (module_assertions ? global_env : env, new_obj); |
| 332 | } | 317 | } |
| 333 | 318 | ||
| 334 | static void | 319 | static void |
| @@ -356,16 +341,23 @@ module_free_global_ref (emacs_env *env, emacs_value ref) | |||
| 356 | 341 | ||
| 357 | if (module_assertions) | 342 | if (module_assertions) |
| 358 | { | 343 | { |
| 344 | Lisp_Object globals = global_env_private.values; | ||
| 345 | Lisp_Object prev = Qnil; | ||
| 359 | ptrdiff_t count = 0; | 346 | ptrdiff_t count = 0; |
| 360 | for (struct emacs_value_frame *frame = &global_storage.initial; | 347 | for (Lisp_Object tail = globals; CONSP (tail); |
| 361 | frame != NULL; frame = frame->next) | 348 | tail = XCDR (tail)) |
| 362 | { | 349 | { |
| 363 | for (int i = 0; i < frame->offset; ++i) | 350 | emacs_value global = xmint_pointer (XCAR (tail)); |
| 351 | if (global == ref) | ||
| 364 | { | 352 | { |
| 365 | if (&frame->objects[i] == ref) | 353 | if (NILP (prev)) |
| 366 | return; | 354 | global_env_private.values = XCDR (globals); |
| 367 | ++count; | 355 | else |
| 356 | XSETCDR (prev, XCDR (tail)); | ||
| 357 | return; | ||
| 368 | } | 358 | } |
| 359 | ++count; | ||
| 360 | prev = tail; | ||
| 369 | } | 361 | } |
| 370 | module_abort ("Global value was not found in list of %"pD"d globals", | 362 | module_abort ("Global value was not found in list of %"pD"d globals", |
| 371 | count); | 363 | count); |
| @@ -396,8 +388,9 @@ module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) | |||
| 396 | struct emacs_env_private *p = env->private_members; | 388 | struct emacs_env_private *p = env->private_members; |
| 397 | if (p->pending_non_local_exit != emacs_funcall_exit_return) | 389 | if (p->pending_non_local_exit != emacs_funcall_exit_return) |
| 398 | { | 390 | { |
| 399 | *sym = &p->non_local_exit_symbol; | 391 | /* FIXME: lisp_to_value can exit non-locally. */ |
| 400 | *data = &p->non_local_exit_data; | 392 | *sym = lisp_to_value (env, p->non_local_exit_symbol); |
| 393 | *data = lisp_to_value (env, p->non_local_exit_data); | ||
| 401 | } | 394 | } |
| 402 | return p->pending_non_local_exit; | 395 | return p->pending_non_local_exit; |
| 403 | } | 396 | } |
| @@ -441,7 +434,7 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, | |||
| 441 | emacs_subr subr, const char *documentation, | 434 | emacs_subr subr, const char *documentation, |
| 442 | void *data) | 435 | void *data) |
| 443 | { | 436 | { |
| 444 | MODULE_FUNCTION_BEGIN (NULL); | 437 | MODULE_FUNCTION_BEGIN (module_nil); |
| 445 | 438 | ||
| 446 | if (! (0 <= min_arity | 439 | if (! (0 <= min_arity |
| 447 | && (max_arity < 0 | 440 | && (max_arity < 0 |
| @@ -474,7 +467,7 @@ static emacs_value | |||
| 474 | module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, | 467 | module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, |
| 475 | emacs_value args[]) | 468 | emacs_value args[]) |
| 476 | { | 469 | { |
| 477 | MODULE_FUNCTION_BEGIN (NULL); | 470 | MODULE_FUNCTION_BEGIN (module_nil); |
| 478 | 471 | ||
| 479 | /* Make a new Lisp_Object array starting with the function as the | 472 | /* Make a new Lisp_Object array starting with the function as the |
| 480 | first arg, because that's what Ffuncall takes. */ | 473 | first arg, because that's what Ffuncall takes. */ |
| @@ -495,14 +488,14 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, | |||
| 495 | static emacs_value | 488 | static emacs_value |
| 496 | module_intern (emacs_env *env, const char *name) | 489 | module_intern (emacs_env *env, const char *name) |
| 497 | { | 490 | { |
| 498 | MODULE_FUNCTION_BEGIN (NULL); | 491 | MODULE_FUNCTION_BEGIN (module_nil); |
| 499 | return lisp_to_value (env, intern (name)); | 492 | return lisp_to_value (env, intern (name)); |
| 500 | } | 493 | } |
| 501 | 494 | ||
| 502 | static emacs_value | 495 | static emacs_value |
| 503 | module_type_of (emacs_env *env, emacs_value value) | 496 | module_type_of (emacs_env *env, emacs_value value) |
| 504 | { | 497 | { |
| 505 | MODULE_FUNCTION_BEGIN (NULL); | 498 | MODULE_FUNCTION_BEGIN (module_nil); |
| 506 | return lisp_to_value (env, Ftype_of (value_to_lisp (value))); | 499 | return lisp_to_value (env, Ftype_of (value_to_lisp (value))); |
| 507 | } | 500 | } |
| 508 | 501 | ||
| @@ -535,7 +528,7 @@ module_extract_integer (emacs_env *env, emacs_value n) | |||
| 535 | static emacs_value | 528 | static emacs_value |
| 536 | module_make_integer (emacs_env *env, intmax_t n) | 529 | module_make_integer (emacs_env *env, intmax_t n) |
| 537 | { | 530 | { |
| 538 | MODULE_FUNCTION_BEGIN (NULL); | 531 | MODULE_FUNCTION_BEGIN (module_nil); |
| 539 | return lisp_to_value (env, make_int (n)); | 532 | return lisp_to_value (env, make_int (n)); |
| 540 | } | 533 | } |
| 541 | 534 | ||
| @@ -551,7 +544,7 @@ module_extract_float (emacs_env *env, emacs_value f) | |||
| 551 | static emacs_value | 544 | static emacs_value |
| 552 | module_make_float (emacs_env *env, double d) | 545 | module_make_float (emacs_env *env, double d) |
| 553 | { | 546 | { |
| 554 | MODULE_FUNCTION_BEGIN (NULL); | 547 | MODULE_FUNCTION_BEGIN (module_nil); |
| 555 | return lisp_to_value (env, make_float (d)); | 548 | return lisp_to_value (env, make_float (d)); |
| 556 | } | 549 | } |
| 557 | 550 | ||
| @@ -588,7 +581,7 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, | |||
| 588 | static emacs_value | 581 | static emacs_value |
| 589 | module_make_string (emacs_env *env, const char *str, ptrdiff_t length) | 582 | module_make_string (emacs_env *env, const char *str, ptrdiff_t length) |
| 590 | { | 583 | { |
| 591 | MODULE_FUNCTION_BEGIN (NULL); | 584 | MODULE_FUNCTION_BEGIN (module_nil); |
| 592 | if (! (0 <= length && length <= STRING_BYTES_BOUND)) | 585 | if (! (0 <= length && length <= STRING_BYTES_BOUND)) |
| 593 | overflow_error (); | 586 | overflow_error (); |
| 594 | /* FIXME: AUTO_STRING_WITH_LEN requires STR to be null-terminated, | 587 | /* FIXME: AUTO_STRING_WITH_LEN requires STR to be null-terminated, |
| @@ -601,7 +594,7 @@ module_make_string (emacs_env *env, const char *str, ptrdiff_t length) | |||
| 601 | static emacs_value | 594 | static emacs_value |
| 602 | module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) | 595 | module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) |
| 603 | { | 596 | { |
| 604 | MODULE_FUNCTION_BEGIN (NULL); | 597 | MODULE_FUNCTION_BEGIN (module_nil); |
| 605 | return lisp_to_value (env, make_user_ptr (fin, ptr)); | 598 | return lisp_to_value (env, make_user_ptr (fin, ptr)); |
| 606 | } | 599 | } |
| 607 | 600 | ||
| @@ -663,7 +656,7 @@ module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) | |||
| 663 | static emacs_value | 656 | static emacs_value |
| 664 | module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) | 657 | module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) |
| 665 | { | 658 | { |
| 666 | MODULE_FUNCTION_BEGIN (NULL); | 659 | MODULE_FUNCTION_BEGIN (module_nil); |
| 667 | Lisp_Object lvec = value_to_lisp (vec); | 660 | Lisp_Object lvec = value_to_lisp (vec); |
| 668 | check_vec_index (lvec, i); | 661 | check_vec_index (lvec, i); |
| 669 | return lisp_to_value (env, AREF (lvec, i)); | 662 | return lisp_to_value (env, AREF (lvec, i)); |
| @@ -706,11 +699,9 @@ module_signal_or_throw (struct emacs_env_private *env) | |||
| 706 | case emacs_funcall_exit_return: | 699 | case emacs_funcall_exit_return: |
| 707 | return; | 700 | return; |
| 708 | case emacs_funcall_exit_signal: | 701 | case emacs_funcall_exit_signal: |
| 709 | xsignal (value_to_lisp (&env->non_local_exit_symbol), | 702 | xsignal (env->non_local_exit_symbol, env->non_local_exit_data); |
| 710 | value_to_lisp (&env->non_local_exit_data)); | ||
| 711 | case emacs_funcall_exit_throw: | 703 | case emacs_funcall_exit_throw: |
| 712 | Fthrow (value_to_lisp (&env->non_local_exit_symbol), | 704 | Fthrow (env->non_local_exit_symbol, env->non_local_exit_data); |
| 713 | value_to_lisp (&env->non_local_exit_data)); | ||
| 714 | default: | 705 | default: |
| 715 | eassume (false); | 706 | eassume (false); |
| 716 | } | 707 | } |
| @@ -786,12 +777,17 @@ funcall_module (Lisp_Object function, ptrdiff_t nargs, Lisp_Object *arglist) | |||
| 786 | record_unwind_protect_ptr (finalize_environment_unwind, env); | 777 | record_unwind_protect_ptr (finalize_environment_unwind, env); |
| 787 | 778 | ||
| 788 | USE_SAFE_ALLOCA; | 779 | USE_SAFE_ALLOCA; |
| 789 | emacs_value *args = nargs > 0 ? SAFE_ALLOCA (nargs * sizeof *args) : NULL; | 780 | ATTRIBUTE_MAY_ALIAS emacs_value *args; |
| 790 | for (ptrdiff_t i = 0; i < nargs; ++i) | 781 | if (plain_values && ! module_assertions) |
| 782 | /* FIXME: The cast below is incorrect because the argument array | ||
| 783 | is not declared as const, so module functions can modify it. | ||
| 784 | Either declare it as const, or remove this branch. */ | ||
| 785 | args = (emacs_value *) arglist; | ||
| 786 | else | ||
| 791 | { | 787 | { |
| 792 | args[i] = lisp_to_value (env, arglist[i]); | 788 | args = SAFE_ALLOCA (nargs * sizeof *args); |
| 793 | if (! args[i]) | 789 | for (ptrdiff_t i = 0; i < nargs; i++) |
| 794 | memory_full (sizeof *args[i]); | 790 | args[i] = lisp_to_value (env, arglist[i]); |
| 795 | } | 791 | } |
| 796 | 792 | ||
| 797 | emacs_value ret = func->subr (env, nargs, args, func->data); | 793 | emacs_value ret = func->subr (env, nargs, args, func->data); |
| @@ -871,8 +867,8 @@ module_non_local_exit_signal_1 (emacs_env *env, Lisp_Object sym, | |||
| 871 | if (p->pending_non_local_exit == emacs_funcall_exit_return) | 867 | if (p->pending_non_local_exit == emacs_funcall_exit_return) |
| 872 | { | 868 | { |
| 873 | p->pending_non_local_exit = emacs_funcall_exit_signal; | 869 | p->pending_non_local_exit = emacs_funcall_exit_signal; |
| 874 | p->non_local_exit_symbol.v = sym; | 870 | p->non_local_exit_symbol = sym; |
| 875 | p->non_local_exit_data.v = data; | 871 | p->non_local_exit_data = data; |
| 876 | } | 872 | } |
| 877 | } | 873 | } |
| 878 | 874 | ||
| @@ -884,8 +880,8 @@ module_non_local_exit_throw_1 (emacs_env *env, Lisp_Object tag, | |||
| 884 | if (p->pending_non_local_exit == emacs_funcall_exit_return) | 880 | if (p->pending_non_local_exit == emacs_funcall_exit_return) |
| 885 | { | 881 | { |
| 886 | p->pending_non_local_exit = emacs_funcall_exit_throw; | 882 | p->pending_non_local_exit = emacs_funcall_exit_throw; |
| 887 | p->non_local_exit_symbol.v = tag; | 883 | p->non_local_exit_symbol = tag; |
| 888 | p->non_local_exit_data.v = value; | 884 | p->non_local_exit_data = value; |
| 889 | } | 885 | } |
| 890 | } | 886 | } |
| 891 | 887 | ||
| @@ -902,8 +898,54 @@ module_out_of_memory (emacs_env *env) | |||
| 902 | 898 | ||
| 903 | /* Value conversion. */ | 899 | /* Value conversion. */ |
| 904 | 900 | ||
| 905 | /* Convert an `emacs_value' to the corresponding internal object. | 901 | /* We represent Lisp objects differently depending on whether the user |
| 906 | Never fails. */ | 902 | gave -module-assertions. If assertions are disabled, emacs_value |
| 903 | objects are Lisp_Objects cast to emacs_value. If assertions are | ||
| 904 | enabled, emacs_value objects are pointers to Lisp_Object objects | ||
| 905 | allocated from the free store; they are never freed, which ensures | ||
| 906 | that their addresses are unique and can be used for liveness | ||
| 907 | checking. */ | ||
| 908 | |||
| 909 | /* Unique Lisp_Object used to mark those emacs_values which are really | ||
| 910 | just containers holding a Lisp_Object that does not fit as an emacs_value, | ||
| 911 | either because it is an integer out of range, or is not properly aligned. | ||
| 912 | Used only if !plain_values. */ | ||
| 913 | static Lisp_Object ltv_mark; | ||
| 914 | |||
| 915 | /* Convert V to the corresponding internal object O, such that | ||
| 916 | V == lisp_to_value_bits (O). Never fails. */ | ||
| 917 | static Lisp_Object | ||
| 918 | value_to_lisp_bits (emacs_value v) | ||
| 919 | { | ||
| 920 | if (plain_values || USE_LSB_TAG) | ||
| 921 | return XPL (v); | ||
| 922 | |||
| 923 | /* With wide EMACS_INT and when tag bits are the most significant, | ||
| 924 | reassembling integers differs from reassembling pointers in two | ||
| 925 | ways. First, save and restore the least-significant bits of the | ||
| 926 | integer, not the most-significant bits. Second, sign-extend the | ||
| 927 | integer when restoring, but zero-extend pointers because that | ||
| 928 | makes TAG_PTR faster. */ | ||
| 929 | |||
| 930 | intptr_t i = (intptr_t) v; | ||
| 931 | EMACS_UINT tag = i & ((1 << GCTYPEBITS) - 1); | ||
| 932 | EMACS_UINT untagged = i - tag; | ||
| 933 | switch (tag) | ||
| 934 | { | ||
| 935 | case_Lisp_Int: | ||
| 936 | { | ||
| 937 | bool negative = tag & 1; | ||
| 938 | EMACS_UINT sign_extension | ||
| 939 | = negative ? VALMASK & ~(INTPTR_MAX >> INTTYPEBITS): 0; | ||
| 940 | uintptr_t u = i; | ||
| 941 | intptr_t all_but_sign = u >> GCTYPEBITS; | ||
| 942 | untagged = sign_extension + all_but_sign; | ||
| 943 | break; | ||
| 944 | } | ||
| 945 | } | ||
| 946 | |||
| 947 | return XIL ((tag << VALBITS) + untagged); | ||
| 948 | } | ||
| 907 | 949 | ||
| 908 | /* If V was computed from lisp_to_value (O), then return O. | 950 | /* If V was computed from lisp_to_value (O), then return O. |
| 909 | Exits non-locally only if the stack overflows. */ | 951 | Exits non-locally only if the stack overflows. */ |
| @@ -914,134 +956,91 @@ value_to_lisp (emacs_value v) | |||
| 914 | { | 956 | { |
| 915 | /* Check the liveness of the value by iterating over all live | 957 | /* Check the liveness of the value by iterating over all live |
| 916 | environments. */ | 958 | environments. */ |
| 959 | void *vptr = v; | ||
| 960 | ATTRIBUTE_MAY_ALIAS Lisp_Object *optr = vptr; | ||
| 917 | ptrdiff_t num_environments = 0; | 961 | ptrdiff_t num_environments = 0; |
| 918 | ptrdiff_t num_values = 0; | 962 | ptrdiff_t num_values = 0; |
| 919 | for (Lisp_Object environments = Vmodule_environments; | 963 | for (Lisp_Object environments = Vmodule_environments; |
| 920 | CONSP (environments); environments = XCDR (environments)) | 964 | CONSP (environments); environments = XCDR (environments)) |
| 921 | { | 965 | { |
| 922 | emacs_env *env = xmint_pointer (XCAR (environments)); | 966 | emacs_env *env = xmint_pointer (XCAR (environments)); |
| 923 | struct emacs_env_private *priv = env->private_members; | 967 | for (Lisp_Object values = env->private_members->values; |
| 924 | /* The value might be one of the nonlocal exit values. Note | 968 | CONSP (values); values = XCDR (values)) |
| 925 | that we don't check whether a nonlocal exit is currently | ||
| 926 | pending, because the module might have cleared the flag | ||
| 927 | in the meantime. */ | ||
| 928 | if (&priv->non_local_exit_symbol == v | ||
| 929 | || &priv->non_local_exit_data == v) | ||
| 930 | goto ok; | ||
| 931 | for (struct emacs_value_frame *frame = &priv->storage.initial; | ||
| 932 | frame != NULL; frame = frame->next) | ||
| 933 | { | 969 | { |
| 934 | for (int i = 0; i < frame->offset; ++i) | 970 | Lisp_Object *p = xmint_pointer (XCAR (values)); |
| 935 | { | 971 | if (p == optr) |
| 936 | if (&frame->objects[i] == v) | 972 | return *p; |
| 937 | goto ok; | ||
| 938 | ++num_values; | ||
| 939 | } | ||
| 940 | } | ||
| 941 | ++num_environments; | ||
| 942 | } | ||
| 943 | /* Also check global values. */ | ||
| 944 | for (struct emacs_value_frame *frame = &global_storage.initial; | ||
| 945 | frame != NULL; frame = frame->next) | ||
| 946 | { | ||
| 947 | for (int i = 0; i < frame->offset; ++i) | ||
| 948 | { | ||
| 949 | if (&frame->objects[i] == v) | ||
| 950 | goto ok; | ||
| 951 | ++num_values; | 973 | ++num_values; |
| 952 | } | 974 | } |
| 975 | ++num_environments; | ||
| 953 | } | 976 | } |
| 954 | module_abort (("Emacs value not found in %"pD"d values " | 977 | module_abort (("Emacs value not found in %"pD"d values " |
| 955 | "of %"pD"d environments"), | 978 | "of %"pD"d environments"), |
| 956 | num_values, num_environments); | 979 | num_values, num_environments); |
| 957 | } | 980 | } |
| 958 | 981 | ||
| 959 | ok: return v->v; | 982 | Lisp_Object o = value_to_lisp_bits (v); |
| 983 | if (! plain_values && CONSP (o) && EQ (XCDR (o), ltv_mark)) | ||
| 984 | o = XCAR (o); | ||
| 985 | return o; | ||
| 960 | } | 986 | } |
| 961 | 987 | ||
| 962 | /* Convert an internal object to an `emacs_value'. Allocate storage | 988 | /* Attempt to convert O to an emacs_value. Do not do any checking |
| 963 | from the environment; return NULL if allocation fails. */ | 989 | or allocate any storage; the caller should prevent or detect |
| 990 | any resulting bit pattern that is not a valid emacs_value. */ | ||
| 964 | static emacs_value | 991 | static emacs_value |
| 965 | lisp_to_value (emacs_env *env, Lisp_Object o) | 992 | lisp_to_value_bits (Lisp_Object o) |
| 966 | { | 993 | { |
| 967 | struct emacs_env_private *p = env->private_members; | 994 | if (plain_values || USE_LSB_TAG) |
| 968 | if (p->pending_non_local_exit != emacs_funcall_exit_return) | 995 | return XLP (o); |
| 969 | return NULL; | ||
| 970 | return allocate_emacs_value (env, &p->storage, o); | ||
| 971 | } | ||
| 972 | 996 | ||
| 973 | /* Must be called for each frame before it can be used for allocation. */ | 997 | /* Compress O into the space of a pointer, possibly losing information. */ |
| 974 | static void | 998 | EMACS_UINT u = XLI (o); |
| 975 | initialize_frame (struct emacs_value_frame *frame) | 999 | if (FIXNUMP (o)) |
| 976 | { | ||
| 977 | frame->offset = 0; | ||
| 978 | frame->next = NULL; | ||
| 979 | } | ||
| 980 | |||
| 981 | /* Must be called for any storage object before it can be used for | ||
| 982 | allocation. */ | ||
| 983 | static void | ||
| 984 | initialize_storage (struct emacs_value_storage *storage) | ||
| 985 | { | ||
| 986 | initialize_frame (&storage->initial); | ||
| 987 | storage->current = &storage->initial; | ||
| 988 | } | ||
| 989 | |||
| 990 | /* Must be called for any initialized storage object before its | ||
| 991 | lifetime ends. Free all dynamically-allocated frames. */ | ||
| 992 | static void | ||
| 993 | finalize_storage (struct emacs_value_storage *storage) | ||
| 994 | { | ||
| 995 | struct emacs_value_frame *next = storage->initial.next; | ||
| 996 | while (next != NULL) | ||
| 997 | { | 1000 | { |
| 998 | struct emacs_value_frame *current = next; | 1001 | uintptr_t i = (u << VALBITS) + XTYPE (o); |
| 999 | next = current->next; | 1002 | return (emacs_value) i; |
| 1000 | free (current); | 1003 | } |
| 1004 | else | ||
| 1005 | { | ||
| 1006 | char *p = XLP (o); | ||
| 1007 | void *v = p - (u & ~VALMASK) + XTYPE (o); | ||
| 1008 | return v; | ||
| 1001 | } | 1009 | } |
| 1002 | } | 1010 | } |
| 1003 | 1011 | ||
| 1004 | /* Allocate a new value from STORAGE and stores OBJ in it. Return | 1012 | /* Convert O to an emacs_value. Allocate storage if needed; this can |
| 1005 | NULL if allocation fails and use ENV for non local exit reporting. */ | 1013 | signal if memory is exhausted. Must be an injective function. */ |
| 1006 | static emacs_value | 1014 | static emacs_value |
| 1007 | allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage, | 1015 | lisp_to_value (emacs_env *env, Lisp_Object o) |
| 1008 | Lisp_Object obj) | ||
| 1009 | { | 1016 | { |
| 1010 | eassert (storage->current); | 1017 | if (module_assertions) |
| 1011 | eassert (storage->current->offset < value_frame_size); | ||
| 1012 | eassert (! storage->current->next); | ||
| 1013 | if (storage->current->offset == value_frame_size - 1) | ||
| 1014 | { | 1018 | { |
| 1015 | storage->current->next = malloc (sizeof *storage->current->next); | 1019 | /* Add the new value to the list of values allocated from this |
| 1016 | if (! storage->current->next) | 1020 | environment. The value is actually a pointer to the |
| 1017 | { | 1021 | Lisp_Object cast to emacs_value. We make a copy of the |
| 1018 | module_out_of_memory (env); | 1022 | object on the free store to guarantee unique addresses. */ |
| 1019 | return NULL; | 1023 | ATTRIBUTE_MAY_ALIAS Lisp_Object *optr = xmalloc (sizeof o); |
| 1020 | } | 1024 | *optr = o; |
| 1021 | initialize_frame (storage->current->next); | 1025 | void *vptr = optr; |
| 1022 | storage->current = storage->current->next; | 1026 | ATTRIBUTE_MAY_ALIAS emacs_value ret = vptr; |
| 1027 | struct emacs_env_private *priv = env->private_members; | ||
| 1028 | priv->values = Fcons (make_mint_ptr (ret), priv->values); | ||
| 1029 | return ret; | ||
| 1023 | } | 1030 | } |
| 1024 | emacs_value value = storage->current->objects + storage->current->offset; | ||
| 1025 | value->v = obj; | ||
| 1026 | ++storage->current->offset; | ||
| 1027 | return value; | ||
| 1028 | } | ||
| 1029 | 1031 | ||
| 1030 | /* Mark all objects allocated from local environments so that they | 1032 | emacs_value v = lisp_to_value_bits (o); |
| 1031 | don't get garbage-collected. */ | 1033 | |
| 1032 | void | 1034 | if (! EQ (o, value_to_lisp_bits (v))) |
| 1033 | mark_modules (void) | ||
| 1034 | { | ||
| 1035 | for (Lisp_Object tem = Vmodule_environments; CONSP (tem); tem = XCDR (tem)) | ||
| 1036 | { | 1035 | { |
| 1037 | emacs_env *env = xmint_pointer (XCAR (tem)); | 1036 | /* Package the incompressible object pointer inside a pair |
| 1038 | struct emacs_env_private *priv = env->private_members; | 1037 | that is compressible. */ |
| 1039 | for (struct emacs_value_frame *frame = &priv->storage.initial; | 1038 | Lisp_Object pair = Fcons (o, ltv_mark); |
| 1040 | frame != NULL; | 1039 | v = (emacs_value) ((intptr_t) XCONS (pair) + Lisp_Cons); |
| 1041 | frame = frame->next) | ||
| 1042 | for (int i = 0; i < frame->offset; ++i) | ||
| 1043 | mark_object (frame->objects[i].v); | ||
| 1044 | } | 1040 | } |
| 1041 | |||
| 1042 | eassert (EQ (o, value_to_lisp (v))); | ||
| 1043 | return v; | ||
| 1045 | } | 1044 | } |
| 1046 | 1045 | ||
| 1047 | 1046 | ||
| @@ -1060,7 +1059,7 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) | |||
| 1060 | env = xmalloc (sizeof *env); | 1059 | env = xmalloc (sizeof *env); |
| 1061 | 1060 | ||
| 1062 | priv->pending_non_local_exit = emacs_funcall_exit_return; | 1061 | priv->pending_non_local_exit = emacs_funcall_exit_return; |
| 1063 | initialize_storage (&priv->storage); | 1062 | priv->values = priv->non_local_exit_symbol = priv->non_local_exit_data = Qnil; |
| 1064 | env->size = sizeof *env; | 1063 | env->size = sizeof *env; |
| 1065 | env->private_members = priv; | 1064 | env->private_members = priv; |
| 1066 | env->make_global_ref = module_make_global_ref; | 1065 | env->make_global_ref = module_make_global_ref; |
| @@ -1101,9 +1100,11 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) | |||
| 1101 | static void | 1100 | static void |
| 1102 | finalize_environment (emacs_env *env) | 1101 | finalize_environment (emacs_env *env) |
| 1103 | { | 1102 | { |
| 1104 | finalize_storage (&env->private_members->storage); | ||
| 1105 | eassert (xmint_pointer (XCAR (Vmodule_environments)) == env); | 1103 | eassert (xmint_pointer (XCAR (Vmodule_environments)) == env); |
| 1106 | Vmodule_environments = XCDR (Vmodule_environments); | 1104 | Vmodule_environments = XCDR (Vmodule_environments); |
| 1105 | if (module_assertions) | ||
| 1106 | /* There is always at least the global environment. */ | ||
| 1107 | eassert (CONSP (Vmodule_environments)); | ||
| 1107 | } | 1108 | } |
| 1108 | 1109 | ||
| 1109 | static void | 1110 | static void |
| @@ -1121,6 +1122,20 @@ finalize_runtime_unwind (void *raw_ert) | |||
| 1121 | finalize_environment (ert->private_members->env); | 1122 | finalize_environment (ert->private_members->env); |
| 1122 | } | 1123 | } |
| 1123 | 1124 | ||
| 1125 | void | ||
| 1126 | mark_modules (void) | ||
| 1127 | { | ||
| 1128 | for (Lisp_Object tail = Vmodule_environments; CONSP (tail); | ||
| 1129 | tail = XCDR (tail)) | ||
| 1130 | { | ||
| 1131 | emacs_env *env = xmint_pointer (XCAR (tail)); | ||
| 1132 | struct emacs_env_private *priv = env->private_members; | ||
| 1133 | mark_object (priv->non_local_exit_symbol); | ||
| 1134 | mark_object (priv->non_local_exit_data); | ||
| 1135 | mark_object (priv->values); | ||
| 1136 | } | ||
| 1137 | } | ||
| 1138 | |||
| 1124 | 1139 | ||
| 1125 | /* Non-local exit handling. */ | 1140 | /* Non-local exit handling. */ |
| 1126 | 1141 | ||
| @@ -1160,7 +1175,8 @@ init_module_assertions (bool enable) | |||
| 1160 | /* If enabling module assertions, use a hidden environment for | 1175 | /* If enabling module assertions, use a hidden environment for |
| 1161 | storing the globals. This environment is never freed. */ | 1176 | storing the globals. This environment is never freed. */ |
| 1162 | module_assertions = enable; | 1177 | module_assertions = enable; |
| 1163 | initialize_storage (&global_storage); | 1178 | if (enable) |
| 1179 | global_env = initialize_environment (NULL, &global_env_private); | ||
| 1164 | } | 1180 | } |
| 1165 | 1181 | ||
| 1166 | static _Noreturn void | 1182 | static _Noreturn void |
| @@ -1183,6 +1199,13 @@ module_abort (const char *format, ...) | |||
| 1183 | void | 1199 | void |
| 1184 | syms_of_module (void) | 1200 | syms_of_module (void) |
| 1185 | { | 1201 | { |
| 1202 | if (!plain_values) | ||
| 1203 | { | ||
| 1204 | ltv_mark = Fcons (Qnil, Qnil); | ||
| 1205 | staticpro (<v_mark); | ||
| 1206 | } | ||
| 1207 | eassert (NILP (value_to_lisp (module_nil))); | ||
| 1208 | |||
| 1186 | DEFSYM (Qmodule_refs_hash, "module-refs-hash"); | 1209 | DEFSYM (Qmodule_refs_hash, "module-refs-hash"); |
| 1187 | DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash, | 1210 | DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash, |
| 1188 | doc: /* Module global reference table. */); | 1211 | doc: /* Module global reference table. */); |