diff options
Diffstat (limited to 'src/alloc.c')
| -rw-r--r-- | src/alloc.c | 530 |
1 files changed, 36 insertions, 494 deletions
diff --git a/src/alloc.c b/src/alloc.c index f115a3cebaa..d95d1a644da 100644 --- a/src/alloc.c +++ b/src/alloc.c | |||
| @@ -34,7 +34,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ | |||
| 34 | #include "bignum.h" | 34 | #include "bignum.h" |
| 35 | #include "dispextern.h" | 35 | #include "dispextern.h" |
| 36 | #include "intervals.h" | 36 | #include "intervals.h" |
| 37 | #include "puresize.h" | ||
| 38 | #include "sheap.h" | 37 | #include "sheap.h" |
| 39 | #include "sysstdio.h" | 38 | #include "sysstdio.h" |
| 40 | #include "systime.h" | 39 | #include "systime.h" |
| @@ -334,33 +333,6 @@ static char *spare_memory[7]; | |||
| 334 | 333 | ||
| 335 | #define SPARE_MEMORY (1 << 14) | 334 | #define SPARE_MEMORY (1 << 14) |
| 336 | 335 | ||
| 337 | /* Initialize it to a nonzero value to force it into data space | ||
| 338 | (rather than bss space). That way unexec will remap it into text | ||
| 339 | space (pure), on some systems. We have not implemented the | ||
| 340 | remapping on more recent systems because this is less important | ||
| 341 | nowadays than in the days of small memories and timesharing. */ | ||
| 342 | |||
| 343 | EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,}; | ||
| 344 | #define PUREBEG (char *) pure | ||
| 345 | |||
| 346 | /* Pointer to the pure area, and its size. */ | ||
| 347 | |||
| 348 | static char *purebeg; | ||
| 349 | static ptrdiff_t pure_size; | ||
| 350 | |||
| 351 | /* Number of bytes of pure storage used before pure storage overflowed. | ||
| 352 | If this is non-zero, this implies that an overflow occurred. */ | ||
| 353 | |||
| 354 | static ptrdiff_t pure_bytes_used_before_overflow; | ||
| 355 | |||
| 356 | /* Index in pure at which next pure Lisp object will be allocated.. */ | ||
| 357 | |||
| 358 | static ptrdiff_t pure_bytes_used_lisp; | ||
| 359 | |||
| 360 | /* Number of bytes allocated for non-Lisp objects in pure storage. */ | ||
| 361 | |||
| 362 | static ptrdiff_t pure_bytes_used_non_lisp; | ||
| 363 | |||
| 364 | /* If positive, garbage collection is inhibited. Otherwise, zero. */ | 336 | /* If positive, garbage collection is inhibited. Otherwise, zero. */ |
| 365 | 337 | ||
| 366 | static intptr_t garbage_collection_inhibited; | 338 | static intptr_t garbage_collection_inhibited; |
| @@ -435,7 +407,6 @@ no_sanitize_memcpy (void *dest, void const *src, size_t size) | |||
| 435 | static void unchain_finalizer (struct Lisp_Finalizer *); | 407 | static void unchain_finalizer (struct Lisp_Finalizer *); |
| 436 | static void mark_terminals (void); | 408 | static void mark_terminals (void); |
| 437 | static void gc_sweep (void); | 409 | static void gc_sweep (void); |
| 438 | static Lisp_Object make_pure_vector (ptrdiff_t); | ||
| 439 | static void mark_buffer (struct buffer *); | 410 | static void mark_buffer (struct buffer *); |
| 440 | 411 | ||
| 441 | #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC | 412 | #if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC |
| @@ -562,8 +533,6 @@ Lisp_Object const *staticvec[NSTATICS] | |||
| 562 | 533 | ||
| 563 | int staticidx; | 534 | int staticidx; |
| 564 | 535 | ||
| 565 | static void *pure_alloc (size_t, int); | ||
| 566 | |||
| 567 | /* Return PTR rounded up to the next multiple of ALIGNMENT. */ | 536 | /* Return PTR rounded up to the next multiple of ALIGNMENT. */ |
| 568 | 537 | ||
| 569 | static void * | 538 | static void * |
| @@ -1677,9 +1646,9 @@ static ptrdiff_t const STRING_BYTES_MAX = | |||
| 1677 | static void | 1646 | static void |
| 1678 | init_strings (void) | 1647 | init_strings (void) |
| 1679 | { | 1648 | { |
| 1680 | empty_unibyte_string = make_pure_string ("", 0, 0, 0); | 1649 | empty_unibyte_string = make_specified_string ("", 0, 0, false); |
| 1681 | staticpro (&empty_unibyte_string); | 1650 | staticpro (&empty_unibyte_string); |
| 1682 | empty_multibyte_string = make_pure_string ("", 0, 0, 1); | 1651 | empty_multibyte_string = make_specified_string ("", 0, 0, true); |
| 1683 | staticpro (&empty_multibyte_string); | 1652 | staticpro (&empty_multibyte_string); |
| 1684 | } | 1653 | } |
| 1685 | 1654 | ||
| @@ -1697,7 +1666,7 @@ string_bytes (struct Lisp_String *s) | |||
| 1697 | ptrdiff_t nbytes = | 1666 | ptrdiff_t nbytes = |
| 1698 | (s->u.s.size_byte < 0 ? s->u.s.size & ~ARRAY_MARK_FLAG : s->u.s.size_byte); | 1667 | (s->u.s.size_byte < 0 ? s->u.s.size & ~ARRAY_MARK_FLAG : s->u.s.size_byte); |
| 1699 | 1668 | ||
| 1700 | if (!PURE_P (s) && !pdumper_object_p (s) && s->u.s.data | 1669 | if (!pdumper_object_p (s) && s->u.s.data |
| 1701 | && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s))) | 1670 | && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s))) |
| 1702 | emacs_abort (); | 1671 | emacs_abort (); |
| 1703 | return nbytes; | 1672 | return nbytes; |
| @@ -2413,7 +2382,7 @@ make_specified_string (const char *contents, | |||
| 2413 | { | 2382 | { |
| 2414 | Lisp_Object val; | 2383 | Lisp_Object val; |
| 2415 | 2384 | ||
| 2416 | if (nchars < 0) | 2385 | if (nchars <= 0) |
| 2417 | { | 2386 | { |
| 2418 | if (multibyte) | 2387 | if (multibyte) |
| 2419 | nchars = multibyte_chars_in_text ((const unsigned char *) contents, | 2388 | nchars = multibyte_chars_in_text ((const unsigned char *) contents, |
| @@ -2467,8 +2436,6 @@ make_clear_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes, bool clearit) | |||
| 2467 | 2436 | ||
| 2468 | if (nchars < 0) | 2437 | if (nchars < 0) |
| 2469 | emacs_abort (); | 2438 | emacs_abort (); |
| 2470 | if (!nbytes) | ||
| 2471 | return empty_multibyte_string; | ||
| 2472 | 2439 | ||
| 2473 | s = allocate_string (); | 2440 | s = allocate_string (); |
| 2474 | s->u.s.intervals = NULL; | 2441 | s->u.s.intervals = NULL; |
| @@ -2512,7 +2479,7 @@ pin_string (Lisp_Object string) | |||
| 2512 | unsigned char *data = s->u.s.data; | 2479 | unsigned char *data = s->u.s.data; |
| 2513 | 2480 | ||
| 2514 | if (!(size > LARGE_STRING_BYTES | 2481 | if (!(size > LARGE_STRING_BYTES |
| 2515 | || PURE_P (data) || pdumper_object_p (data) | 2482 | || pdumper_object_p (data) |
| 2516 | || s->u.s.size_byte == -3)) | 2483 | || s->u.s.size_byte == -3)) |
| 2517 | { | 2484 | { |
| 2518 | eassert (s->u.s.size_byte == -1); | 2485 | eassert (s->u.s.size_byte == -1); |
| @@ -2772,17 +2739,16 @@ list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, | |||
| 2772 | } | 2739 | } |
| 2773 | 2740 | ||
| 2774 | /* Make a list of COUNT Lisp_Objects, where ARG is the first one. | 2741 | /* Make a list of COUNT Lisp_Objects, where ARG is the first one. |
| 2775 | Use CONS to construct the pairs. AP has any remaining args. */ | 2742 | AP has any remaining args. */ |
| 2776 | static Lisp_Object | 2743 | static Lisp_Object |
| 2777 | cons_listn (ptrdiff_t count, Lisp_Object arg, | 2744 | cons_listn (ptrdiff_t count, Lisp_Object arg, va_list ap) |
| 2778 | Lisp_Object (*cons) (Lisp_Object, Lisp_Object), va_list ap) | ||
| 2779 | { | 2745 | { |
| 2780 | eassume (0 < count); | 2746 | eassume (0 < count); |
| 2781 | Lisp_Object val = cons (arg, Qnil); | 2747 | Lisp_Object val = Fcons (arg, Qnil); |
| 2782 | Lisp_Object tail = val; | 2748 | Lisp_Object tail = val; |
| 2783 | for (ptrdiff_t i = 1; i < count; i++) | 2749 | for (ptrdiff_t i = 1; i < count; i++) |
| 2784 | { | 2750 | { |
| 2785 | Lisp_Object elem = cons (va_arg (ap, Lisp_Object), Qnil); | 2751 | Lisp_Object elem = Fcons (va_arg (ap, Lisp_Object), Qnil); |
| 2786 | XSETCDR (tail, elem); | 2752 | XSETCDR (tail, elem); |
| 2787 | tail = elem; | 2753 | tail = elem; |
| 2788 | } | 2754 | } |
| @@ -2795,18 +2761,7 @@ listn (ptrdiff_t count, Lisp_Object arg1, ...) | |||
| 2795 | { | 2761 | { |
| 2796 | va_list ap; | 2762 | va_list ap; |
| 2797 | va_start (ap, arg1); | 2763 | va_start (ap, arg1); |
| 2798 | Lisp_Object val = cons_listn (count, arg1, Fcons, ap); | 2764 | Lisp_Object val = cons_listn (count, arg1, ap); |
| 2799 | va_end (ap); | ||
| 2800 | return val; | ||
| 2801 | } | ||
| 2802 | |||
| 2803 | /* Make a pure list of COUNT Lisp_Objects, where ARG1 is the first one. */ | ||
| 2804 | Lisp_Object | ||
| 2805 | pure_listn (ptrdiff_t count, Lisp_Object arg1, ...) | ||
| 2806 | { | ||
| 2807 | va_list ap; | ||
| 2808 | va_start (ap, arg1); | ||
| 2809 | Lisp_Object val = cons_listn (count, arg1, pure_cons, ap); | ||
| 2810 | va_end (ap); | 2765 | va_end (ap); |
| 2811 | return val; | 2766 | return val; |
| 2812 | } | 2767 | } |
| @@ -2972,7 +2927,7 @@ static struct Lisp_Vector *vector_free_lists[VECTOR_MAX_FREE_LIST_INDEX]; | |||
| 2972 | 2927 | ||
| 2973 | static struct large_vector *large_vectors; | 2928 | static struct large_vector *large_vectors; |
| 2974 | 2929 | ||
| 2975 | /* The only vector with 0 slots, allocated from pure space. */ | 2930 | /* The only vector with 0 slots. */ |
| 2976 | 2931 | ||
| 2977 | Lisp_Object zero_vector; | 2932 | Lisp_Object zero_vector; |
| 2978 | 2933 | ||
| @@ -3008,15 +2963,6 @@ allocate_vector_block (void) | |||
| 3008 | return block; | 2963 | return block; |
| 3009 | } | 2964 | } |
| 3010 | 2965 | ||
| 3011 | /* Called once to initialize vector allocation. */ | ||
| 3012 | |||
| 3013 | static void | ||
| 3014 | init_vectors (void) | ||
| 3015 | { | ||
| 3016 | zero_vector = make_pure_vector (0); | ||
| 3017 | staticpro (&zero_vector); | ||
| 3018 | } | ||
| 3019 | |||
| 3020 | /* Allocate vector from a vector block. */ | 2966 | /* Allocate vector from a vector block. */ |
| 3021 | 2967 | ||
| 3022 | static struct Lisp_Vector * | 2968 | static struct Lisp_Vector * |
| @@ -3107,6 +3053,8 @@ vectorlike_nbytes (const union vectorlike_header *hdr) | |||
| 3107 | } | 3053 | } |
| 3108 | else | 3054 | else |
| 3109 | nwords = size; | 3055 | nwords = size; |
| 3056 | if (nwords == 0) | ||
| 3057 | nwords = 1; | ||
| 3110 | return vroundup (header_size + word_size * nwords); | 3058 | return vroundup (header_size + word_size * nwords); |
| 3111 | } | 3059 | } |
| 3112 | 3060 | ||
| @@ -3384,6 +3332,18 @@ allocate_nil_vector (ptrdiff_t len) | |||
| 3384 | } | 3332 | } |
| 3385 | 3333 | ||
| 3386 | 3334 | ||
| 3335 | /* Called once to initialize vector allocation. */ | ||
| 3336 | |||
| 3337 | static void | ||
| 3338 | init_vectors (void) | ||
| 3339 | { | ||
| 3340 | zero_vector = | ||
| 3341 | make_lisp_ptr (allocate_vectorlike (1, true), Lisp_Vectorlike); | ||
| 3342 | XVECTOR (zero_vector)->header.size = 0; | ||
| 3343 | XVECTOR (zero_vector)->contents[0] = Qnil; | ||
| 3344 | staticpro (&zero_vector); | ||
| 3345 | } | ||
| 3346 | |||
| 3387 | /* Allocate other vector-like structures. */ | 3347 | /* Allocate other vector-like structures. */ |
| 3388 | 3348 | ||
| 3389 | struct Lisp_Vector * | 3349 | struct Lisp_Vector * |
| @@ -3598,13 +3558,6 @@ struct symbol_block | |||
| 3598 | 3558 | ||
| 3599 | static struct symbol_block *symbol_block; | 3559 | static struct symbol_block *symbol_block; |
| 3600 | static int symbol_block_index = SYMBOL_BLOCK_SIZE; | 3560 | static int symbol_block_index = SYMBOL_BLOCK_SIZE; |
| 3601 | /* Pointer to the first symbol_block that contains pinned symbols. | ||
| 3602 | Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols, | ||
| 3603 | 10K of which are pinned (and all but 250 of them are interned in obarray), | ||
| 3604 | whereas a "typical session" has in the order of 30K symbols. | ||
| 3605 | `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather | ||
| 3606 | than 30K to find the 10K symbols we need to mark. */ | ||
| 3607 | static struct symbol_block *symbol_block_pinned; | ||
| 3608 | 3561 | ||
| 3609 | /* List of free symbols. */ | 3562 | /* List of free symbols. */ |
| 3610 | 3563 | ||
| @@ -3630,7 +3583,6 @@ init_symbol (Lisp_Object val, Lisp_Object name) | |||
| 3630 | p->u.s.interned = SYMBOL_UNINTERNED; | 3583 | p->u.s.interned = SYMBOL_UNINTERNED; |
| 3631 | p->u.s.trapped_write = SYMBOL_UNTRAPPED_WRITE; | 3584 | p->u.s.trapped_write = SYMBOL_UNTRAPPED_WRITE; |
| 3632 | p->u.s.declared_special = false; | 3585 | p->u.s.declared_special = false; |
| 3633 | p->u.s.pinned = false; | ||
| 3634 | } | 3586 | } |
| 3635 | 3587 | ||
| 3636 | DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, | 3588 | DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, |
| @@ -5238,8 +5190,6 @@ valid_lisp_object_p (Lisp_Object obj) | |||
| 5238 | return 1; | 5190 | return 1; |
| 5239 | 5191 | ||
| 5240 | void *p = XPNTR (obj); | 5192 | void *p = XPNTR (obj); |
| 5241 | if (PURE_P (p)) | ||
| 5242 | return 1; | ||
| 5243 | 5193 | ||
| 5244 | if (BARE_SYMBOL_P (obj) && c_symbol_p (p)) | 5194 | if (BARE_SYMBOL_P (obj) && c_symbol_p (p)) |
| 5245 | return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0; | 5195 | return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0; |
| @@ -5295,296 +5245,8 @@ valid_lisp_object_p (Lisp_Object obj) | |||
| 5295 | return 0; | 5245 | return 0; |
| 5296 | } | 5246 | } |
| 5297 | 5247 | ||
| 5298 | /*********************************************************************** | ||
| 5299 | Pure Storage Management | ||
| 5300 | ***********************************************************************/ | ||
| 5301 | |||
| 5302 | /* Allocate room for SIZE bytes from pure Lisp storage and return a | ||
| 5303 | pointer to it. TYPE is the Lisp type for which the memory is | ||
| 5304 | allocated. TYPE < 0 means it's not used for a Lisp object, | ||
| 5305 | and that the result should have an alignment of -TYPE. | ||
| 5306 | |||
| 5307 | The bytes are initially zero. | ||
| 5308 | |||
| 5309 | If pure space is exhausted, allocate space from the heap. This is | ||
| 5310 | merely an expedient to let Emacs warn that pure space was exhausted | ||
| 5311 | and that Emacs should be rebuilt with a larger pure space. */ | ||
| 5312 | |||
| 5313 | static void * | ||
| 5314 | pure_alloc (size_t size, int type) | ||
| 5315 | { | ||
| 5316 | void *result; | ||
| 5317 | |||
| 5318 | again: | ||
| 5319 | if (type >= 0) | ||
| 5320 | { | ||
| 5321 | /* Allocate space for a Lisp object from the beginning of the free | ||
| 5322 | space with taking account of alignment. */ | ||
| 5323 | result = pointer_align (purebeg + pure_bytes_used_lisp, LISP_ALIGNMENT); | ||
| 5324 | pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size; | ||
| 5325 | } | ||
| 5326 | else | ||
| 5327 | { | ||
| 5328 | /* Allocate space for a non-Lisp object from the end of the free | ||
| 5329 | space. */ | ||
| 5330 | ptrdiff_t unaligned_non_lisp = pure_bytes_used_non_lisp + size; | ||
| 5331 | char *unaligned = purebeg + pure_size - unaligned_non_lisp; | ||
| 5332 | int decr = (intptr_t) unaligned & (-1 - type); | ||
| 5333 | pure_bytes_used_non_lisp = unaligned_non_lisp + decr; | ||
| 5334 | result = unaligned - decr; | ||
| 5335 | } | ||
| 5336 | pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; | ||
| 5337 | |||
| 5338 | if (pure_bytes_used <= pure_size) | ||
| 5339 | return result; | ||
| 5340 | |||
| 5341 | /* Don't allocate a large amount here, | ||
| 5342 | because it might get mmap'd and then its address | ||
| 5343 | might not be usable. */ | ||
| 5344 | int small_amount = 10000; | ||
| 5345 | eassert (size <= small_amount - LISP_ALIGNMENT); | ||
| 5346 | purebeg = xzalloc (small_amount); | ||
| 5347 | pure_size = small_amount; | ||
| 5348 | pure_bytes_used_before_overflow += pure_bytes_used - size; | ||
| 5349 | pure_bytes_used = 0; | ||
| 5350 | pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0; | ||
| 5351 | |||
| 5352 | /* Can't GC if pure storage overflowed because we can't determine | ||
| 5353 | if something is a pure object or not. */ | ||
| 5354 | garbage_collection_inhibited++; | ||
| 5355 | goto again; | ||
| 5356 | } | ||
| 5357 | |||
| 5358 | |||
| 5359 | #ifdef HAVE_UNEXEC | ||
| 5360 | |||
| 5361 | /* Print a warning if PURESIZE is too small. */ | ||
| 5362 | |||
| 5363 | void | ||
| 5364 | check_pure_size (void) | ||
| 5365 | { | ||
| 5366 | if (pure_bytes_used_before_overflow) | ||
| 5367 | message (("emacs:0:Pure Lisp storage overflow (approx. %"pI"d" | ||
| 5368 | " bytes needed)"), | ||
| 5369 | pure_bytes_used + pure_bytes_used_before_overflow); | ||
| 5370 | } | ||
| 5371 | #endif | ||
| 5372 | |||
| 5373 | |||
| 5374 | /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from | ||
| 5375 | the non-Lisp data pool of the pure storage, and return its start | ||
| 5376 | address. Return NULL if not found. */ | ||
| 5377 | |||
| 5378 | static char * | ||
| 5379 | find_string_data_in_pure (const char *data, ptrdiff_t nbytes) | ||
| 5380 | { | ||
| 5381 | int i; | ||
| 5382 | ptrdiff_t skip, bm_skip[256], last_char_skip, infinity, start, start_max; | ||
| 5383 | const unsigned char *p; | ||
| 5384 | char *non_lisp_beg; | ||
| 5385 | |||
| 5386 | if (pure_bytes_used_non_lisp <= nbytes) | ||
| 5387 | return NULL; | ||
| 5388 | |||
| 5389 | /* Set up the Boyer-Moore table. */ | ||
| 5390 | skip = nbytes + 1; | ||
| 5391 | for (i = 0; i < 256; i++) | ||
| 5392 | bm_skip[i] = skip; | ||
| 5393 | |||
| 5394 | p = (const unsigned char *) data; | ||
| 5395 | while (--skip > 0) | ||
| 5396 | bm_skip[*p++] = skip; | ||
| 5397 | |||
| 5398 | last_char_skip = bm_skip['\0']; | ||
| 5399 | |||
| 5400 | non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp; | ||
| 5401 | start_max = pure_bytes_used_non_lisp - (nbytes + 1); | ||
| 5402 | |||
| 5403 | /* See the comments in the function `boyer_moore' (search.c) for the | ||
| 5404 | use of `infinity'. */ | ||
| 5405 | infinity = pure_bytes_used_non_lisp + 1; | ||
| 5406 | bm_skip['\0'] = infinity; | ||
| 5407 | |||
| 5408 | p = (const unsigned char *) non_lisp_beg + nbytes; | ||
| 5409 | start = 0; | ||
| 5410 | do | ||
| 5411 | { | ||
| 5412 | /* Check the last character (== '\0'). */ | ||
| 5413 | do | ||
| 5414 | { | ||
| 5415 | start += bm_skip[*(p + start)]; | ||
| 5416 | } | ||
| 5417 | while (start <= start_max); | ||
| 5418 | |||
| 5419 | if (start < infinity) | ||
| 5420 | /* Couldn't find the last character. */ | ||
| 5421 | return NULL; | ||
| 5422 | |||
| 5423 | /* No less than `infinity' means we could find the last | ||
| 5424 | character at `p[start - infinity]'. */ | ||
| 5425 | start -= infinity; | ||
| 5426 | |||
| 5427 | /* Check the remaining characters. */ | ||
| 5428 | if (memcmp (data, non_lisp_beg + start, nbytes) == 0) | ||
| 5429 | /* Found. */ | ||
| 5430 | return non_lisp_beg + start; | ||
| 5431 | |||
| 5432 | start += last_char_skip; | ||
| 5433 | } | ||
| 5434 | while (start <= start_max); | ||
| 5435 | |||
| 5436 | return NULL; | ||
| 5437 | } | ||
| 5438 | |||
| 5439 | |||
| 5440 | /* Return a string allocated in pure space. DATA is a buffer holding | ||
| 5441 | NCHARS characters, and NBYTES bytes of string data. MULTIBYTE | ||
| 5442 | means make the result string multibyte. | ||
| 5443 | |||
| 5444 | Must get an error if pure storage is full, since if it cannot hold | ||
| 5445 | a large string it may be able to hold conses that point to that | ||
| 5446 | string; then the string is not protected from gc. */ | ||
| 5447 | |||
| 5448 | Lisp_Object | ||
| 5449 | make_pure_string (const char *data, | ||
| 5450 | ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte) | ||
| 5451 | { | ||
| 5452 | Lisp_Object string; | ||
| 5453 | struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String); | ||
| 5454 | s->u.s.data = (unsigned char *) find_string_data_in_pure (data, nbytes); | ||
| 5455 | if (s->u.s.data == NULL) | ||
| 5456 | { | ||
| 5457 | s->u.s.data = pure_alloc (nbytes + 1, -1); | ||
| 5458 | memcpy (s->u.s.data, data, nbytes); | ||
| 5459 | s->u.s.data[nbytes] = '\0'; | ||
| 5460 | } | ||
| 5461 | s->u.s.size = nchars; | ||
| 5462 | s->u.s.size_byte = multibyte ? nbytes : -1; | ||
| 5463 | s->u.s.intervals = NULL; | ||
| 5464 | XSETSTRING (string, s); | ||
| 5465 | return string; | ||
| 5466 | } | ||
| 5467 | |||
| 5468 | /* Return a string allocated in pure space. Do not | ||
| 5469 | allocate the string data, just point to DATA. */ | ||
| 5470 | |||
| 5471 | Lisp_Object | ||
| 5472 | make_pure_c_string (const char *data, ptrdiff_t nchars) | ||
| 5473 | { | ||
| 5474 | Lisp_Object string; | ||
| 5475 | struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String); | ||
| 5476 | s->u.s.size = nchars; | ||
| 5477 | s->u.s.size_byte = -2; | ||
| 5478 | s->u.s.data = (unsigned char *) data; | ||
| 5479 | s->u.s.intervals = NULL; | ||
| 5480 | XSETSTRING (string, s); | ||
| 5481 | return string; | ||
| 5482 | } | ||
| 5483 | |||
| 5484 | static Lisp_Object purecopy (Lisp_Object obj); | ||
| 5485 | |||
| 5486 | /* Return a cons allocated from pure space. Give it pure copies | ||
| 5487 | of CAR as car and CDR as cdr. */ | ||
| 5488 | |||
| 5489 | Lisp_Object | ||
| 5490 | pure_cons (Lisp_Object car, Lisp_Object cdr) | ||
| 5491 | { | ||
| 5492 | Lisp_Object new; | ||
| 5493 | struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons); | ||
| 5494 | XSETCONS (new, p); | ||
| 5495 | XSETCAR (new, purecopy (car)); | ||
| 5496 | XSETCDR (new, purecopy (cdr)); | ||
| 5497 | return new; | ||
| 5498 | } | ||
| 5499 | |||
| 5500 | |||
| 5501 | /* Value is a float object with value NUM allocated from pure space. */ | ||
| 5502 | |||
| 5503 | static Lisp_Object | ||
| 5504 | make_pure_float (double num) | ||
| 5505 | { | ||
| 5506 | Lisp_Object new; | ||
| 5507 | struct Lisp_Float *p = pure_alloc (sizeof *p, Lisp_Float); | ||
| 5508 | XSETFLOAT (new, p); | ||
| 5509 | XFLOAT_INIT (new, num); | ||
| 5510 | return new; | ||
| 5511 | } | ||
| 5512 | |||
| 5513 | /* Value is a bignum object with value VALUE allocated from pure | ||
| 5514 | space. */ | ||
| 5515 | |||
| 5516 | static Lisp_Object | 5248 | static Lisp_Object |
| 5517 | make_pure_bignum (Lisp_Object value) | 5249 | purecopy (Lisp_Object obj); |
| 5518 | { | ||
| 5519 | mpz_t const *n = xbignum_val (value); | ||
| 5520 | size_t i, nlimbs = mpz_size (*n); | ||
| 5521 | size_t nbytes = nlimbs * sizeof (mp_limb_t); | ||
| 5522 | mp_limb_t *pure_limbs; | ||
| 5523 | mp_size_t new_size; | ||
| 5524 | |||
| 5525 | struct Lisp_Bignum *b = pure_alloc (sizeof *b, Lisp_Vectorlike); | ||
| 5526 | XSETPVECTYPESIZE (b, PVEC_BIGNUM, 0, VECSIZE (struct Lisp_Bignum)); | ||
| 5527 | |||
| 5528 | int limb_alignment = alignof (mp_limb_t); | ||
| 5529 | pure_limbs = pure_alloc (nbytes, - limb_alignment); | ||
| 5530 | for (i = 0; i < nlimbs; ++i) | ||
| 5531 | pure_limbs[i] = mpz_getlimbn (*n, i); | ||
| 5532 | |||
| 5533 | new_size = nlimbs; | ||
| 5534 | if (mpz_sgn (*n) < 0) | ||
| 5535 | new_size = -new_size; | ||
| 5536 | |||
| 5537 | mpz_roinit_n (b->value, pure_limbs, new_size); | ||
| 5538 | |||
| 5539 | return make_lisp_ptr (b, Lisp_Vectorlike); | ||
| 5540 | } | ||
| 5541 | |||
| 5542 | /* Return a vector with room for LEN Lisp_Objects allocated from | ||
| 5543 | pure space. */ | ||
| 5544 | |||
| 5545 | static Lisp_Object | ||
| 5546 | make_pure_vector (ptrdiff_t len) | ||
| 5547 | { | ||
| 5548 | Lisp_Object new; | ||
| 5549 | size_t size = header_size + len * word_size; | ||
| 5550 | struct Lisp_Vector *p = pure_alloc (size, Lisp_Vectorlike); | ||
| 5551 | XSETVECTOR (new, p); | ||
| 5552 | XVECTOR (new)->header.size = len; | ||
| 5553 | return new; | ||
| 5554 | } | ||
| 5555 | |||
| 5556 | /* Copy all contents and parameters of TABLE to a new table allocated | ||
| 5557 | from pure space, return the purified table. */ | ||
| 5558 | static struct Lisp_Hash_Table * | ||
| 5559 | purecopy_hash_table (struct Lisp_Hash_Table *table) | ||
| 5560 | { | ||
| 5561 | eassert (NILP (table->weak)); | ||
| 5562 | eassert (table->purecopy); | ||
| 5563 | |||
| 5564 | struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike); | ||
| 5565 | struct hash_table_test pure_test = table->test; | ||
| 5566 | |||
| 5567 | /* Purecopy the hash table test. */ | ||
| 5568 | pure_test.name = purecopy (table->test.name); | ||
| 5569 | pure_test.user_hash_function = purecopy (table->test.user_hash_function); | ||
| 5570 | pure_test.user_cmp_function = purecopy (table->test.user_cmp_function); | ||
| 5571 | |||
| 5572 | pure->header = table->header; | ||
| 5573 | pure->weak = purecopy (Qnil); | ||
| 5574 | pure->hash = purecopy (table->hash); | ||
| 5575 | pure->next = purecopy (table->next); | ||
| 5576 | pure->index = purecopy (table->index); | ||
| 5577 | pure->count = table->count; | ||
| 5578 | pure->next_free = table->next_free; | ||
| 5579 | pure->purecopy = table->purecopy; | ||
| 5580 | eassert (!pure->mutable); | ||
| 5581 | pure->rehash_threshold = table->rehash_threshold; | ||
| 5582 | pure->rehash_size = table->rehash_size; | ||
| 5583 | pure->key_and_value = purecopy (table->key_and_value); | ||
| 5584 | pure->test = pure_test; | ||
| 5585 | |||
| 5586 | return pure; | ||
| 5587 | } | ||
| 5588 | 5250 | ||
| 5589 | DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, | 5251 | DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, |
| 5590 | doc: /* Make a copy of object OBJ in pure storage. | 5252 | doc: /* Make a copy of object OBJ in pure storage. |
| @@ -5601,104 +5263,23 @@ Does not copy symbols. Copies strings without text properties. */) | |||
| 5601 | return purecopy (obj); | 5263 | return purecopy (obj); |
| 5602 | } | 5264 | } |
| 5603 | 5265 | ||
| 5604 | /* Pinned objects are marked before every GC cycle. */ | ||
| 5605 | static struct pinned_object | ||
| 5606 | { | ||
| 5607 | Lisp_Object object; | ||
| 5608 | struct pinned_object *next; | ||
| 5609 | } *pinned_objects; | ||
| 5610 | |||
| 5611 | static Lisp_Object | 5266 | static Lisp_Object |
| 5612 | purecopy (Lisp_Object obj) | 5267 | purecopy (Lisp_Object obj) |
| 5613 | { | 5268 | { |
| 5614 | if (FIXNUMP (obj) | 5269 | if (FIXNUMP (obj) || SUBRP (obj)) |
| 5615 | || (! SYMBOLP (obj) && PURE_P (XPNTR (obj))) | ||
| 5616 | || SUBRP (obj)) | ||
| 5617 | return obj; /* Already pure. */ | 5270 | return obj; /* Already pure. */ |
| 5618 | 5271 | ||
| 5619 | if (STRINGP (obj) && XSTRING (obj)->u.s.intervals) | ||
| 5620 | message_with_string ("Dropping text-properties while making string `%s' pure", | ||
| 5621 | obj, true); | ||
| 5622 | |||
| 5623 | if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */ | 5272 | if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */ |
| 5624 | { | 5273 | { |
| 5625 | Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil); | 5274 | Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil); |
| 5626 | if (!NILP (tmp)) | 5275 | if (!NILP (tmp)) |
| 5627 | return tmp; | 5276 | return tmp; |
| 5277 | Fputhash (obj, obj, Vpurify_flag); | ||
| 5628 | } | 5278 | } |
| 5629 | 5279 | ||
| 5630 | if (CONSP (obj)) | ||
| 5631 | obj = pure_cons (XCAR (obj), XCDR (obj)); | ||
| 5632 | else if (FLOATP (obj)) | ||
| 5633 | obj = make_pure_float (XFLOAT_DATA (obj)); | ||
| 5634 | else if (STRINGP (obj)) | ||
| 5635 | obj = make_pure_string (SSDATA (obj), SCHARS (obj), | ||
| 5636 | SBYTES (obj), | ||
| 5637 | STRING_MULTIBYTE (obj)); | ||
| 5638 | else if (HASH_TABLE_P (obj)) | ||
| 5639 | { | ||
| 5640 | struct Lisp_Hash_Table *table = XHASH_TABLE (obj); | ||
| 5641 | /* Do not purify hash tables which haven't been defined with | ||
| 5642 | :purecopy as non-nil or are weak - they aren't guaranteed to | ||
| 5643 | not change. */ | ||
| 5644 | if (!NILP (table->weak) || !table->purecopy) | ||
| 5645 | { | ||
| 5646 | /* Instead, add the hash table to the list of pinned objects, | ||
| 5647 | so that it will be marked during GC. */ | ||
| 5648 | struct pinned_object *o = xmalloc (sizeof *o); | ||
| 5649 | o->object = obj; | ||
| 5650 | o->next = pinned_objects; | ||
| 5651 | pinned_objects = o; | ||
| 5652 | return obj; /* Don't hash cons it. */ | ||
| 5653 | } | ||
| 5654 | |||
| 5655 | struct Lisp_Hash_Table *h = purecopy_hash_table (table); | ||
| 5656 | XSET_HASH_TABLE (obj, h); | ||
| 5657 | } | ||
| 5658 | else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj)) | ||
| 5659 | { | ||
| 5660 | struct Lisp_Vector *objp = XVECTOR (obj); | ||
| 5661 | ptrdiff_t nbytes = vector_nbytes (objp); | ||
| 5662 | struct Lisp_Vector *vec = pure_alloc (nbytes, Lisp_Vectorlike); | ||
| 5663 | register ptrdiff_t i; | ||
| 5664 | ptrdiff_t size = ASIZE (obj); | ||
| 5665 | if (size & PSEUDOVECTOR_FLAG) | ||
| 5666 | size &= PSEUDOVECTOR_SIZE_MASK; | ||
| 5667 | memcpy (vec, objp, nbytes); | ||
| 5668 | for (i = 0; i < size; i++) | ||
| 5669 | vec->contents[i] = purecopy (vec->contents[i]); | ||
| 5670 | // Byte code strings must be pinned. | ||
| 5671 | if (COMPILEDP (obj) && size >= 2 && STRINGP (vec->contents[1]) | ||
| 5672 | && !STRING_MULTIBYTE (vec->contents[1])) | ||
| 5673 | pin_string (vec->contents[1]); | ||
| 5674 | XSETVECTOR (obj, vec); | ||
| 5675 | } | ||
| 5676 | else if (BARE_SYMBOL_P (obj)) | ||
| 5677 | { | ||
| 5678 | if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (obj))) | ||
| 5679 | { /* We can't purify them, but they appear in many pure objects. | ||
| 5680 | Mark them as `pinned' so we know to mark them at every GC cycle. */ | ||
| 5681 | XBARE_SYMBOL (obj)->u.s.pinned = true; | ||
| 5682 | symbol_block_pinned = symbol_block; | ||
| 5683 | } | ||
| 5684 | /* Don't hash-cons it. */ | ||
| 5685 | return obj; | ||
| 5686 | } | ||
| 5687 | else if (BIGNUMP (obj)) | ||
| 5688 | obj = make_pure_bignum (obj); | ||
| 5689 | else | ||
| 5690 | { | ||
| 5691 | AUTO_STRING (fmt, "Don't know how to purify: %S"); | ||
| 5692 | Fsignal (Qerror, list1 (CALLN (Fformat, fmt, obj))); | ||
| 5693 | } | ||
| 5694 | |||
| 5695 | if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */ | ||
| 5696 | Fputhash (obj, obj, Vpurify_flag); | ||
| 5697 | |||
| 5698 | return obj; | 5280 | return obj; |
| 5699 | } | 5281 | } |
| 5700 | 5282 | ||
| 5701 | |||
| 5702 | 5283 | ||
| 5703 | /*********************************************************************** | 5284 | /*********************************************************************** |
| 5704 | Protection from GC | 5285 | Protection from GC |
| @@ -5890,31 +5471,6 @@ compact_undo_list (Lisp_Object list) | |||
| 5890 | } | 5471 | } |
| 5891 | 5472 | ||
| 5892 | static void | 5473 | static void |
| 5893 | mark_pinned_objects (void) | ||
| 5894 | { | ||
| 5895 | for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next) | ||
| 5896 | mark_object (pobj->object); | ||
| 5897 | } | ||
| 5898 | |||
| 5899 | static void | ||
| 5900 | mark_pinned_symbols (void) | ||
| 5901 | { | ||
| 5902 | struct symbol_block *sblk; | ||
| 5903 | int lim = (symbol_block_pinned == symbol_block | ||
| 5904 | ? symbol_block_index : SYMBOL_BLOCK_SIZE); | ||
| 5905 | |||
| 5906 | for (sblk = symbol_block_pinned; sblk; sblk = sblk->next) | ||
| 5907 | { | ||
| 5908 | struct Lisp_Symbol *sym = sblk->symbols, *end = sym + lim; | ||
| 5909 | for (; sym < end; ++sym) | ||
| 5910 | if (sym->u.s.pinned) | ||
| 5911 | mark_object (make_lisp_symbol (sym)); | ||
| 5912 | |||
| 5913 | lim = SYMBOL_BLOCK_SIZE; | ||
| 5914 | } | ||
| 5915 | } | ||
| 5916 | |||
| 5917 | static void | ||
| 5918 | visit_vectorlike_root (struct gc_root_visitor visitor, | 5474 | visit_vectorlike_root (struct gc_root_visitor visitor, |
| 5919 | struct Lisp_Vector *ptr, | 5475 | struct Lisp_Vector *ptr, |
| 5920 | enum gc_root_type type) | 5476 | enum gc_root_type type) |
| @@ -6178,8 +5734,6 @@ garbage_collect (void) | |||
| 6178 | struct gc_root_visitor visitor = { .visit = mark_object_root_visitor }; | 5734 | struct gc_root_visitor visitor = { .visit = mark_object_root_visitor }; |
| 6179 | visit_static_gc_roots (visitor); | 5735 | visit_static_gc_roots (visitor); |
| 6180 | 5736 | ||
| 6181 | mark_pinned_objects (); | ||
| 6182 | mark_pinned_symbols (); | ||
| 6183 | mark_lread (); | 5737 | mark_lread (); |
| 6184 | mark_terminals (); | 5738 | mark_terminals (); |
| 6185 | mark_kboards (); | 5739 | mark_kboards (); |
| @@ -6306,10 +5860,6 @@ where each entry has the form (NAME SIZE USED FREE), where: | |||
| 6306 | keeps around for future allocations (maybe because it does not know how | 5860 | keeps around for future allocations (maybe because it does not know how |
| 6307 | to return them to the OS). | 5861 | to return them to the OS). |
| 6308 | 5862 | ||
| 6309 | However, if there was overflow in pure space, and Emacs was dumped | ||
| 6310 | using the \"unexec\" method, `garbage-collect' returns nil, because | ||
| 6311 | real GC can't be done. | ||
| 6312 | |||
| 6313 | Note that calling this function does not guarantee that absolutely all | 5863 | Note that calling this function does not guarantee that absolutely all |
| 6314 | unreachable objects will be garbage-collected. Emacs uses a | 5864 | unreachable objects will be garbage-collected. Emacs uses a |
| 6315 | mark-and-sweep garbage collector, but is conservative when it comes to | 5865 | mark-and-sweep garbage collector, but is conservative when it comes to |
| @@ -6737,8 +6287,6 @@ process_mark_stack (ptrdiff_t base_sp) | |||
| 6737 | Lisp_Object obj = mark_stack_pop (); | 6287 | Lisp_Object obj = mark_stack_pop (); |
| 6738 | mark_obj: ; | 6288 | mark_obj: ; |
| 6739 | void *po = XPNTR (obj); | 6289 | void *po = XPNTR (obj); |
| 6740 | if (PURE_P (po)) | ||
| 6741 | continue; | ||
| 6742 | 6290 | ||
| 6743 | #if GC_REMEMBER_LAST_MARKED | 6291 | #if GC_REMEMBER_LAST_MARKED |
| 6744 | last_marked[last_marked_index++] = obj; | 6292 | last_marked[last_marked_index++] = obj; |
| @@ -6964,8 +6512,7 @@ process_mark_stack (ptrdiff_t base_sp) | |||
| 6964 | break; | 6512 | break; |
| 6965 | default: emacs_abort (); | 6513 | default: emacs_abort (); |
| 6966 | } | 6514 | } |
| 6967 | if (!PURE_P (XSTRING (ptr->u.s.name))) | 6515 | set_string_marked (XSTRING (ptr->u.s.name)); |
| 6968 | set_string_marked (XSTRING (ptr->u.s.name)); | ||
| 6969 | mark_interval_tree (string_intervals (ptr->u.s.name)); | 6516 | mark_interval_tree (string_intervals (ptr->u.s.name)); |
| 6970 | /* Inner loop to mark next symbol in this bucket, if any. */ | 6517 | /* Inner loop to mark next symbol in this bucket, if any. */ |
| 6971 | po = ptr = ptr->u.s.next; | 6518 | po = ptr = ptr->u.s.next; |
| @@ -7099,7 +6646,7 @@ survives_gc_p (Lisp_Object obj) | |||
| 7099 | emacs_abort (); | 6646 | emacs_abort (); |
| 7100 | } | 6647 | } |
| 7101 | 6648 | ||
| 7102 | return survives_p || PURE_P (XPNTR (obj)); | 6649 | return survives_p; |
| 7103 | } | 6650 | } |
| 7104 | 6651 | ||
| 7105 | 6652 | ||
| @@ -7719,8 +7266,6 @@ init_alloc_once (void) | |||
| 7719 | static void | 7266 | static void |
| 7720 | init_alloc_once_for_pdumper (void) | 7267 | init_alloc_once_for_pdumper (void) |
| 7721 | { | 7268 | { |
| 7722 | purebeg = PUREBEG; | ||
| 7723 | pure_size = PURESIZE; | ||
| 7724 | mem_init (); | 7269 | mem_init (); |
| 7725 | 7270 | ||
| 7726 | #ifdef DOUG_LEA_MALLOC | 7271 | #ifdef DOUG_LEA_MALLOC |
| @@ -7764,7 +7309,7 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */); | |||
| 7764 | Vgc_cons_percentage = make_float (0.1); | 7309 | Vgc_cons_percentage = make_float (0.1); |
| 7765 | 7310 | ||
| 7766 | DEFVAR_INT ("pure-bytes-used", pure_bytes_used, | 7311 | DEFVAR_INT ("pure-bytes-used", pure_bytes_used, |
| 7767 | doc: /* Number of bytes of shareable Lisp data allocated so far. */); | 7312 | doc: /* No longer used. */); |
| 7768 | 7313 | ||
| 7769 | DEFVAR_INT ("cons-cells-consed", cons_cells_consed, | 7314 | DEFVAR_INT ("cons-cells-consed", cons_cells_consed, |
| 7770 | doc: /* Number of cons cells that have been consed so far. */); | 7315 | doc: /* Number of cons cells that have been consed so far. */); |
| @@ -7789,10 +7334,7 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */); | |||
| 7789 | doc: /* Number of strings that have been consed so far. */); | 7334 | doc: /* Number of strings that have been consed so far. */); |
| 7790 | 7335 | ||
| 7791 | DEFVAR_LISP ("purify-flag", Vpurify_flag, | 7336 | DEFVAR_LISP ("purify-flag", Vpurify_flag, |
| 7792 | doc: /* Non-nil means loading Lisp code in order to dump an executable. | 7337 | doc: /* No longer used. */); |
| 7793 | This means that certain objects should be allocated in shared (pure) space. | ||
| 7794 | It can also be set to a hash-table, in which case this table is used to | ||
| 7795 | do hash-consing of the objects allocated to pure space. */); | ||
| 7796 | 7338 | ||
| 7797 | DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages, | 7339 | DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages, |
| 7798 | doc: /* Non-nil means display messages at start and end of garbage collection. */); | 7340 | doc: /* Non-nil means display messages at start and end of garbage collection. */); |
| @@ -7808,10 +7350,10 @@ do hash-consing of the objects allocated to pure space. */); | |||
| 7808 | /* We build this in advance because if we wait until we need it, we might | 7350 | /* We build this in advance because if we wait until we need it, we might |
| 7809 | not be able to allocate the memory to hold it. */ | 7351 | not be able to allocate the memory to hold it. */ |
| 7810 | Vmemory_signal_data | 7352 | Vmemory_signal_data |
| 7811 | = pure_list (Qerror, | 7353 | = list (Qerror, |
| 7812 | build_pure_c_string ("Memory exhausted--use" | 7354 | build_string ("Memory exhausted--use" |
| 7813 | " M-x save-some-buffers then" | 7355 | " M-x save-some-buffers then" |
| 7814 | " exit and restart Emacs")); | 7356 | " exit and restart Emacs")); |
| 7815 | 7357 | ||
| 7816 | DEFVAR_LISP ("memory-full", Vmemory_full, | 7358 | DEFVAR_LISP ("memory-full", Vmemory_full, |
| 7817 | doc: /* Non-nil means Emacs cannot get much more Lisp memory. */); | 7359 | doc: /* Non-nil means Emacs cannot get much more Lisp memory. */); |