aboutsummaryrefslogtreecommitdiffstats
path: root/src/alloc.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/alloc.c')
-rw-r--r--src/alloc.c530
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
343EMACS_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
348static char *purebeg;
349static 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
354static ptrdiff_t pure_bytes_used_before_overflow;
355
356/* Index in pure at which next pure Lisp object will be allocated.. */
357
358static ptrdiff_t pure_bytes_used_lisp;
359
360/* Number of bytes allocated for non-Lisp objects in pure storage. */
361
362static 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
366static intptr_t garbage_collection_inhibited; 338static intptr_t garbage_collection_inhibited;
@@ -435,7 +407,6 @@ no_sanitize_memcpy (void *dest, void const *src, size_t size)
435static void unchain_finalizer (struct Lisp_Finalizer *); 407static void unchain_finalizer (struct Lisp_Finalizer *);
436static void mark_terminals (void); 408static void mark_terminals (void);
437static void gc_sweep (void); 409static void gc_sweep (void);
438static Lisp_Object make_pure_vector (ptrdiff_t);
439static void mark_buffer (struct buffer *); 410static 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
563int staticidx; 534int staticidx;
564 535
565static 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
569static void * 538static void *
@@ -1677,9 +1646,9 @@ static ptrdiff_t const STRING_BYTES_MAX =
1677static void 1646static void
1678init_strings (void) 1647init_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. */
2776static Lisp_Object 2743static Lisp_Object
2777cons_listn (ptrdiff_t count, Lisp_Object arg, 2744cons_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. */
2804Lisp_Object
2805pure_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
2973static struct large_vector *large_vectors; 2928static 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
2977Lisp_Object zero_vector; 2932Lisp_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
3013static void
3014init_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
3022static struct Lisp_Vector * 2968static 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
3337static void
3338init_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
3389struct Lisp_Vector * 3349struct Lisp_Vector *
@@ -3598,13 +3558,6 @@ struct symbol_block
3598 3558
3599static struct symbol_block *symbol_block; 3559static struct symbol_block *symbol_block;
3600static int symbol_block_index = SYMBOL_BLOCK_SIZE; 3560static 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. */
3607static 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
3636DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, 3588DEFUN ("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
5313static void *
5314pure_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
5363void
5364check_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
5378static char *
5379find_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
5448Lisp_Object
5449make_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
5471Lisp_Object
5472make_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
5484static 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
5489Lisp_Object
5490pure_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
5503static Lisp_Object
5504make_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
5516static Lisp_Object 5248static Lisp_Object
5517make_pure_bignum (Lisp_Object value) 5249purecopy (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
5545static Lisp_Object
5546make_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. */
5558static struct Lisp_Hash_Table *
5559purecopy_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
5589DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, 5251DEFUN ("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. */
5605static struct pinned_object
5606{
5607 Lisp_Object object;
5608 struct pinned_object *next;
5609} *pinned_objects;
5610
5611static Lisp_Object 5266static Lisp_Object
5612purecopy (Lisp_Object obj) 5267purecopy (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
5892static void 5473static void
5893mark_pinned_objects (void)
5894{
5895 for (struct pinned_object *pobj = pinned_objects; pobj; pobj = pobj->next)
5896 mark_object (pobj->object);
5897}
5898
5899static void
5900mark_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
5917static void
5918visit_vectorlike_root (struct gc_root_visitor visitor, 5474visit_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
6309However, if there was overflow in pure space, and Emacs was dumped
6310using the \"unexec\" method, `garbage-collect' returns nil, because
6311real GC can't be done.
6312
6313Note that calling this function does not guarantee that absolutely all 5863Note that calling this function does not guarantee that absolutely all
6314unreachable objects will be garbage-collected. Emacs uses a 5864unreachable objects will be garbage-collected. Emacs uses a
6315mark-and-sweep garbage collector, but is conservative when it comes to 5865mark-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)
7719static void 7266static void
7720init_alloc_once_for_pdumper (void) 7267init_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. */);
7793This means that certain objects should be allocated in shared (pure) space.
7794It can also be set to a hash-table, in which case this table is used to
7795do 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. */);