diff options
| author | Stefan Kangas | 2025-02-01 04:56:52 +0100 |
|---|---|---|
| committer | Stefan Kangas | 2025-02-01 04:56:52 +0100 |
| commit | bf97946d7dc460b7d3c3ce03193041b891b51faf (patch) | |
| tree | c799f87903ca3dcba8b804bd185b519aacc0a636 /src/alloc.c | |
| parent | a4a0957b6b3b1db858524ac6d4dc3d951f65960b (diff) | |
| parent | aa07e94439c663f768c32a689d14506d25a7a5bc (diff) | |
| download | emacs-bf97946d7dc460b7d3c3ce03193041b891b51faf.tar.gz emacs-bf97946d7dc460b7d3c3ce03193041b891b51faf.zip | |
Merge branch 'scratch/no-purespace' into 'master'
Diffstat (limited to 'src/alloc.c')
| -rw-r--r-- | src/alloc.c | 734 |
1 files changed, 90 insertions, 644 deletions
diff --git a/src/alloc.c b/src/alloc.c index b13c3e49224..40a59854a87 100644 --- a/src/alloc.c +++ b/src/alloc.c | |||
| @@ -33,7 +33,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ | |||
| 33 | #include "bignum.h" | 33 | #include "bignum.h" |
| 34 | #include "dispextern.h" | 34 | #include "dispextern.h" |
| 35 | #include "intervals.h" | 35 | #include "intervals.h" |
| 36 | #include "puresize.h" | ||
| 37 | #include "sysstdio.h" | 36 | #include "sysstdio.h" |
| 38 | #include "systime.h" | 37 | #include "systime.h" |
| 39 | #include "character.h" | 38 | #include "character.h" |
| @@ -127,7 +126,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ | |||
| 127 | marked objects. */ | 126 | marked objects. */ |
| 128 | 127 | ||
| 129 | #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \ | 128 | #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \ |
| 130 | || defined HYBRID_MALLOC || GC_CHECK_MARKED_OBJECTS) | 129 | || GC_CHECK_MARKED_OBJECTS) |
| 131 | #undef GC_MALLOC_CHECK | 130 | #undef GC_MALLOC_CHECK |
| 132 | #endif | 131 | #endif |
| 133 | 132 | ||
| @@ -210,10 +209,6 @@ enum { MALLOC_ALIGNMENT = max (2 * sizeof (size_t), alignof (long double)) }; | |||
| 210 | 209 | ||
| 211 | # define MMAP_MAX_AREAS 100000000 | 210 | # define MMAP_MAX_AREAS 100000000 |
| 212 | 211 | ||
| 213 | /* A pointer to the memory allocated that copies that static data | ||
| 214 | inside glibc's malloc. */ | ||
| 215 | static void *malloc_state_ptr; | ||
| 216 | |||
| 217 | /* Restore the dumped malloc state. Because malloc can be invoked | 212 | /* Restore the dumped malloc state. Because malloc can be invoked |
| 218 | even before main (e.g. by the dynamic linker), the dumped malloc | 213 | even before main (e.g. by the dynamic linker), the dumped malloc |
| 219 | state must be restored as early as possible using this special hook. */ | 214 | state must be restored as early as possible using this special hook. */ |
| @@ -224,9 +219,6 @@ malloc_initialize_hook (void) | |||
| 224 | 219 | ||
| 225 | if (! initialized) | 220 | if (! initialized) |
| 226 | { | 221 | { |
| 227 | # ifdef GNU_LINUX | ||
| 228 | my_heap_start (); | ||
| 229 | # endif | ||
| 230 | malloc_using_checking = getenv ("MALLOC_CHECK_") != NULL; | 222 | malloc_using_checking = getenv ("MALLOC_CHECK_") != NULL; |
| 231 | } | 223 | } |
| 232 | else | 224 | else |
| @@ -248,10 +240,6 @@ malloc_initialize_hook (void) | |||
| 248 | break; | 240 | break; |
| 249 | } | 241 | } |
| 250 | } | 242 | } |
| 251 | |||
| 252 | if (malloc_set_state (malloc_state_ptr) != 0) | ||
| 253 | emacs_abort (); | ||
| 254 | alloc_unexec_post (); | ||
| 255 | } | 243 | } |
| 256 | } | 244 | } |
| 257 | 245 | ||
| @@ -266,43 +254,6 @@ voidfuncptr __MALLOC_HOOK_VOLATILE __malloc_initialize_hook EXTERNALLY_VISIBLE | |||
| 266 | 254 | ||
| 267 | #endif | 255 | #endif |
| 268 | 256 | ||
| 269 | #if defined DOUG_LEA_MALLOC || defined HAVE_UNEXEC | ||
| 270 | |||
| 271 | /* Allocator-related actions to do just before and after unexec. */ | ||
| 272 | |||
| 273 | void | ||
| 274 | alloc_unexec_pre (void) | ||
| 275 | { | ||
| 276 | # ifdef DOUG_LEA_MALLOC | ||
| 277 | malloc_state_ptr = malloc_get_state (); | ||
| 278 | if (!malloc_state_ptr) | ||
| 279 | fatal ("malloc_get_state: %s", strerror (errno)); | ||
| 280 | # endif | ||
| 281 | } | ||
| 282 | |||
| 283 | void | ||
| 284 | alloc_unexec_post (void) | ||
| 285 | { | ||
| 286 | # ifdef DOUG_LEA_MALLOC | ||
| 287 | free (malloc_state_ptr); | ||
| 288 | # endif | ||
| 289 | } | ||
| 290 | |||
| 291 | # ifdef GNU_LINUX | ||
| 292 | |||
| 293 | /* The address where the heap starts. */ | ||
| 294 | void * | ||
| 295 | my_heap_start (void) | ||
| 296 | { | ||
| 297 | static void *start; | ||
| 298 | if (! start) | ||
| 299 | start = sbrk (0); | ||
| 300 | return start; | ||
| 301 | } | ||
| 302 | # endif | ||
| 303 | |||
| 304 | #endif | ||
| 305 | |||
| 306 | /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer | 257 | /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer |
| 307 | to a struct Lisp_String. */ | 258 | to a struct Lisp_String. */ |
| 308 | 259 | ||
| @@ -380,33 +331,6 @@ static char *spare_memory[7]; | |||
| 380 | 331 | ||
| 381 | #define SPARE_MEMORY (1 << 14) | 332 | #define SPARE_MEMORY (1 << 14) |
| 382 | 333 | ||
| 383 | /* Initialize it to a nonzero value to force it into data space | ||
| 384 | (rather than bss space). That way unexec will remap it into text | ||
| 385 | space (pure), on some systems. We have not implemented the | ||
| 386 | remapping on more recent systems because this is less important | ||
| 387 | nowadays than in the days of small memories and timesharing. */ | ||
| 388 | |||
| 389 | EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,}; | ||
| 390 | #define PUREBEG (char *) pure | ||
| 391 | |||
| 392 | /* Pointer to the pure area, and its size. */ | ||
| 393 | |||
| 394 | static char *purebeg; | ||
| 395 | static ptrdiff_t pure_size; | ||
| 396 | |||
| 397 | /* Number of bytes of pure storage used before pure storage overflowed. | ||
| 398 | If this is non-zero, this implies that an overflow occurred. */ | ||
| 399 | |||
| 400 | static ptrdiff_t pure_bytes_used_before_overflow; | ||
| 401 | |||
| 402 | /* Index in pure at which next pure Lisp object will be allocated.. */ | ||
| 403 | |||
| 404 | static ptrdiff_t pure_bytes_used_lisp; | ||
| 405 | |||
| 406 | /* Number of bytes allocated for non-Lisp objects in pure storage. */ | ||
| 407 | |||
| 408 | static ptrdiff_t pure_bytes_used_non_lisp; | ||
| 409 | |||
| 410 | /* If positive, garbage collection is inhibited. Otherwise, zero. */ | 334 | /* If positive, garbage collection is inhibited. Otherwise, zero. */ |
| 411 | 335 | ||
| 412 | intptr_t garbage_collection_inhibited; | 336 | intptr_t garbage_collection_inhibited; |
| @@ -457,10 +381,9 @@ static struct Lisp_Vector *allocate_clear_vector (ptrdiff_t, bool); | |||
| 457 | static void unchain_finalizer (struct Lisp_Finalizer *); | 381 | static void unchain_finalizer (struct Lisp_Finalizer *); |
| 458 | static void mark_terminals (void); | 382 | static void mark_terminals (void); |
| 459 | static void gc_sweep (void); | 383 | static void gc_sweep (void); |
| 460 | static Lisp_Object make_pure_vector (ptrdiff_t); | ||
| 461 | static void mark_buffer (struct buffer *); | 384 | static void mark_buffer (struct buffer *); |
| 462 | 385 | ||
| 463 | #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC | 386 | #if !defined REL_ALLOC || defined SYSTEM_MALLOC |
| 464 | static void refill_memory_reserve (void); | 387 | static void refill_memory_reserve (void); |
| 465 | #endif | 388 | #endif |
| 466 | static void compact_small_strings (void); | 389 | static void compact_small_strings (void); |
| @@ -570,29 +493,21 @@ static void mem_delete (struct mem_node *); | |||
| 570 | static void mem_delete_fixup (struct mem_node *); | 493 | static void mem_delete_fixup (struct mem_node *); |
| 571 | static struct mem_node *mem_find (void *); | 494 | static struct mem_node *mem_find (void *); |
| 572 | 495 | ||
| 573 | /* Addresses of staticpro'd variables. Initialize it to a nonzero | 496 | /* Addresses of staticpro'd variables. */ |
| 574 | value if we might unexec; otherwise some compilers put it into | ||
| 575 | BSS. */ | ||
| 576 | 497 | ||
| 577 | Lisp_Object const *staticvec[NSTATICS] | 498 | Lisp_Object const *staticvec[NSTATICS]; |
| 578 | #ifdef HAVE_UNEXEC | ||
| 579 | = {&Vpurify_flag} | ||
| 580 | #endif | ||
| 581 | ; | ||
| 582 | 499 | ||
| 583 | /* Index of next unused slot in staticvec. */ | 500 | /* Index of next unused slot in staticvec. */ |
| 584 | 501 | ||
| 585 | int staticidx; | 502 | int staticidx; |
| 586 | 503 | ||
| 587 | static void *pure_alloc (size_t, int); | 504 | #ifndef HAVE_ALIGNED_ALLOC |
| 588 | |||
| 589 | /* Return PTR rounded up to the next multiple of ALIGNMENT. */ | ||
| 590 | |||
| 591 | static void * | 505 | static void * |
| 592 | pointer_align (void *ptr, int alignment) | 506 | pointer_align (void *ptr, int alignment) |
| 593 | { | 507 | { |
| 594 | return (void *) ROUNDUP ((uintptr_t) ptr, alignment); | 508 | return (void *) ROUNDUP ((uintptr_t) ptr, alignment); |
| 595 | } | 509 | } |
| 510 | #endif | ||
| 596 | 511 | ||
| 597 | /* Extract the pointer hidden within O. */ | 512 | /* Extract the pointer hidden within O. */ |
| 598 | 513 | ||
| @@ -631,10 +546,8 @@ mmap_lisp_allowed_p (void) | |||
| 631 | { | 546 | { |
| 632 | /* If we can't store all memory addresses in our lisp objects, it's | 547 | /* If we can't store all memory addresses in our lisp objects, it's |
| 633 | risky to let the heap use mmap and give us addresses from all | 548 | risky to let the heap use mmap and give us addresses from all |
| 634 | over our address space. We also can't use mmap for lisp objects | 549 | over our address space. */ |
| 635 | if we might dump: unexec doesn't preserve the contents of mmapped | 550 | return pointers_fit_in_lispobj_p (); |
| 636 | regions. */ | ||
| 637 | return pointers_fit_in_lispobj_p () && !will_dump_with_unexec_p (); | ||
| 638 | } | 551 | } |
| 639 | #endif | 552 | #endif |
| 640 | 553 | ||
| @@ -652,7 +565,7 @@ struct Lisp_Finalizer doomed_finalizers; | |||
| 652 | Malloc | 565 | Malloc |
| 653 | ************************************************************************/ | 566 | ************************************************************************/ |
| 654 | 567 | ||
| 655 | #if defined SIGDANGER || (!defined SYSTEM_MALLOC && !defined HYBRID_MALLOC) | 568 | #if defined SIGDANGER || (!defined SYSTEM_MALLOC) |
| 656 | 569 | ||
| 657 | /* Function malloc calls this if it finds we are near exhausting storage. */ | 570 | /* Function malloc calls this if it finds we are near exhausting storage. */ |
| 658 | 571 | ||
| @@ -1074,26 +987,17 @@ lisp_free (void *block) | |||
| 1074 | BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */ | 987 | BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */ |
| 1075 | 988 | ||
| 1076 | /* Byte alignment of storage blocks. */ | 989 | /* Byte alignment of storage blocks. */ |
| 1077 | #ifdef HAVE_UNEXEC | ||
| 1078 | # define BLOCK_ALIGN (1 << 10) | ||
| 1079 | #else /* !HAVE_UNEXEC */ | ||
| 1080 | # define BLOCK_ALIGN (1 << 15) | 990 | # define BLOCK_ALIGN (1 << 15) |
| 1081 | #endif | ||
| 1082 | static_assert (POWER_OF_2 (BLOCK_ALIGN)); | 991 | static_assert (POWER_OF_2 (BLOCK_ALIGN)); |
| 1083 | 992 | ||
| 1084 | /* Use aligned_alloc if it or a simple substitute is available. | 993 | /* Use aligned_alloc if it or a simple substitute is available. */ |
| 1085 | Aligned allocation is incompatible with unexmacosx.c, so don't use | 994 | |
| 1086 | it on Darwin if HAVE_UNEXEC. */ | 995 | #if (defined HAVE_ALIGNED_ALLOC \ |
| 1087 | 996 | || (!defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC)) | |
| 1088 | #if ! (defined DARWIN_OS && defined HAVE_UNEXEC) | 997 | # define USE_ALIGNED_ALLOC 1 |
| 1089 | # if (defined HAVE_ALIGNED_ALLOC \ | 998 | #elif defined HAVE_POSIX_MEMALIGN |
| 1090 | || (defined HYBRID_MALLOC \ | 999 | # define USE_ALIGNED_ALLOC 1 |
| 1091 | ? defined HAVE_POSIX_MEMALIGN \ | 1000 | # define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h. */ |
| 1092 | : !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC)) | ||
| 1093 | # define USE_ALIGNED_ALLOC 1 | ||
| 1094 | # elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN | ||
| 1095 | # define USE_ALIGNED_ALLOC 1 | ||
| 1096 | # define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h. */ | ||
| 1097 | static void * | 1001 | static void * |
| 1098 | aligned_alloc (size_t alignment, size_t size) | 1002 | aligned_alloc (size_t alignment, size_t size) |
| 1099 | { | 1003 | { |
| @@ -1106,7 +1010,6 @@ aligned_alloc (size_t alignment, size_t size) | |||
| 1106 | void *p; | 1010 | void *p; |
| 1107 | return posix_memalign (&p, alignment, size) == 0 ? p : 0; | 1011 | return posix_memalign (&p, alignment, size) == 0 ? p : 0; |
| 1108 | } | 1012 | } |
| 1109 | # endif | ||
| 1110 | #endif | 1013 | #endif |
| 1111 | 1014 | ||
| 1112 | /* Padding to leave at the end of a malloc'd block. This is to give | 1015 | /* Padding to leave at the end of a malloc'd block. This is to give |
| @@ -1662,12 +1565,30 @@ static ptrdiff_t const STRING_BYTES_MAX = | |||
| 1662 | 1565 | ||
| 1663 | /* Initialize string allocation. Called from init_alloc_once. */ | 1566 | /* Initialize string allocation. Called from init_alloc_once. */ |
| 1664 | 1567 | ||
| 1568 | static struct Lisp_String *allocate_string (void); | ||
| 1569 | static void | ||
| 1570 | allocate_string_data (struct Lisp_String *s, | ||
| 1571 | EMACS_INT nchars, EMACS_INT nbytes, bool clearit, | ||
| 1572 | bool immovable); | ||
| 1573 | |||
| 1665 | static void | 1574 | static void |
| 1666 | init_strings (void) | 1575 | init_strings (void) |
| 1667 | { | 1576 | { |
| 1668 | empty_unibyte_string = make_pure_string ("", 0, 0, 0); | 1577 | /* String allocation code will return one of 'empty_*ibyte_string' |
| 1578 | when asked to construct a new 0-length string, so in order to build | ||
| 1579 | those special cases, we have to do it "by hand". */ | ||
| 1580 | struct Lisp_String *ems = allocate_string (); | ||
| 1581 | struct Lisp_String *eus = allocate_string (); | ||
| 1582 | ems->u.s.intervals = NULL; | ||
| 1583 | eus->u.s.intervals = NULL; | ||
| 1584 | allocate_string_data (ems, 0, 0, false, false); | ||
| 1585 | allocate_string_data (eus, 0, 0, false, false); | ||
| 1586 | /* We can't use 'STRING_SET_UNIBYTE' because this one includes a hack | ||
| 1587 | * to redirect its arg to 'empty_unibyte_string' when nbytes == 0. */ | ||
| 1588 | eus->u.s.size_byte = -1; | ||
| 1589 | XSETSTRING (empty_multibyte_string, ems); | ||
| 1590 | XSETSTRING (empty_unibyte_string, eus); | ||
| 1669 | staticpro (&empty_unibyte_string); | 1591 | staticpro (&empty_unibyte_string); |
| 1670 | empty_multibyte_string = make_pure_string ("", 0, 0, 1); | ||
| 1671 | staticpro (&empty_multibyte_string); | 1592 | staticpro (&empty_multibyte_string); |
| 1672 | } | 1593 | } |
| 1673 | 1594 | ||
| @@ -1720,7 +1641,7 @@ string_bytes (struct Lisp_String *s) | |||
| 1720 | ptrdiff_t nbytes = | 1641 | ptrdiff_t nbytes = |
| 1721 | (s->u.s.size_byte < 0 ? s->u.s.size & ~ARRAY_MARK_FLAG : s->u.s.size_byte); | 1642 | (s->u.s.size_byte < 0 ? s->u.s.size & ~ARRAY_MARK_FLAG : s->u.s.size_byte); |
| 1722 | 1643 | ||
| 1723 | if (!PURE_P (s) && !pdumper_object_p (s) && s->u.s.data | 1644 | if (!pdumper_object_p (s) && s->u.s.data |
| 1724 | && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s))) | 1645 | && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s))) |
| 1725 | emacs_abort (); | 1646 | emacs_abort (); |
| 1726 | return nbytes; | 1647 | return nbytes; |
| @@ -2571,7 +2492,7 @@ pin_string (Lisp_Object string) | |||
| 2571 | unsigned char *data = s->u.s.data; | 2492 | unsigned char *data = s->u.s.data; |
| 2572 | 2493 | ||
| 2573 | if (!(size > LARGE_STRING_BYTES | 2494 | if (!(size > LARGE_STRING_BYTES |
| 2574 | || PURE_P (data) || pdumper_object_p (data) | 2495 | || pdumper_object_p (data) |
| 2575 | || s->u.s.size_byte == -3)) | 2496 | || s->u.s.size_byte == -3)) |
| 2576 | { | 2497 | { |
| 2577 | eassert (s->u.s.size_byte == -1); | 2498 | eassert (s->u.s.size_byte == -1); |
| @@ -2870,17 +2791,16 @@ list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, | |||
| 2870 | } | 2791 | } |
| 2871 | 2792 | ||
| 2872 | /* Make a list of COUNT Lisp_Objects, where ARG is the first one. | 2793 | /* Make a list of COUNT Lisp_Objects, where ARG is the first one. |
| 2873 | Use CONS to construct the pairs. AP has any remaining args. */ | 2794 | AP has any remaining args. */ |
| 2874 | static Lisp_Object | 2795 | static Lisp_Object |
| 2875 | cons_listn (ptrdiff_t count, Lisp_Object arg, | 2796 | cons_listn (ptrdiff_t count, Lisp_Object arg, va_list ap) |
| 2876 | Lisp_Object (*cons) (Lisp_Object, Lisp_Object), va_list ap) | ||
| 2877 | { | 2797 | { |
| 2878 | eassume (0 < count); | 2798 | eassume (0 < count); |
| 2879 | Lisp_Object val = cons (arg, Qnil); | 2799 | Lisp_Object val = Fcons (arg, Qnil); |
| 2880 | Lisp_Object tail = val; | 2800 | Lisp_Object tail = val; |
| 2881 | for (ptrdiff_t i = 1; i < count; i++) | 2801 | for (ptrdiff_t i = 1; i < count; i++) |
| 2882 | { | 2802 | { |
| 2883 | Lisp_Object elem = cons (va_arg (ap, Lisp_Object), Qnil); | 2803 | Lisp_Object elem = Fcons (va_arg (ap, Lisp_Object), Qnil); |
| 2884 | XSETCDR (tail, elem); | 2804 | XSETCDR (tail, elem); |
| 2885 | tail = elem; | 2805 | tail = elem; |
| 2886 | } | 2806 | } |
| @@ -2893,18 +2813,7 @@ listn (ptrdiff_t count, Lisp_Object arg1, ...) | |||
| 2893 | { | 2813 | { |
| 2894 | va_list ap; | 2814 | va_list ap; |
| 2895 | va_start (ap, arg1); | 2815 | va_start (ap, arg1); |
| 2896 | Lisp_Object val = cons_listn (count, arg1, Fcons, ap); | 2816 | Lisp_Object val = cons_listn (count, arg1, ap); |
| 2897 | va_end (ap); | ||
| 2898 | return val; | ||
| 2899 | } | ||
| 2900 | |||
| 2901 | /* Make a pure list of COUNT Lisp_Objects, where ARG1 is the first one. */ | ||
| 2902 | Lisp_Object | ||
| 2903 | pure_listn (ptrdiff_t count, Lisp_Object arg1, ...) | ||
| 2904 | { | ||
| 2905 | va_list ap; | ||
| 2906 | va_start (ap, arg1); | ||
| 2907 | Lisp_Object val = cons_listn (count, arg1, pure_cons, ap); | ||
| 2908 | va_end (ap); | 2817 | va_end (ap); |
| 2909 | return val; | 2818 | return val; |
| 2910 | } | 2819 | } |
| @@ -3085,7 +2994,7 @@ static ptrdiff_t last_inserted_vector_free_idx = VECTOR_FREE_LIST_ARRAY_SIZE; | |||
| 3085 | 2994 | ||
| 3086 | static struct large_vector *large_vectors; | 2995 | static struct large_vector *large_vectors; |
| 3087 | 2996 | ||
| 3088 | /* The only vector with 0 slots, allocated from pure space. */ | 2997 | /* The only vector with 0 slots. */ |
| 3089 | 2998 | ||
| 3090 | Lisp_Object zero_vector; | 2999 | Lisp_Object zero_vector; |
| 3091 | 3000 | ||
| @@ -3137,14 +3046,8 @@ allocate_vector_block (void) | |||
| 3137 | return block; | 3046 | return block; |
| 3138 | } | 3047 | } |
| 3139 | 3048 | ||
| 3140 | /* Called once to initialize vector allocation. */ | 3049 | static struct Lisp_Vector * |
| 3141 | 3050 | allocate_vector_from_block (ptrdiff_t nbytes); | |
| 3142 | static void | ||
| 3143 | init_vectors (void) | ||
| 3144 | { | ||
| 3145 | zero_vector = make_pure_vector (0); | ||
| 3146 | staticpro (&zero_vector); | ||
| 3147 | } | ||
| 3148 | 3051 | ||
| 3149 | /* Memory footprint in bytes of a pseudovector other than a bool-vector. */ | 3052 | /* Memory footprint in bytes of a pseudovector other than a bool-vector. */ |
| 3150 | static ptrdiff_t | 3053 | static ptrdiff_t |
| @@ -3157,6 +3060,31 @@ pseudovector_nbytes (const union vectorlike_header *hdr) | |||
| 3157 | return vroundup (header_size + word_size * nwords); | 3060 | return vroundup (header_size + word_size * nwords); |
| 3158 | } | 3061 | } |
| 3159 | 3062 | ||
| 3063 | /* Called once to initialize vector allocation. */ | ||
| 3064 | |||
| 3065 | static void | ||
| 3066 | init_vectors (void) | ||
| 3067 | { | ||
| 3068 | /* The normal vector allocation code refuses to allocate a 0-length vector | ||
| 3069 | because we use the first field of vectors internally when they're on | ||
| 3070 | the free list, so we can't put a zero-length vector on the free list. | ||
| 3071 | This is not a problem for 'zero_vector' since it's always reachable. | ||
| 3072 | An alternative approach would be to allocate zero_vector outside of the | ||
| 3073 | normal heap, e.g. as a static object, and then to "hide" it from the GC, | ||
| 3074 | for example by marking it by hand at the beginning of the GC and unmarking | ||
| 3075 | it by hand at the end. */ | ||
| 3076 | struct vector_block *block = allocate_vector_block (); | ||
| 3077 | struct Lisp_Vector *zv = (struct Lisp_Vector *)block->data; | ||
| 3078 | zv->header.size = 0; | ||
| 3079 | ssize_t nbytes = pseudovector_nbytes (&zv->header); | ||
| 3080 | ssize_t restbytes = VECTOR_BLOCK_BYTES - nbytes; | ||
| 3081 | eassert (restbytes % roundup_size == 0); | ||
| 3082 | setup_on_free_list (ADVANCE (zv, nbytes), restbytes); | ||
| 3083 | |||
| 3084 | zero_vector = make_lisp_ptr (zv, Lisp_Vectorlike); | ||
| 3085 | staticpro (&zero_vector); | ||
| 3086 | } | ||
| 3087 | |||
| 3160 | /* Allocate vector from a vector block. */ | 3088 | /* Allocate vector from a vector block. */ |
| 3161 | 3089 | ||
| 3162 | static struct Lisp_Vector * | 3090 | static struct Lisp_Vector * |
| @@ -3764,13 +3692,6 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT | |||
| 3764 | /* Bytecode must be immovable. */ | 3692 | /* Bytecode must be immovable. */ |
| 3765 | pin_string (args[CLOSURE_CODE]); | 3693 | pin_string (args[CLOSURE_CODE]); |
| 3766 | 3694 | ||
| 3767 | /* We used to purecopy everything here, if purify-flag was set. This worked | ||
| 3768 | OK for Emacs-23, but with Emacs-24's lexical binding code, it can be | ||
| 3769 | dangerous, since make-byte-code is used during execution to build | ||
| 3770 | closures, so any closure built during the preload phase would end up | ||
| 3771 | copied into pure space, including its free variables, which is sometimes | ||
| 3772 | just wasteful and other times plainly wrong (e.g. those free vars may want | ||
| 3773 | to be setcar'd). */ | ||
| 3774 | Lisp_Object val = Fvector (nargs, args); | 3695 | Lisp_Object val = Fvector (nargs, args); |
| 3775 | XSETPVECTYPE (XVECTOR (val), PVEC_CLOSURE); | 3696 | XSETPVECTYPE (XVECTOR (val), PVEC_CLOSURE); |
| 3776 | return val; | 3697 | return val; |
| @@ -3850,13 +3771,6 @@ struct symbol_block | |||
| 3850 | 3771 | ||
| 3851 | static struct symbol_block *symbol_block; | 3772 | static struct symbol_block *symbol_block; |
| 3852 | static int symbol_block_index = SYMBOL_BLOCK_SIZE; | 3773 | static int symbol_block_index = SYMBOL_BLOCK_SIZE; |
| 3853 | /* Pointer to the first symbol_block that contains pinned symbols. | ||
| 3854 | Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols, | ||
| 3855 | 10K of which are pinned (and all but 250 of them are interned in obarray), | ||
| 3856 | whereas a "typical session" has in the order of 30K symbols. | ||
| 3857 | `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather | ||
| 3858 | than 30K to find the 10K symbols we need to mark. */ | ||
| 3859 | static struct symbol_block *symbol_block_pinned; | ||
| 3860 | 3774 | ||
| 3861 | /* List of free symbols. */ | 3775 | /* List of free symbols. */ |
| 3862 | 3776 | ||
| @@ -3882,7 +3796,6 @@ init_symbol (Lisp_Object val, Lisp_Object name) | |||
| 3882 | p->u.s.interned = SYMBOL_UNINTERNED; | 3796 | p->u.s.interned = SYMBOL_UNINTERNED; |
| 3883 | p->u.s.trapped_write = SYMBOL_UNTRAPPED_WRITE; | 3797 | p->u.s.trapped_write = SYMBOL_UNTRAPPED_WRITE; |
| 3884 | p->u.s.declared_special = false; | 3798 | p->u.s.declared_special = false; |
| 3885 | p->u.s.pinned = false; | ||
| 3886 | } | 3799 | } |
| 3887 | 3800 | ||
| 3888 | DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, | 3801 | DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, |
| @@ -4373,7 +4286,7 @@ memory_full (size_t nbytes) | |||
| 4373 | void | 4286 | void |
| 4374 | refill_memory_reserve (void) | 4287 | refill_memory_reserve (void) |
| 4375 | { | 4288 | { |
| 4376 | #if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC | 4289 | #if !defined SYSTEM_MALLOC |
| 4377 | if (spare_memory[0] == 0) | 4290 | if (spare_memory[0] == 0) |
| 4378 | spare_memory[0] = malloc (SPARE_MEMORY); | 4291 | spare_memory[0] = malloc (SPARE_MEMORY); |
| 4379 | if (spare_memory[1] == 0) | 4292 | if (spare_memory[1] == 0) |
| @@ -5522,8 +5435,6 @@ valid_lisp_object_p (Lisp_Object obj) | |||
| 5522 | return 1; | 5435 | return 1; |
| 5523 | 5436 | ||
| 5524 | void *p = XPNTR (obj); | 5437 | void *p = XPNTR (obj); |
| 5525 | if (PURE_P (p)) | ||
| 5526 | return 1; | ||
| 5527 | 5438 | ||
| 5528 | if (BARE_SYMBOL_P (obj) && c_symbol_p (p)) | 5439 | if (BARE_SYMBOL_P (obj) && c_symbol_p (p)) |
| 5529 | return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0; | 5440 | return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0; |
| @@ -5602,433 +5513,6 @@ hash_table_free_bytes (void *p, ptrdiff_t nbytes) | |||
| 5602 | xfree (p); | 5513 | xfree (p); |
| 5603 | } | 5514 | } |
| 5604 | 5515 | ||
| 5605 | |||
| 5606 | /*********************************************************************** | ||
| 5607 | Pure Storage Management | ||
| 5608 | ***********************************************************************/ | ||
| 5609 | |||
| 5610 | /* Allocate room for SIZE bytes from pure Lisp storage and return a | ||
| 5611 | pointer to it. TYPE is the Lisp type for which the memory is | ||
| 5612 | allocated. TYPE < 0 means it's not used for a Lisp object, | ||
| 5613 | and that the result should have an alignment of -TYPE. | ||
| 5614 | |||
| 5615 | The bytes are initially zero. | ||
| 5616 | |||
| 5617 | If pure space is exhausted, allocate space from the heap. This is | ||
| 5618 | merely an expedient to let Emacs warn that pure space was exhausted | ||
| 5619 | and that Emacs should be rebuilt with a larger pure space. */ | ||
| 5620 | |||
| 5621 | static void * | ||
| 5622 | pure_alloc (size_t size, int type) | ||
| 5623 | { | ||
| 5624 | void *result; | ||
| 5625 | static bool pure_overflow_warned = false; | ||
| 5626 | |||
| 5627 | again: | ||
| 5628 | if (type >= 0) | ||
| 5629 | { | ||
| 5630 | /* Allocate space for a Lisp object from the beginning of the free | ||
| 5631 | space with taking account of alignment. */ | ||
| 5632 | result = pointer_align (purebeg + pure_bytes_used_lisp, LISP_ALIGNMENT); | ||
| 5633 | pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size; | ||
| 5634 | } | ||
| 5635 | else | ||
| 5636 | { | ||
| 5637 | /* Allocate space for a non-Lisp object from the end of the free | ||
| 5638 | space. */ | ||
| 5639 | ptrdiff_t unaligned_non_lisp = pure_bytes_used_non_lisp + size; | ||
| 5640 | char *unaligned = purebeg + pure_size - unaligned_non_lisp; | ||
| 5641 | int decr = (intptr_t) unaligned & (-1 - type); | ||
| 5642 | pure_bytes_used_non_lisp = unaligned_non_lisp + decr; | ||
| 5643 | result = unaligned - decr; | ||
| 5644 | } | ||
| 5645 | pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; | ||
| 5646 | |||
| 5647 | if (pure_bytes_used <= pure_size) | ||
| 5648 | return result; | ||
| 5649 | |||
| 5650 | if (!pure_overflow_warned) | ||
| 5651 | { | ||
| 5652 | message ("Pure Lisp storage overflowed"); | ||
| 5653 | pure_overflow_warned = true; | ||
| 5654 | } | ||
| 5655 | |||
| 5656 | /* Don't allocate a large amount here, | ||
| 5657 | because it might get mmap'd and then its address | ||
| 5658 | might not be usable. */ | ||
| 5659 | int small_amount = 10000; | ||
| 5660 | eassert (size <= small_amount - LISP_ALIGNMENT); | ||
| 5661 | purebeg = xzalloc (small_amount); | ||
| 5662 | pure_size = small_amount; | ||
| 5663 | pure_bytes_used_before_overflow += pure_bytes_used - size; | ||
| 5664 | pure_bytes_used = 0; | ||
| 5665 | pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0; | ||
| 5666 | |||
| 5667 | /* Can't GC if pure storage overflowed because we can't determine | ||
| 5668 | if something is a pure object or not. */ | ||
| 5669 | garbage_collection_inhibited++; | ||
| 5670 | goto again; | ||
| 5671 | } | ||
| 5672 | |||
| 5673 | /* Print a warning if PURESIZE is too small. */ | ||
| 5674 | |||
| 5675 | void | ||
| 5676 | check_pure_size (void) | ||
| 5677 | { | ||
| 5678 | if (pure_bytes_used_before_overflow) | ||
| 5679 | message (("emacs:0:Pure Lisp storage overflow (approx. %jd" | ||
| 5680 | " bytes needed)"), | ||
| 5681 | pure_bytes_used + pure_bytes_used_before_overflow); | ||
| 5682 | } | ||
| 5683 | |||
| 5684 | /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from | ||
| 5685 | the non-Lisp data pool of the pure storage, and return its start | ||
| 5686 | address. Return NULL if not found. */ | ||
| 5687 | |||
| 5688 | static char * | ||
| 5689 | find_string_data_in_pure (const char *data, ptrdiff_t nbytes) | ||
| 5690 | { | ||
| 5691 | int i; | ||
| 5692 | ptrdiff_t skip, bm_skip[256], last_char_skip, infinity, start, start_max; | ||
| 5693 | const unsigned char *p; | ||
| 5694 | char *non_lisp_beg; | ||
| 5695 | |||
| 5696 | if (pure_bytes_used_non_lisp <= nbytes) | ||
| 5697 | return NULL; | ||
| 5698 | |||
| 5699 | /* The Android GCC generates code like: | ||
| 5700 | |||
| 5701 | 0xa539e755 <+52>: lea 0x430(%esp),%esi | ||
| 5702 | => 0xa539e75c <+59>: movdqa %xmm0,0x0(%ebp) | ||
| 5703 | 0xa539e761 <+64>: add $0x10,%ebp | ||
| 5704 | |||
| 5705 | but data is not aligned appropriately, so a GP fault results. */ | ||
| 5706 | |||
| 5707 | #if defined __i386__ \ | ||
| 5708 | && defined HAVE_ANDROID \ | ||
| 5709 | && !defined ANDROID_STUBIFY \ | ||
| 5710 | && !defined (__clang__) | ||
| 5711 | if ((intptr_t) data & 15) | ||
| 5712 | return NULL; | ||
| 5713 | #endif | ||
| 5714 | |||
| 5715 | /* Set up the Boyer-Moore table. */ | ||
| 5716 | skip = nbytes + 1; | ||
| 5717 | for (i = 0; i < 256; i++) | ||
| 5718 | bm_skip[i] = skip; | ||
| 5719 | |||
| 5720 | p = (const unsigned char *) data; | ||
| 5721 | while (--skip > 0) | ||
| 5722 | bm_skip[*p++] = skip; | ||
| 5723 | |||
| 5724 | last_char_skip = bm_skip['\0']; | ||
| 5725 | |||
| 5726 | non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp; | ||
| 5727 | start_max = pure_bytes_used_non_lisp - (nbytes + 1); | ||
| 5728 | |||
| 5729 | /* See the comments in the function `boyer_moore' (search.c) for the | ||
| 5730 | use of `infinity'. */ | ||
| 5731 | infinity = pure_bytes_used_non_lisp + 1; | ||
| 5732 | bm_skip['\0'] = infinity; | ||
| 5733 | |||
| 5734 | p = (const unsigned char *) non_lisp_beg + nbytes; | ||
| 5735 | start = 0; | ||
| 5736 | do | ||
| 5737 | { | ||
| 5738 | /* Check the last character (== '\0'). */ | ||
| 5739 | do | ||
| 5740 | { | ||
| 5741 | start += bm_skip[*(p + start)]; | ||
| 5742 | } | ||
| 5743 | while (start <= start_max); | ||
| 5744 | |||
| 5745 | if (start < infinity) | ||
| 5746 | /* Couldn't find the last character. */ | ||
| 5747 | return NULL; | ||
| 5748 | |||
| 5749 | /* No less than `infinity' means we could find the last | ||
| 5750 | character at `p[start - infinity]'. */ | ||
| 5751 | start -= infinity; | ||
| 5752 | |||
| 5753 | /* Check the remaining characters. */ | ||
| 5754 | if (memcmp (data, non_lisp_beg + start, nbytes) == 0) | ||
| 5755 | /* Found. */ | ||
| 5756 | return non_lisp_beg + start; | ||
| 5757 | |||
| 5758 | start += last_char_skip; | ||
| 5759 | } | ||
| 5760 | while (start <= start_max); | ||
| 5761 | |||
| 5762 | return NULL; | ||
| 5763 | } | ||
| 5764 | |||
| 5765 | |||
| 5766 | /* Return a string allocated in pure space. DATA is a buffer holding | ||
| 5767 | NCHARS characters, and NBYTES bytes of string data. MULTIBYTE | ||
| 5768 | means make the result string multibyte. | ||
| 5769 | |||
| 5770 | Must get an error if pure storage is full, since if it cannot hold | ||
| 5771 | a large string it may be able to hold conses that point to that | ||
| 5772 | string; then the string is not protected from gc. */ | ||
| 5773 | |||
| 5774 | Lisp_Object | ||
| 5775 | make_pure_string (const char *data, | ||
| 5776 | ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte) | ||
| 5777 | { | ||
| 5778 | Lisp_Object string; | ||
| 5779 | struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String); | ||
| 5780 | s->u.s.data = (unsigned char *) find_string_data_in_pure (data, nbytes); | ||
| 5781 | if (s->u.s.data == NULL) | ||
| 5782 | { | ||
| 5783 | s->u.s.data = pure_alloc (nbytes + 1, -1); | ||
| 5784 | memcpy (s->u.s.data, data, nbytes); | ||
| 5785 | s->u.s.data[nbytes] = '\0'; | ||
| 5786 | } | ||
| 5787 | s->u.s.size = nchars; | ||
| 5788 | s->u.s.size_byte = multibyte ? nbytes : -1; | ||
| 5789 | s->u.s.intervals = NULL; | ||
| 5790 | XSETSTRING (string, s); | ||
| 5791 | return string; | ||
| 5792 | } | ||
| 5793 | |||
| 5794 | /* Return a string allocated in pure space. Do not | ||
| 5795 | allocate the string data, just point to DATA. */ | ||
| 5796 | |||
| 5797 | Lisp_Object | ||
| 5798 | make_pure_c_string (const char *data, ptrdiff_t nchars) | ||
| 5799 | { | ||
| 5800 | Lisp_Object string; | ||
| 5801 | struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String); | ||
| 5802 | s->u.s.size = nchars; | ||
| 5803 | s->u.s.size_byte = -2; | ||
| 5804 | s->u.s.data = (unsigned char *) data; | ||
| 5805 | s->u.s.intervals = NULL; | ||
| 5806 | XSETSTRING (string, s); | ||
| 5807 | return string; | ||
| 5808 | } | ||
| 5809 | |||
| 5810 | static Lisp_Object purecopy (Lisp_Object obj); | ||
| 5811 | |||
| 5812 | /* Return a cons allocated from pure space. Give it pure copies | ||
| 5813 | of CAR as car and CDR as cdr. */ | ||
| 5814 | |||
| 5815 | Lisp_Object | ||
| 5816 | pure_cons (Lisp_Object car, Lisp_Object cdr) | ||
| 5817 | { | ||
| 5818 | Lisp_Object new; | ||
| 5819 | struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons); | ||
| 5820 | XSETCONS (new, p); | ||
| 5821 | XSETCAR (new, purecopy (car)); | ||
| 5822 | XSETCDR (new, purecopy (cdr)); | ||
| 5823 | return new; | ||
| 5824 | } | ||
| 5825 | |||
| 5826 | |||
| 5827 | /* Value is a float object with value NUM allocated from pure space. */ | ||
| 5828 | |||
| 5829 | static Lisp_Object | ||
| 5830 | make_pure_float (double num) | ||
| 5831 | { | ||
| 5832 | Lisp_Object new; | ||
| 5833 | struct Lisp_Float *p = pure_alloc (sizeof *p, Lisp_Float); | ||
| 5834 | XSETFLOAT (new, p); | ||
| 5835 | XFLOAT_INIT (new, num); | ||
| 5836 | return new; | ||
| 5837 | } | ||
| 5838 | |||
| 5839 | /* Value is a bignum object with value VALUE allocated from pure | ||
| 5840 | space. */ | ||
| 5841 | |||
| 5842 | static Lisp_Object | ||
| 5843 | make_pure_bignum (Lisp_Object value) | ||
| 5844 | { | ||
| 5845 | mpz_t const *n = xbignum_val (value); | ||
| 5846 | size_t i, nlimbs = mpz_size (*n); | ||
| 5847 | size_t nbytes = nlimbs * sizeof (mp_limb_t); | ||
| 5848 | mp_limb_t *pure_limbs; | ||
| 5849 | mp_size_t new_size; | ||
| 5850 | |||
| 5851 | struct Lisp_Bignum *b = pure_alloc (sizeof *b, Lisp_Vectorlike); | ||
| 5852 | XSETPVECTYPESIZE (b, PVEC_BIGNUM, 0, VECSIZE (struct Lisp_Bignum)); | ||
| 5853 | |||
| 5854 | int limb_alignment = alignof (mp_limb_t); | ||
| 5855 | pure_limbs = pure_alloc (nbytes, - limb_alignment); | ||
| 5856 | for (i = 0; i < nlimbs; ++i) | ||
| 5857 | pure_limbs[i] = mpz_getlimbn (*n, i); | ||
| 5858 | |||
| 5859 | new_size = nlimbs; | ||
| 5860 | if (mpz_sgn (*n) < 0) | ||
| 5861 | new_size = -new_size; | ||
| 5862 | |||
| 5863 | mpz_roinit_n (b->value, pure_limbs, new_size); | ||
| 5864 | |||
| 5865 | return make_lisp_ptr (b, Lisp_Vectorlike); | ||
| 5866 | } | ||
| 5867 | |||
| 5868 | /* Return a vector with room for LEN Lisp_Objects allocated from | ||
| 5869 | pure space. */ | ||
| 5870 | |||
| 5871 | static Lisp_Object | ||
| 5872 | make_pure_vector (ptrdiff_t len) | ||
| 5873 | { | ||
| 5874 | Lisp_Object new; | ||
| 5875 | size_t size = header_size + len * word_size; | ||
| 5876 | struct Lisp_Vector *p = pure_alloc (size, Lisp_Vectorlike); | ||
| 5877 | XSETVECTOR (new, p); | ||
| 5878 | XVECTOR (new)->header.size = len; | ||
| 5879 | return new; | ||
| 5880 | } | ||
| 5881 | |||
| 5882 | /* Copy all contents and parameters of TABLE to a new table allocated | ||
| 5883 | from pure space, return the purified table. */ | ||
| 5884 | static struct Lisp_Hash_Table * | ||
| 5885 | purecopy_hash_table (struct Lisp_Hash_Table *table) | ||
| 5886 | { | ||
| 5887 | eassert (table->weakness == Weak_None); | ||
| 5888 | eassert (table->purecopy); | ||
| 5889 | |||
| 5890 | struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike); | ||
| 5891 | *pure = *table; | ||
| 5892 | pure->mutable = false; | ||
| 5893 | |||
| 5894 | if (table->table_size > 0) | ||
| 5895 | { | ||
| 5896 | ptrdiff_t hash_bytes = table->table_size * sizeof *table->hash; | ||
| 5897 | pure->hash = pure_alloc (hash_bytes, -(int)sizeof *table->hash); | ||
| 5898 | memcpy (pure->hash, table->hash, hash_bytes); | ||
| 5899 | |||
| 5900 | ptrdiff_t next_bytes = table->table_size * sizeof *table->next; | ||
| 5901 | pure->next = pure_alloc (next_bytes, -(int)sizeof *table->next); | ||
| 5902 | memcpy (pure->next, table->next, next_bytes); | ||
| 5903 | |||
| 5904 | ptrdiff_t nvalues = table->table_size * 2; | ||
| 5905 | ptrdiff_t kv_bytes = nvalues * sizeof *table->key_and_value; | ||
| 5906 | pure->key_and_value = pure_alloc (kv_bytes, | ||
| 5907 | -(int)sizeof *table->key_and_value); | ||
| 5908 | for (ptrdiff_t i = 0; i < nvalues; i++) | ||
| 5909 | pure->key_and_value[i] = purecopy (table->key_and_value[i]); | ||
| 5910 | |||
| 5911 | ptrdiff_t index_bytes = hash_table_index_size (table) | ||
| 5912 | * sizeof *table->index; | ||
| 5913 | pure->index = pure_alloc (index_bytes, -(int)sizeof *table->index); | ||
| 5914 | memcpy (pure->index, table->index, index_bytes); | ||
| 5915 | } | ||
| 5916 | |||
| 5917 | return pure; | ||
| 5918 | } | ||
| 5919 | |||
| 5920 | DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, | ||
| 5921 | doc: /* Make a copy of object OBJ in pure storage. | ||
| 5922 | Recursively copies contents of vectors and cons cells. | ||
| 5923 | Does not copy symbols. Copies strings without text properties. */) | ||
| 5924 | (register Lisp_Object obj) | ||
| 5925 | { | ||
| 5926 | if (NILP (Vpurify_flag)) | ||
| 5927 | return obj; | ||
| 5928 | else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj)) | ||
| 5929 | /* Can't purify those. */ | ||
| 5930 | return obj; | ||
| 5931 | else | ||
| 5932 | return purecopy (obj); | ||
| 5933 | } | ||
| 5934 | |||
| 5935 | /* Pinned objects are marked before every GC cycle. */ | ||
| 5936 | static struct pinned_object | ||
| 5937 | { | ||
| 5938 | Lisp_Object object; | ||
| 5939 | struct pinned_object *next; | ||
| 5940 | } *pinned_objects; | ||
| 5941 | |||
| 5942 | static Lisp_Object | ||
| 5943 | purecopy (Lisp_Object obj) | ||
| 5944 | { | ||
| 5945 | if (FIXNUMP (obj) | ||
| 5946 | || (! SYMBOLP (obj) && PURE_P (XPNTR (obj))) | ||
| 5947 | || SUBRP (obj)) | ||
| 5948 | return obj; /* Already pure. */ | ||
| 5949 | |||
| 5950 | if (STRINGP (obj) && XSTRING (obj)->u.s.intervals) | ||
| 5951 | message_with_string ("Dropping text-properties while making string `%s' pure", | ||
| 5952 | obj, true); | ||
| 5953 | |||
| 5954 | if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */ | ||
| 5955 | { | ||
| 5956 | Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil); | ||
| 5957 | if (!NILP (tmp)) | ||
| 5958 | return tmp; | ||
| 5959 | } | ||
| 5960 | |||
| 5961 | if (CONSP (obj)) | ||
| 5962 | obj = pure_cons (XCAR (obj), XCDR (obj)); | ||
| 5963 | else if (FLOATP (obj)) | ||
| 5964 | obj = make_pure_float (XFLOAT_DATA (obj)); | ||
| 5965 | else if (STRINGP (obj)) | ||
| 5966 | obj = make_pure_string (SSDATA (obj), SCHARS (obj), | ||
| 5967 | SBYTES (obj), | ||
| 5968 | STRING_MULTIBYTE (obj)); | ||
| 5969 | else if (HASH_TABLE_P (obj)) | ||
| 5970 | { | ||
| 5971 | struct Lisp_Hash_Table *table = XHASH_TABLE (obj); | ||
| 5972 | /* Do not purify hash tables which haven't been defined with | ||
| 5973 | :purecopy as non-nil or are weak - they aren't guaranteed to | ||
| 5974 | not change. */ | ||
| 5975 | if (table->weakness != Weak_None || !table->purecopy) | ||
| 5976 | { | ||
| 5977 | /* Instead, add the hash table to the list of pinned objects, | ||
| 5978 | so that it will be marked during GC. */ | ||
| 5979 | struct pinned_object *o = xmalloc (sizeof *o); | ||
| 5980 | o->object = obj; | ||
| 5981 | o->next = pinned_objects; | ||
| 5982 | pinned_objects = o; | ||
| 5983 | return obj; /* Don't hash cons it. */ | ||
| 5984 | } | ||
| 5985 | |||
| 5986 | obj = make_lisp_hash_table (purecopy_hash_table (table)); | ||
| 5987 | } | ||
| 5988 | else if (CLOSUREP (obj) || VECTORP (obj) || RECORDP (obj)) | ||
| 5989 | { | ||
| 5990 | struct Lisp_Vector *objp = XVECTOR (obj); | ||
| 5991 | ptrdiff_t nbytes = vector_nbytes (objp); | ||
| 5992 | struct Lisp_Vector *vec = pure_alloc (nbytes, Lisp_Vectorlike); | ||
| 5993 | register ptrdiff_t i; | ||
| 5994 | ptrdiff_t size = ASIZE (obj); | ||
| 5995 | if (size & PSEUDOVECTOR_FLAG) | ||
| 5996 | size &= PSEUDOVECTOR_SIZE_MASK; | ||
| 5997 | memcpy (vec, objp, nbytes); | ||
| 5998 | for (i = 0; i < size; i++) | ||
| 5999 | vec->contents[i] = purecopy (vec->contents[i]); | ||
| 6000 | /* Byte code strings must be pinned. */ | ||
| 6001 | if (CLOSUREP (obj) && size >= 2 && STRINGP (vec->contents[1]) | ||
| 6002 | && !STRING_MULTIBYTE (vec->contents[1])) | ||
| 6003 | pin_string (vec->contents[1]); | ||
| 6004 | XSETVECTOR (obj, vec); | ||
| 6005 | } | ||
| 6006 | else if (BARE_SYMBOL_P (obj)) | ||
| 6007 | { | ||
| 6008 | if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (obj))) | ||
| 6009 | { /* We can't purify them, but they appear in many pure objects. | ||
| 6010 | Mark them as `pinned' so we know to mark them at every GC cycle. */ | ||
| 6011 | XBARE_SYMBOL (obj)->u.s.pinned = true; | ||
| 6012 | symbol_block_pinned = symbol_block; | ||
| 6013 | } | ||
| 6014 | /* Don't hash-cons it. */ | ||
| 6015 | return obj; | ||
| 6016 | } | ||
| 6017 | else if (BIGNUMP (obj)) | ||
| 6018 | obj = make_pure_bignum (obj); | ||
| 6019 | else | ||
| 6020 | { | ||
| 6021 | AUTO_STRING (fmt, "Don't know how to purify: %S"); | ||
| 6022 | Fsignal (Qerror, list1 (CALLN (Fformat, fmt, obj))); | ||
| 6023 | } | ||
| 6024 | |||
| 6025 | if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */ | ||
| 6026 | Fputhash (obj, obj, Vpurify_flag); | ||
| 6027 | |||
| 6028 | return obj; | ||
| 6029 | } | ||
| 6030 | |||
| 6031 | |||
| 6032 | 5516 | ||
| 6033 | /*********************************************************************** | 5517 | /*********************************************************************** |
| 6034 | Protection from GC | 5518 | Protection from GC |
| @@ -6220,13 +5704,6 @@ compact_undo_list (Lisp_Object list) | |||
| 6220 | return list; | 5704 | return list; |
| 6221 | } | 5705 | } |
| 6222 | 5706 | ||
| 6223 | static void | ||
| 6224 | mark_pinned_objects (void) | ||
| 6225 | { | ||
| 6226 | for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next) | ||
| 6227 | mark_object (pobj->object); | ||
| 6228 | } | ||
| 6229 | |||
| 6230 | #if defined HAVE_ANDROID && !defined (__clang__) | 5707 | #if defined HAVE_ANDROID && !defined (__clang__) |
| 6231 | 5708 | ||
| 6232 | /* The Android gcc is broken and needs the following version of | 5709 | /* The Android gcc is broken and needs the following version of |
| @@ -6251,29 +5728,6 @@ android_make_lisp_symbol (struct Lisp_Symbol *sym) | |||
| 6251 | #endif | 5728 | #endif |
| 6252 | 5729 | ||
| 6253 | static void | 5730 | static void |
| 6254 | mark_pinned_symbols (void) | ||
| 6255 | { | ||
| 6256 | struct symbol_block *sblk; | ||
| 6257 | int lim; | ||
| 6258 | struct Lisp_Symbol *sym, *end; | ||
| 6259 | |||
| 6260 | if (symbol_block_pinned == symbol_block) | ||
| 6261 | lim = symbol_block_index; | ||
| 6262 | else | ||
| 6263 | lim = SYMBOL_BLOCK_SIZE; | ||
| 6264 | |||
| 6265 | for (sblk = symbol_block_pinned; sblk; sblk = sblk->next) | ||
| 6266 | { | ||
| 6267 | sym = sblk->symbols, end = sym + lim; | ||
| 6268 | for (; sym < end; ++sym) | ||
| 6269 | if (sym->u.s.pinned) | ||
| 6270 | mark_object (make_lisp_symbol (sym)); | ||
| 6271 | |||
| 6272 | lim = SYMBOL_BLOCK_SIZE; | ||
| 6273 | } | ||
| 6274 | } | ||
| 6275 | |||
| 6276 | static void | ||
| 6277 | visit_vectorlike_root (struct gc_root_visitor visitor, | 5731 | visit_vectorlike_root (struct gc_root_visitor visitor, |
| 6278 | struct Lisp_Vector *ptr, | 5732 | struct Lisp_Vector *ptr, |
| 6279 | enum gc_root_type type) | 5733 | enum gc_root_type type) |
| @@ -6536,8 +5990,6 @@ garbage_collect (void) | |||
| 6536 | struct gc_root_visitor visitor = { .visit = mark_object_root_visitor }; | 5990 | struct gc_root_visitor visitor = { .visit = mark_object_root_visitor }; |
| 6537 | visit_static_gc_roots (visitor); | 5991 | visit_static_gc_roots (visitor); |
| 6538 | 5992 | ||
| 6539 | mark_pinned_objects (); | ||
| 6540 | mark_pinned_symbols (); | ||
| 6541 | mark_lread (); | 5993 | mark_lread (); |
| 6542 | mark_terminals (); | 5994 | mark_terminals (); |
| 6543 | mark_kboards (); | 5995 | mark_kboards (); |
| @@ -6681,10 +6133,6 @@ where each entry has the form (NAME SIZE USED FREE), where: | |||
| 6681 | keeps around for future allocations (maybe because it does not know how | 6133 | keeps around for future allocations (maybe because it does not know how |
| 6682 | to return them to the OS). | 6134 | to return them to the OS). |
| 6683 | 6135 | ||
| 6684 | However, if there was overflow in pure space, and Emacs was dumped | ||
| 6685 | using the \"unexec\" method, `garbage-collect' returns nil, because | ||
| 6686 | real GC can't be done. | ||
| 6687 | |||
| 6688 | Note that calling this function does not guarantee that absolutely all | 6136 | Note that calling this function does not guarantee that absolutely all |
| 6689 | unreachable objects will be garbage-collected. Emacs uses a | 6137 | unreachable objects will be garbage-collected. Emacs uses a |
| 6690 | mark-and-sweep garbage collector, but is conservative when it comes to | 6138 | mark-and-sweep garbage collector, but is conservative when it comes to |
| @@ -7093,10 +6541,6 @@ process_mark_stack (ptrdiff_t base_sp) | |||
| 7093 | { | 6541 | { |
| 7094 | Lisp_Object obj = mark_stack_pop (); | 6542 | Lisp_Object obj = mark_stack_pop (); |
| 7095 | mark_obj: ; | 6543 | mark_obj: ; |
| 7096 | void *po = XPNTR (obj); | ||
| 7097 | if (PURE_P (po)) | ||
| 7098 | continue; | ||
| 7099 | |||
| 7100 | #if GC_REMEMBER_LAST_MARKED | 6544 | #if GC_REMEMBER_LAST_MARKED |
| 7101 | last_marked[last_marked_index++] = obj; | 6545 | last_marked[last_marked_index++] = obj; |
| 7102 | last_marked_index &= LAST_MARKED_SIZE - 1; | 6546 | last_marked_index &= LAST_MARKED_SIZE - 1; |
| @@ -7106,6 +6550,7 @@ process_mark_stack (ptrdiff_t base_sp) | |||
| 7106 | we encounter an object we know is bogus. This increases GC time | 6550 | we encounter an object we know is bogus. This increases GC time |
| 7107 | by ~80%. */ | 6551 | by ~80%. */ |
| 7108 | #if GC_CHECK_MARKED_OBJECTS | 6552 | #if GC_CHECK_MARKED_OBJECTS |
| 6553 | void *po = XPNTR (obj); | ||
| 7109 | 6554 | ||
| 7110 | /* Check that the object pointed to by PO is known to be a Lisp | 6555 | /* Check that the object pointed to by PO is known to be a Lisp |
| 7111 | structure allocated from the heap. */ | 6556 | structure allocated from the heap. */ |
| @@ -7339,11 +6784,13 @@ process_mark_stack (ptrdiff_t base_sp) | |||
| 7339 | break; | 6784 | break; |
| 7340 | default: emacs_abort (); | 6785 | default: emacs_abort (); |
| 7341 | } | 6786 | } |
| 7342 | if (!PURE_P (XSTRING (ptr->u.s.name))) | 6787 | set_string_marked (XSTRING (ptr->u.s.name)); |
| 7343 | set_string_marked (XSTRING (ptr->u.s.name)); | ||
| 7344 | mark_interval_tree (string_intervals (ptr->u.s.name)); | 6788 | mark_interval_tree (string_intervals (ptr->u.s.name)); |
| 7345 | /* Inner loop to mark next symbol in this bucket, if any. */ | 6789 | /* Inner loop to mark next symbol in this bucket, if any. */ |
| 7346 | po = ptr = ptr->u.s.next; | 6790 | ptr = ptr->u.s.next; |
| 6791 | #if GC_CHECK_MARKED_OBJECTS | ||
| 6792 | po = ptr; | ||
| 6793 | #endif | ||
| 7347 | if (ptr) | 6794 | if (ptr) |
| 7348 | goto nextsym; | 6795 | goto nextsym; |
| 7349 | } | 6796 | } |
| @@ -7475,7 +6922,7 @@ survives_gc_p (Lisp_Object obj) | |||
| 7475 | emacs_abort (); | 6922 | emacs_abort (); |
| 7476 | } | 6923 | } |
| 7477 | 6924 | ||
| 7478 | return survives_p || PURE_P (XPNTR (obj)); | 6925 | return survives_p; |
| 7479 | } | 6926 | } |
| 7480 | 6927 | ||
| 7481 | 6928 | ||
| @@ -8043,8 +7490,6 @@ init_alloc_once (void) | |||
| 8043 | static void | 7490 | static void |
| 8044 | init_alloc_once_for_pdumper (void) | 7491 | init_alloc_once_for_pdumper (void) |
| 8045 | { | 7492 | { |
| 8046 | purebeg = PUREBEG; | ||
| 8047 | pure_size = PURESIZE; | ||
| 8048 | mem_init (); | 7493 | mem_init (); |
| 8049 | 7494 | ||
| 8050 | #ifdef DOUG_LEA_MALLOC | 7495 | #ifdef DOUG_LEA_MALLOC |
| @@ -8098,7 +7543,7 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */); | |||
| 8098 | Vgc_cons_percentage = make_float (0.1); | 7543 | Vgc_cons_percentage = make_float (0.1); |
| 8099 | 7544 | ||
| 8100 | DEFVAR_INT ("pure-bytes-used", pure_bytes_used, | 7545 | DEFVAR_INT ("pure-bytes-used", pure_bytes_used, |
| 8101 | doc: /* Number of bytes of shareable Lisp data allocated so far. */); | 7546 | doc: /* No longer used. */); |
| 8102 | 7547 | ||
| 8103 | DEFVAR_INT ("cons-cells-consed", cons_cells_consed, | 7548 | DEFVAR_INT ("cons-cells-consed", cons_cells_consed, |
| 8104 | doc: /* Number of cons cells that have been consed so far. */); | 7549 | doc: /* Number of cons cells that have been consed so far. */); |
| @@ -8124,9 +7569,11 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */); | |||
| 8124 | 7569 | ||
| 8125 | DEFVAR_LISP ("purify-flag", Vpurify_flag, | 7570 | DEFVAR_LISP ("purify-flag", Vpurify_flag, |
| 8126 | doc: /* Non-nil means loading Lisp code in order to dump an executable. | 7571 | doc: /* Non-nil means loading Lisp code in order to dump an executable. |
| 8127 | This means that certain objects should be allocated in shared (pure) space. | 7572 | This used to mean that certain objects should be allocated in shared |
| 8128 | It can also be set to a hash-table, in which case this table is used to | 7573 | (pure) space, but objects are not allocated in pure storage any more. |
| 8129 | do hash-consing of the objects allocated to pure space. */); | 7574 | This flag is still used in a few places, not to decide where objects are |
| 7575 | allocated, but to know if we're in the preload phase of Emacs's | ||
| 7576 | build. */); | ||
| 8130 | 7577 | ||
| 8131 | DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages, | 7578 | DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages, |
| 8132 | doc: /* Non-nil means display messages at start and end of garbage collection. */); | 7579 | doc: /* Non-nil means display messages at start and end of garbage collection. */); |
| @@ -8142,10 +7589,10 @@ do hash-consing of the objects allocated to pure space. */); | |||
| 8142 | /* We build this in advance because if we wait until we need it, we might | 7589 | /* We build this in advance because if we wait until we need it, we might |
| 8143 | not be able to allocate the memory to hold it. */ | 7590 | not be able to allocate the memory to hold it. */ |
| 8144 | Vmemory_signal_data | 7591 | Vmemory_signal_data |
| 8145 | = pure_list (Qerror, | 7592 | = list (Qerror, |
| 8146 | build_pure_c_string ("Memory exhausted--use" | 7593 | build_string ("Memory exhausted--use" |
| 8147 | " M-x save-some-buffers then" | 7594 | " M-x save-some-buffers then" |
| 8148 | " exit and restart Emacs")); | 7595 | " exit and restart Emacs")); |
| 8149 | 7596 | ||
| 8150 | DEFVAR_LISP ("memory-full", Vmemory_full, | 7597 | DEFVAR_LISP ("memory-full", Vmemory_full, |
| 8151 | doc: /* Non-nil means Emacs cannot get much more Lisp memory. */); | 7598 | doc: /* Non-nil means Emacs cannot get much more Lisp memory. */); |
| @@ -8195,7 +7642,6 @@ N should be nonnegative. */); | |||
| 8195 | defsubr (&Smake_symbol); | 7642 | defsubr (&Smake_symbol); |
| 8196 | defsubr (&Smake_marker); | 7643 | defsubr (&Smake_marker); |
| 8197 | defsubr (&Smake_finalizer); | 7644 | defsubr (&Smake_finalizer); |
| 8198 | defsubr (&Spurecopy); | ||
| 8199 | defsubr (&Sgarbage_collect); | 7645 | defsubr (&Sgarbage_collect); |
| 8200 | defsubr (&Sgarbage_collect_maybe); | 7646 | defsubr (&Sgarbage_collect_maybe); |
| 8201 | defsubr (&Smemory_info); | 7647 | defsubr (&Smemory_info); |