diff options
Diffstat (limited to 'src/alloc.c')
| -rw-r--r-- | src/alloc.c | 885 |
1 files changed, 512 insertions, 373 deletions
diff --git a/src/alloc.c b/src/alloc.c index 568fee666fe..ed30c449785 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -67,7 +67,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ # include <malloc.h> #endif -#if defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND +#if (defined ENABLE_CHECKING \ + && defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND) # define USE_VALGRIND 1 #endif @@ -104,6 +105,66 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "w32heap.h" /* for sbrk */ #endif +/* A type with alignment at least as large as any object that Emacs + allocates. This is not max_align_t because some platforms (e.g., + mingw) have buggy malloc implementations that do not align for + max_align_t. This union contains types of all GCALIGNED_STRUCT + components visible here. */ +union emacs_align_type +{ + struct frame frame; + struct Lisp_Bignum Lisp_Bignum; + struct Lisp_Bool_Vector Lisp_Bool_Vector; + struct Lisp_Char_Table Lisp_Char_Table; + struct Lisp_CondVar Lisp_CondVar; + struct Lisp_Finalizer Lisp_Finalizer; + struct Lisp_Float Lisp_Float; + struct Lisp_Hash_Table Lisp_Hash_Table; + struct Lisp_Marker Lisp_Marker; + struct Lisp_Misc_Ptr Lisp_Misc_Ptr; + struct Lisp_Mutex Lisp_Mutex; + struct Lisp_Overlay Lisp_Overlay; + struct Lisp_Sub_Char_Table Lisp_Sub_Char_Table; + struct Lisp_Subr Lisp_Subr; + struct Lisp_User_Ptr Lisp_User_Ptr; + struct Lisp_Vector Lisp_Vector; + struct terminal terminal; + struct thread_state thread_state; + struct window window; + + /* Omit the following since they would require including process.h + etc. In practice their alignments never exceed that of the + structs already listed. */ +#if 0 + struct Lisp_Module_Function Lisp_Module_Function; + struct Lisp_Process Lisp_Process; + struct save_window_data save_window_data; + struct scroll_bar scroll_bar; + struct xwidget_view xwidget_view; + struct xwidget xwidget; +#endif +}; + +/* MALLOC_SIZE_NEAR (N) is a good number to pass to malloc when + allocating a block of memory with size close to N bytes. + For best results N should be a power of 2. + + When calculating how much memory to allocate, GNU malloc (SIZE) + adds sizeof (size_t) to SIZE for internal overhead, and then rounds + up to a multiple of MALLOC_ALIGNMENT. Emacs can improve + performance a bit on GNU platforms by arranging for the resulting + size to be a power of two. This heuristic is good for glibc 2.26 + (2017) and later, and does not affect correctness on other + platforms. */ + +#define MALLOC_SIZE_NEAR(n) \ + (ROUNDUP (max (n, sizeof (size_t)), MALLOC_ALIGNMENT) - sizeof (size_t)) +#ifdef __i386 +enum { MALLOC_ALIGNMENT = 16 }; +#else +enum { MALLOC_ALIGNMENT = max (2 * sizeof (size_t), alignof (long double)) }; +#endif + #ifdef DOUG_LEA_MALLOC /* Specify maximum number of areas to mmap. It would be nice to use a @@ -412,7 +473,6 @@ inline static void set_interval_marked (INTERVAL i); enum mem_type { MEM_TYPE_NON_LISP, - MEM_TYPE_BUFFER, MEM_TYPE_CONS, MEM_TYPE_STRING, MEM_TYPE_SYMBOL, @@ -636,25 +696,19 @@ buffer_memory_full (ptrdiff_t nbytes) #define COMMON_MULTIPLE(a, b) \ ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b)) -/* LISP_ALIGNMENT is the alignment of Lisp objects. It must be at - least GCALIGNMENT so that pointers can be tagged. It also must be - at least as strict as the alignment of all the C types used to - implement Lisp objects; since pseudovectors can contain any C type, - this is max_align_t. On recent GNU/Linux x86 and x86-64 this can - often waste up to 8 bytes, since alignof (max_align_t) is 16 but - typical vectors need only an alignment of 8. Although shrinking - the alignment to 8 would save memory, it cost a 20% hit to Emacs - CPU performance on Fedora 28 x86-64 when compiled with gcc -m32. */ -enum { LISP_ALIGNMENT = alignof (union { max_align_t x; +/* Alignment needed for memory blocks that are allocated via malloc + and that contain Lisp objects. On typical hosts malloc already + aligns sufficiently, but extra work is needed on oddball hosts + where Emacs would crash if malloc returned a non-GCALIGNED pointer. */ +enum { LISP_ALIGNMENT = alignof (union { union emacs_align_type x; GCALIGNED_UNION_MEMBER }) }; verify (LISP_ALIGNMENT % GCALIGNMENT == 0); /* True if malloc (N) is known to return storage suitably aligned for Lisp objects whenever N is a multiple of LISP_ALIGNMENT. In practice this is true whenever alignof (max_align_t) is also a - multiple of LISP_ALIGNMENT. This works even for x86, where some - platform combinations (e.g., GCC 7 and later, glibc 2.25 and - earlier) have bugs where alignof (max_align_t) is 16 even though + multiple of LISP_ALIGNMENT. This works even for buggy platforms + like MinGW circa 2020, where alignof (max_align_t) is 16 even though the malloc alignment is only 8, and where Emacs still works because it never does anything that requires an alignment of 16. */ enum { MALLOC_IS_LISP_ALIGNED = alignof (max_align_t) % LISP_ALIGNMENT == 0 }; @@ -694,7 +748,7 @@ malloc_unblock_input (void) malloc_probe (size); \ } while (0) -static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); +static void *lmalloc (size_t, bool) ATTRIBUTE_MALLOC_SIZE ((1)); static void *lrealloc (void *, size_t); /* Like malloc but check for no memory and block interrupt input. */ @@ -705,7 +759,7 @@ xmalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = lmalloc (size); + val = lmalloc (size, false); MALLOC_UNBLOCK_INPUT; if (!val && size) @@ -722,12 +776,11 @@ xzalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = lmalloc (size); + val = lmalloc (size, true); MALLOC_UNBLOCK_INPUT; if (!val && size) memory_full (size); - memset (val, 0, size); MALLOC_PROBE (size); return val; } @@ -743,7 +796,7 @@ xrealloc (void *block, size_t size) /* We must call malloc explicitly when BLOCK is 0, since some reallocs don't do this. */ if (! block) - val = lmalloc (size); + val = lmalloc (size, false); else val = lrealloc (block, size); MALLOC_UNBLOCK_INPUT; @@ -939,7 +992,7 @@ void *lisp_malloc_loser EXTERNALLY_VISIBLE; #endif static void * -lisp_malloc (size_t nbytes, enum mem_type type) +lisp_malloc (size_t nbytes, bool clearit, enum mem_type type) { register void *val; @@ -949,7 +1002,7 @@ lisp_malloc (size_t nbytes, enum mem_type type) allocated_mem_type = type; #endif - val = lmalloc (nbytes); + val = lmalloc (nbytes, clearit); #if ! USE_LSB_TAG /* If the memory just allocated cannot be addressed thru a Lisp @@ -1290,16 +1343,21 @@ laligned (void *p, size_t size) that's never really exercised) for little benefit. */ static void * -lmalloc (size_t size) +lmalloc (size_t size, bool clearit) { #ifdef USE_ALIGNED_ALLOC if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0) - return aligned_alloc (LISP_ALIGNMENT, size); + { + void *p = aligned_alloc (LISP_ALIGNMENT, size); + if (clearit && p) + memclear (p, size); + return p; + } #endif while (true) { - void *p = malloc (size); + void *p = clearit ? calloc (1, size) : malloc (size); if (laligned (p, size)) return p; free (p); @@ -1328,11 +1386,11 @@ lrealloc (void *p, size_t size) Interval Allocation ***********************************************************************/ -/* Number of intervals allocated in an interval_block structure. - The 1020 is 1024 minus malloc overhead. */ +/* Number of intervals allocated in an interval_block structure. */ -#define INTERVAL_BLOCK_SIZE \ - ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval)) +enum { INTERVAL_BLOCK_SIZE + = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct interval_block *)) + / sizeof (struct interval)) }; /* Intervals are allocated in chunks in the form of an interval_block structure. */ @@ -1377,7 +1435,7 @@ make_interval (void) if (interval_block_index == INTERVAL_BLOCK_SIZE) { struct interval_block *newi - = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP); + = lisp_malloc (sizeof *newi, false, MEM_TYPE_NON_LISP); newi->next = interval_block; interval_block = newi; @@ -1444,10 +1502,9 @@ mark_interval_tree (INTERVAL i) longer used, can be easily recognized, and it's easy to compact the sblocks of small strings which we do in compact_small_strings. */ -/* Size in bytes of an sblock structure used for small strings. This - is 8192 minus malloc overhead. */ +/* Size in bytes of an sblock structure used for small strings. */ -#define SBLOCK_SIZE 8188 +enum { SBLOCK_SIZE = MALLOC_SIZE_NEAR (8192) }; /* Strings larger than this are considered large strings. String data for large strings is allocated from individual sblocks. */ @@ -1522,11 +1579,11 @@ struct sblock sdata data[FLEXIBLE_ARRAY_MEMBER]; }; -/* Number of Lisp strings in a string_block structure. The 1020 is - 1024 minus malloc overhead. */ +/* Number of Lisp strings in a string_block structure. */ -#define STRING_BLOCK_SIZE \ - ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String)) +enum { STRING_BLOCK_SIZE + = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct string_block *)) + / sizeof (struct Lisp_String)) }; /* Structure describing a block from which Lisp_String structures are allocated. */ @@ -1730,7 +1787,7 @@ allocate_string (void) add all the Lisp_Strings in it to the free-list. */ if (string_free_list == NULL) { - struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING); + struct string_block *b = lisp_malloc (sizeof *b, false, MEM_TYPE_STRING); int i; b->next = string_blocks; @@ -1778,15 +1835,16 @@ allocate_string (void) plus a NUL byte at the end. Allocate an sdata structure DATA for S, and set S->u.s.data to SDATA->u.data. Store a NUL byte at the end of S->u.s.data. Set S->u.s.size to NCHARS and S->u.s.size_byte - to NBYTES. Free S->u.s.data if it was initially non-null. */ + to NBYTES. Free S->u.s.data if it was initially non-null. -void + If CLEARIT, also clear the other bytes of S->u.s.data. */ + +static void allocate_string_data (struct Lisp_String *s, - EMACS_INT nchars, EMACS_INT nbytes) + EMACS_INT nchars, EMACS_INT nbytes, bool clearit) { - sdata *data, *old_data; + sdata *data; struct sblock *b; - ptrdiff_t old_nbytes; if (STRING_BYTES_MAX < nbytes) string_overflow (); @@ -1794,13 +1852,6 @@ allocate_string_data (struct Lisp_String *s, /* Determine the number of bytes needed to store NBYTES bytes of string data. */ ptrdiff_t needed = sdata_size (nbytes); - if (s->u.s.data) - { - old_data = SDATA_OF_STRING (s); - old_nbytes = STRING_BYTES (s); - } - else - old_data = NULL; MALLOC_BLOCK_INPUT; @@ -1813,7 +1864,7 @@ allocate_string_data (struct Lisp_String *s, mallopt (M_MMAP_MAX, 0); #endif - b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP); + b = lisp_malloc (size + GC_STRING_EXTRA, clearit, MEM_TYPE_NON_LISP); #ifdef DOUG_LEA_MALLOC if (!mmap_lisp_allowed_p ()) @@ -1825,27 +1876,30 @@ allocate_string_data (struct Lisp_String *s, b->next_free = data; large_sblocks = b; } - else if (current_sblock == NULL - || (((char *) current_sblock + SBLOCK_SIZE - - (char *) current_sblock->next_free) - < (needed + GC_STRING_EXTRA))) - { - /* Not enough room in the current sblock. */ - b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP); - data = b->data; - b->next = NULL; - b->next_free = data; - - if (current_sblock) - current_sblock->next = b; - else - oldest_sblock = b; - current_sblock = b; - } else { b = current_sblock; + + if (b == NULL + || (SBLOCK_SIZE - GC_STRING_EXTRA + < (char *) b->next_free - (char *) b + needed)) + { + /* Not enough room in the current sblock. */ + b = lisp_malloc (SBLOCK_SIZE, false, MEM_TYPE_NON_LISP); + data = b->data; + b->next = NULL; + b->next_free = data; + + if (current_sblock) + current_sblock->next = b; + else + oldest_sblock = b; + current_sblock = b; + } + data = b->next_free; + if (clearit) + memset (SDATA_DATA (data), 0, nbytes); } data->string = s; @@ -1866,16 +1920,55 @@ allocate_string_data (struct Lisp_String *s, GC_STRING_OVERRUN_COOKIE_SIZE); #endif - /* Note that Faset may call to this function when S has already data - assigned. In this case, mark data as free by setting it's string - back-pointer to null, and record the size of the data in it. */ - if (old_data) + tally_consing (needed); +} + +/* Reallocate multibyte STRING data when a single character is replaced. + The character is at byte offset CIDX_BYTE in the string. + The character being replaced is CLEN bytes long, + and the character that will replace it is NEW_CLEN bytes long. + Return the address of where the caller should store the + the new character. */ + +unsigned char * +resize_string_data (Lisp_Object string, ptrdiff_t cidx_byte, + int clen, int new_clen) +{ + eassume (STRING_MULTIBYTE (string)); + sdata *old_sdata = SDATA_OF_STRING (XSTRING (string)); + ptrdiff_t nchars = SCHARS (string); + ptrdiff_t nbytes = SBYTES (string); + ptrdiff_t new_nbytes = nbytes + (new_clen - clen); + unsigned char *data = SDATA (string); + unsigned char *new_charaddr; + + if (sdata_size (nbytes) == sdata_size (new_nbytes)) { - SDATA_NBYTES (old_data) = old_nbytes; - old_data->string = NULL; + /* No need to reallocate, as the size change falls within the + alignment slop. */ + XSTRING (string)->u.s.size_byte = new_nbytes; + new_charaddr = data + cidx_byte; + memmove (new_charaddr + new_clen, new_charaddr + clen, + nbytes - (cidx_byte + (clen - 1))); + } + else + { + allocate_string_data (XSTRING (string), nchars, new_nbytes, false); + unsigned char *new_data = SDATA (string); + new_charaddr = new_data + cidx_byte; + memcpy (new_charaddr + new_clen, data + cidx_byte + clen, + nbytes - (cidx_byte + clen)); + memcpy (new_data, data, cidx_byte); + + /* Mark old string data as free by setting its string back-pointer + to null, and record the size of the data in it. */ + SDATA_NBYTES (old_sdata) = nbytes; + old_sdata->string = NULL; } - tally_consing (needed); + clear_string_char_byte_cache (); + + return new_charaddr; } @@ -2110,6 +2203,9 @@ string_overflow (void) error ("Maximum string size exceeded"); } +static Lisp_Object make_clear_string (EMACS_INT, bool); +static Lisp_Object make_clear_multibyte_string (EMACS_INT, EMACS_INT, bool); + DEFUN ("make-string", Fmake_string, Smake_string, 2, 3, 0, doc: /* Return a newly created string of length LENGTH, with INIT in each element. LENGTH must be an integer. @@ -2118,19 +2214,20 @@ If optional argument MULTIBYTE is non-nil, the result will be a multibyte string even if INIT is an ASCII character. */) (Lisp_Object length, Lisp_Object init, Lisp_Object multibyte) { - register Lisp_Object val; - int c; + Lisp_Object val; EMACS_INT nbytes; CHECK_FIXNAT (length); CHECK_CHARACTER (init); - c = XFIXNAT (init); + int c = XFIXNAT (init); + bool clearit = !c; + if (ASCII_CHAR_P (c) && NILP (multibyte)) { nbytes = XFIXNUM (length); - val = make_uninit_string (nbytes); - if (nbytes) + val = make_clear_string (nbytes, clearit); + if (nbytes && !clearit) { memset (SDATA (val), c, nbytes); SDATA (val)[nbytes] = 0; @@ -2141,26 +2238,27 @@ a multibyte string even if INIT is an ASCII character. */) unsigned char str[MAX_MULTIBYTE_LENGTH]; ptrdiff_t len = CHAR_STRING (c, str); EMACS_INT string_len = XFIXNUM (length); - unsigned char *p, *beg, *end; if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes)) string_overflow (); - val = make_uninit_multibyte_string (string_len, nbytes); - for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len) + val = make_clear_multibyte_string (string_len, nbytes, clearit); + if (!clearit) { - /* First time we just copy `str' to the data of `val'. */ - if (p == beg) - memcpy (p, str, len); - else + unsigned char *beg = SDATA (val), *end = beg + nbytes; + for (unsigned char *p = beg; p < end; p += len) { - /* Next time we copy largest possible chunk from - initialized to uninitialized part of `val'. */ - len = min (p - beg, end - p); - memcpy (p, beg, len); + /* First time we just copy STR to the data of VAL. */ + if (p == beg) + memcpy (p, str, len); + else + { + /* Next time we copy largest possible chunk from + initialized to uninitialized part of VAL. */ + len = min (p - beg, end - p); + memcpy (p, beg, len); + } } } - if (nbytes) - *p = 0; } return val; @@ -2330,26 +2428,37 @@ make_specified_string (const char *contents, /* Return a unibyte Lisp_String set up to hold LENGTH characters - occupying LENGTH bytes. */ + occupying LENGTH bytes. If CLEARIT, clear its contents to null + bytes; otherwise, the contents are uninitialized. */ -Lisp_Object -make_uninit_string (EMACS_INT length) +static Lisp_Object +make_clear_string (EMACS_INT length, bool clearit) { Lisp_Object val; if (!length) return empty_unibyte_string; - val = make_uninit_multibyte_string (length, length); + val = make_clear_multibyte_string (length, length, clearit); STRING_SET_UNIBYTE (val); return val; } +/* Return a unibyte Lisp_String set up to hold LENGTH characters + occupying LENGTH bytes. */ + +Lisp_Object +make_uninit_string (EMACS_INT length) +{ + return make_clear_string (length, false); +} + /* Return a multibyte Lisp_String set up to hold NCHARS characters - which occupy NBYTES bytes. */ + which occupy NBYTES bytes. If CLEARIT, clear its contents to null + bytes; otherwise, the contents are uninitialized. */ -Lisp_Object -make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) +static Lisp_Object +make_clear_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes, bool clearit) { Lisp_Object string; struct Lisp_String *s; @@ -2361,12 +2470,21 @@ make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) s = allocate_string (); s->u.s.intervals = NULL; - allocate_string_data (s, nchars, nbytes); + allocate_string_data (s, nchars, nbytes, clearit); XSETSTRING (string, s); string_chars_consed += nbytes; return string; } +/* Return a multibyte Lisp_String set up to hold NCHARS characters + which occupy NBYTES bytes. */ + +Lisp_Object +make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) +{ + return make_clear_multibyte_string (nchars, nbytes, false); +} + /* Print arguments to BUF according to a FORMAT, then return a Lisp_String initialized with the data from BUF. */ @@ -3023,6 +3141,14 @@ cleanup_vector (struct Lisp_Vector *vector) if (uptr->finalizer) uptr->finalizer (uptr->p); } +#ifdef HAVE_MODULES + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MODULE_FUNCTION)) + { + ATTRIBUTE_MAY_ALIAS struct Lisp_Module_Function *function + = (struct Lisp_Module_Function *) vector; + module_finalize_function (function); + } +#endif } /* Reclaim space used by unmarked vectors. */ @@ -3137,7 +3263,7 @@ sweep_vectors (void) at most VECTOR_ELTS_MAX. */ static struct Lisp_Vector * -allocate_vectorlike (ptrdiff_t len) +allocate_vectorlike (ptrdiff_t len, bool clearit) { eassert (0 < len && len <= VECTOR_ELTS_MAX); ptrdiff_t nbytes = header_size + len * word_size; @@ -3151,11 +3277,15 @@ allocate_vectorlike (ptrdiff_t len) #endif if (nbytes <= VBLOCK_BYTES_MAX) - p = allocate_vector_from_block (vroundup (nbytes)); + { + p = allocate_vector_from_block (vroundup (nbytes)); + if (clearit) + memclear (p, nbytes); + } else { struct large_vector *lv = lisp_malloc (large_vector_offset + nbytes, - MEM_TYPE_VECTORLIKE); + clearit, MEM_TYPE_VECTORLIKE); lv->next = large_vectors; large_vectors = lv; p = large_vector_vec (lv); @@ -3178,20 +3308,37 @@ allocate_vectorlike (ptrdiff_t len) } -/* Allocate a vector with LEN slots. */ +/* Allocate a vector with LEN slots. If CLEARIT, clear its slots; + otherwise the vector's slots are uninitialized. */ -struct Lisp_Vector * -allocate_vector (ptrdiff_t len) +static struct Lisp_Vector * +allocate_clear_vector (ptrdiff_t len, bool clearit) { if (len == 0) return XVECTOR (zero_vector); if (VECTOR_ELTS_MAX < len) memory_full (SIZE_MAX); - struct Lisp_Vector *v = allocate_vectorlike (len); + struct Lisp_Vector *v = allocate_vectorlike (len, clearit); v->header.size = len; return v; } +/* Allocate a vector with LEN uninitialized slots. */ + +struct Lisp_Vector * +allocate_vector (ptrdiff_t len) +{ + return allocate_clear_vector (len, false); +} + +/* Allocate a vector with LEN nil slots. */ + +struct Lisp_Vector * +allocate_nil_vector (ptrdiff_t len) +{ + return allocate_clear_vector (len, true); +} + /* Allocate other vector-like structures. */ @@ -3208,7 +3355,7 @@ allocate_pseudovector (int memlen, int lisplen, eassert (lisplen <= size_max); eassert (memlen <= size_max + rest_max); - struct Lisp_Vector *v = allocate_vectorlike (memlen); + struct Lisp_Vector *v = allocate_vectorlike (memlen, false); /* Only the first LISPLEN slots will be traced normally by the GC. */ memclear (v->contents, zerolen * word_size); XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen); @@ -3218,12 +3365,10 @@ allocate_pseudovector (int memlen, int lisplen, struct buffer * allocate_buffer (void) { - struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER); - + struct buffer *b + = ALLOCATE_PSEUDOVECTOR (struct buffer, cursor_in_non_selected_windows_, + PVEC_BUFFER); BUFFER_PVEC_INIT (b); - /* Put B on the chain of all buffers including killed ones. */ - b->next = all_buffers; - all_buffers = b; /* Note that the rest fields of B are not initialized. */ return b; } @@ -3238,7 +3383,7 @@ allocate_record (EMACS_INT count) if (count > PSEUDOVECTOR_SIZE_MASK) error ("Attempt to allocate a record of %"pI"d slots; max is %d", count, PSEUDOVECTOR_SIZE_MASK); - struct Lisp_Vector *p = allocate_vectorlike (count); + struct Lisp_Vector *p = allocate_vectorlike (count, false); p->header.size = count; XSETPVECTYPE (p, PVEC_RECORD); return p; @@ -3291,9 +3436,11 @@ See also the function `vector'. */) Lisp_Object make_vector (ptrdiff_t length, Lisp_Object init) { - struct Lisp_Vector *p = allocate_vector (length); - for (ptrdiff_t i = 0; i < length; i++) - p->contents[i] = init; + bool clearit = NIL_IS_ZERO && NILP (init); + struct Lisp_Vector *p = allocate_clear_vector (length, clearit); + if (!clearit) + for (ptrdiff_t i = 0; i < length; i++) + p->contents[i] = init; return make_lisp_ptr (p, Lisp_Vectorlike); } @@ -3309,23 +3456,6 @@ usage: (vector &rest OBJECTS) */) return val; } -void -make_byte_code (struct Lisp_Vector *v) -{ - /* Don't allow the global zero_vector to become a byte code object. */ - eassert (0 < v->header.size); - - if (v->header.size > 1 && STRINGP (v->contents[1]) - && STRING_MULTIBYTE (v->contents[1])) - /* BYTECODE-STRING must have been produced by Emacs 20.2 or the - earlier because they produced a raw 8-bit string for byte-code - and now such a byte-code string is loaded as multibyte while - raw 8-bit characters converted to multibyte form. Thus, now we - must convert them back to the original unibyte form. */ - v->contents[1] = Fstring_as_unibyte (v->contents[1]); - XSETPVECTYPE (v, PVEC_COMPILED); -} - DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, doc: /* Create a byte-code object with specified arguments as elements. The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant @@ -3344,8 +3474,14 @@ stack before executing the byte-code. usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object val = make_uninit_vector (nargs); - struct Lisp_Vector *p = XVECTOR (val); + if (! ((FIXNUMP (args[COMPILED_ARGLIST]) + || CONSP (args[COMPILED_ARGLIST]) + || NILP (args[COMPILED_ARGLIST])) + && STRINGP (args[COMPILED_BYTECODE]) + && !STRING_MULTIBYTE (args[COMPILED_BYTECODE]) + && VECTORP (args[COMPILED_CONSTANTS]) + && FIXNATP (args[COMPILED_STACK_DEPTH]))) + error ("Invalid byte-code object"); /* We used to purecopy everything here, if purify-flag was set. This worked OK for Emacs-23, but with Emacs-24's lexical binding code, it can be @@ -3354,10 +3490,8 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT copied into pure space, including its free variables, which is sometimes just wasteful and other times plainly wrong (e.g. those free vars may want to be setcar'd). */ - - memcpy (p->contents, args, nargs * sizeof *args); - make_byte_code (p); - XSETCOMPILED (val, p); + Lisp_Object val = Fvector (nargs, args); + XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED); return val; } @@ -3442,7 +3576,7 @@ Its value is void, and its function definition and property list are nil. */) if (symbol_block_index == SYMBOL_BLOCK_SIZE) { struct symbol_block *new - = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL); + = lisp_malloc (sizeof *new, false, MEM_TYPE_SYMBOL); new->next = symbol_block; symbol_block = new; symbol_block_index = 0; @@ -3904,10 +4038,10 @@ refill_memory_reserve (void) MEM_TYPE_SPARE); if (spare_memory[5] == 0) spare_memory[5] = lisp_malloc (sizeof (struct string_block), - MEM_TYPE_SPARE); + false, MEM_TYPE_SPARE); if (spare_memory[6] == 0) spare_memory[6] = lisp_malloc (sizeof (struct string_block), - MEM_TYPE_SPARE); + false, MEM_TYPE_SPARE); if (spare_memory[0] && spare_memory[1] && spare_memory[5]) Vmemory_full = Qnil; #endif @@ -4304,7 +4438,7 @@ mem_delete_fixup (struct mem_node *x) /* If P is a pointer into a live Lisp string object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. This and other *_holding functions look for a pointer anywhere into @@ -4312,103 +4446,97 @@ mem_delete_fixup (struct mem_node *x) because some compilers sometimes optimize away the latter. See Bug#28213. */ -static Lisp_Object +static struct Lisp_String * live_string_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_STRING) - { - struct string_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->strings[0]; + eassert (m->type == MEM_TYPE_STRING); + struct string_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->strings[0]; - /* P must point into a Lisp_String structure, and it - must not be on the free-list. */ - if (0 <= offset && offset < STRING_BLOCK_SIZE * sizeof b->strings[0]) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; - if (s->u.s.data) - return make_lisp_ptr (s, Lisp_String); - } + /* P must point into a Lisp_String structure, and it + must not be on the free-list. */ + if (0 <= offset && offset < sizeof b->strings) + { + cp = ptr_bounds_copy (cp, b); + struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; + if (s->u.s.data) + return s; } - return Qnil; + return NULL; } static bool live_string_p (struct mem_node *m, void *p) { - return !NILP (live_string_holding (m, p)); + return live_string_holding (m, p) == p; } /* If P is a pointer into a live Lisp cons object on the heap, return - the object. Otherwise, return nil. M is a pointer to the + the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Cons * live_cons_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_CONS) + eassert (m->type == MEM_TYPE_CONS); + struct cons_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->conses[0]; + + /* P must point into a Lisp_Cons, not be + one of the unused cells in the current cons block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->conses + && (b != cons_block + || offset / sizeof b->conses[0] < cons_block_index)) { - struct cons_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->conses[0]; - - /* P must point into a Lisp_Cons, not be - one of the unused cells in the current cons block, - and not be on the free-list. */ - if (0 <= offset && offset < CONS_BLOCK_SIZE * sizeof b->conses[0] - && (b != cons_block - || offset / sizeof b->conses[0] < cons_block_index)) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; - if (!deadp (s->u.s.car)) - return make_lisp_ptr (s, Lisp_Cons); - } + cp = ptr_bounds_copy (cp, b); + struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; + if (!deadp (s->u.s.car)) + return s; } - return Qnil; + return NULL; } static bool live_cons_p (struct mem_node *m, void *p) { - return !NILP (live_cons_holding (m, p)); + return live_cons_holding (m, p) == p; } /* If P is a pointer into a live Lisp symbol object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Symbol * live_symbol_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_SYMBOL) + eassert (m->type == MEM_TYPE_SYMBOL); + struct symbol_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->symbols[0]; + + /* P must point into the Lisp_Symbol, not be + one of the unused cells in the current symbol block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->symbols + && (b != symbol_block + || offset / sizeof b->symbols[0] < symbol_block_index)) { - struct symbol_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->symbols[0]; - - /* P must point into the Lisp_Symbol, not be - one of the unused cells in the current symbol block, - and not be on the free-list. */ - if (0 <= offset && offset < SYMBOL_BLOCK_SIZE * sizeof b->symbols[0] - && (b != symbol_block - || offset / sizeof b->symbols[0] < symbol_block_index)) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; - if (!deadp (s->u.s.function)) - return make_lisp_symbol (s); - } + cp = ptr_bounds_copy (cp, b); + struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; + if (!deadp (s->u.s.function)) + return s; } - return Qnil; + return NULL; } static bool live_symbol_p (struct mem_node *m, void *p) { - return !NILP (live_symbol_holding (m, p)); + return live_symbol_holding (m, p) == p; } @@ -4418,97 +4546,70 @@ live_symbol_p (struct mem_node *m, void *p) static bool live_float_p (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_FLOAT) - { - struct float_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->floats[0]; - - /* P must point to the start of a Lisp_Float and not be - one of the unused cells in the current float block. */ - return (offset >= 0 - && offset % sizeof b->floats[0] == 0 - && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0]) - && (b != float_block - || offset / sizeof b->floats[0] < float_block_index)); - } - else - return 0; + eassert (m->type == MEM_TYPE_FLOAT); + struct float_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->floats[0]; + + /* P must point to the start of a Lisp_Float and not be + one of the unused cells in the current float block. */ + return (0 <= offset && offset < sizeof b->floats + && offset % sizeof b->floats[0] == 0 + && (b != float_block + || offset / sizeof b->floats[0] < float_block_index)); } -/* If P is a pointer to a live vector-like object, return the object. +/* If P is a pointer to a live, large vector-like object, return the object. Otherwise, return nil. M is a pointer to the mem_block for P. */ -static Lisp_Object -live_vector_holding (struct mem_node *m, void *p) +static struct Lisp_Vector * +live_large_vector_holding (struct mem_node *m, void *p) { + eassert (m->type == MEM_TYPE_VECTORLIKE); struct Lisp_Vector *vp = p; - - if (m->type == MEM_TYPE_VECTOR_BLOCK) - { - /* This memory node corresponds to a vector block. */ - struct vector_block *block = m->start; - struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; - - /* P is in the block's allocation range. Scan the block - up to P and see whether P points to the start of some - vector which is not on a free list. FIXME: check whether - some allocation patterns (probably a lot of short vectors) - may cause a substantial overhead of this loop. */ - while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) - { - struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) - return make_lisp_ptr (vector, Lisp_Vectorlike); - vector = next; - } - } - else if (m->type == MEM_TYPE_VECTORLIKE) - { - /* This memory node corresponds to a large vector. */ - struct Lisp_Vector *vector = large_vector_vec (m->start); - struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vector <= vp && vp < next) - return make_lisp_ptr (vector, Lisp_Vectorlike); - } - return Qnil; + struct Lisp_Vector *vector = large_vector_vec (m->start); + struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); + return vector <= vp && vp < next ? vector : NULL; } static bool -live_vector_p (struct mem_node *m, void *p) +live_large_vector_p (struct mem_node *m, void *p) { - return !NILP (live_vector_holding (m, p)); + return live_large_vector_holding (m, p) == p; } -/* If P is a pointer into a live buffer, return the buffer. - Otherwise, return nil. M is a pointer to the mem_block for P. */ +/* If P is a pointer to a live, small vector-like object, return the object. + Otherwise, return NULL. + M is a pointer to the mem_block for P. */ -static Lisp_Object -live_buffer_holding (struct mem_node *m, void *p) +static struct Lisp_Vector * +live_small_vector_holding (struct mem_node *m, void *p) { - /* P must point into the block, and the buffer - must not have been killed. */ - if (m->type == MEM_TYPE_BUFFER) + eassert (m->type == MEM_TYPE_VECTOR_BLOCK); + struct Lisp_Vector *vp = p; + struct vector_block *block = m->start; + struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; + + /* P is in the block's allocation range. Scan the block + up to P and see whether P points to the start of some + vector which is not on a free list. FIXME: check whether + some allocation patterns (probably a lot of short vectors) + may cause a substantial overhead of this loop. */ + while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) { - struct buffer *b = m->start; - char *cb = m->start; - char *cp = p; - ptrdiff_t offset = cp - cb; - if (0 <= offset && offset < sizeof *b && !NILP (b->name_)) - { - Lisp_Object obj; - XSETBUFFER (obj, b); - return obj; - } + struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); + if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) + return vector; + vector = next; } - return Qnil; + return NULL; } static bool -live_buffer_p (struct mem_node *m, void *p) +live_small_vector_p (struct mem_node *m, void *p) { - return !NILP (live_buffer_holding (m, p)); + return live_small_vector_holding (m, p) == p; } /* Mark OBJ if we can prove it's a Lisp_Object. */ @@ -4520,10 +4621,24 @@ mark_maybe_object (Lisp_Object obj) VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); #endif - if (FIXNUMP (obj)) - return; + int type_tag = XTYPE (obj); + intptr_t offset; + + switch (type_tag) + { + case_Lisp_Int: case Lisp_Type_Unused0: + return; + + case Lisp_Symbol: + offset = (intptr_t) lispsym; + break; - void *po = XPNTR (obj); + default: + offset = 0; + break; + } + + void *po = (char *) XLP (obj) + (offset - LISP_WORD_TAG (type_tag)); /* If the pointer is in the dump image and the dump has a record of the object starting at the place where the pointer points, we @@ -4535,7 +4650,7 @@ mark_maybe_object (Lisp_Object obj) /* Don't use pdumper_object_p_precise here! It doesn't check the tag bits. OBJ here might be complete garbage, so we need to verify both the pointer and the tag. */ - if (XTYPE (obj) == pdumper_find_object_type (po)) + if (pdumper_find_object_type (po) == type_tag) mark_object (obj); return; } @@ -4546,31 +4661,33 @@ mark_maybe_object (Lisp_Object obj) { bool mark_p = false; - switch (XTYPE (obj)) + switch (type_tag) { case Lisp_String: - mark_p = EQ (obj, live_string_holding (m, po)); + mark_p = m->type == MEM_TYPE_STRING && live_string_p (m, po); break; case Lisp_Cons: - mark_p = EQ (obj, live_cons_holding (m, po)); + mark_p = m->type == MEM_TYPE_CONS && live_cons_p (m, po); break; case Lisp_Symbol: - mark_p = EQ (obj, live_symbol_holding (m, po)); + mark_p = m->type == MEM_TYPE_SYMBOL && live_symbol_p (m, po); break; case Lisp_Float: - mark_p = live_float_p (m, po); + mark_p = m->type == MEM_TYPE_FLOAT && live_float_p (m, po); break; case Lisp_Vectorlike: - mark_p = (EQ (obj, live_vector_holding (m, po)) - || EQ (obj, live_buffer_holding (m, po))); + mark_p = (m->type == MEM_TYPE_VECTOR_BLOCK + ? live_small_vector_p (m, po) + : (m->type == MEM_TYPE_VECTORLIKE + && live_large_vector_p (m, po))); break; default: - break; + eassume (false); } if (mark_p) @@ -4593,7 +4710,7 @@ mark_maybe_pointer (void *p) { struct mem_node *m; -#ifdef USE_VALGRIND +#if USE_VALGRIND VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p)); #endif @@ -4611,47 +4728,71 @@ mark_maybe_pointer (void *p) m = mem_find (p); if (m != MEM_NIL) { - Lisp_Object obj = Qnil; + Lisp_Object obj; switch (m->type) { case MEM_TYPE_NON_LISP: case MEM_TYPE_SPARE: /* Nothing to do; not a pointer to Lisp memory. */ - break; - - case MEM_TYPE_BUFFER: - obj = live_buffer_holding (m, p); - break; + return; case MEM_TYPE_CONS: - obj = live_cons_holding (m, p); + { + struct Lisp_Cons *h = live_cons_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Cons); + } break; case MEM_TYPE_STRING: - obj = live_string_holding (m, p); + { + struct Lisp_String *h = live_string_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_String); + } break; case MEM_TYPE_SYMBOL: - obj = live_symbol_holding (m, p); + { + struct Lisp_Symbol *h = live_symbol_holding (m, p); + if (!h) + return; + obj = make_lisp_symbol (h); + } break; case MEM_TYPE_FLOAT: - if (live_float_p (m, p)) - obj = make_lisp_ptr (p, Lisp_Float); + if (! live_float_p (m, p)) + return; + obj = make_lisp_ptr (p, Lisp_Float); break; case MEM_TYPE_VECTORLIKE: + { + struct Lisp_Vector *h = live_large_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } + break; + case MEM_TYPE_VECTOR_BLOCK: - obj = live_vector_holding (m, p); + { + struct Lisp_Vector *h = live_small_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } break; default: emacs_abort (); } - if (!NILP (obj)) - mark_object (obj); + mark_object (obj); } } @@ -4815,9 +4956,10 @@ test_setjmp (void) as a stack scan limit. */ typedef union { - /* Align the stack top properly. Even if !HAVE___BUILTIN_UNWIND_INIT, - jmp_buf may not be aligned enough on darwin-ppc64. */ - max_align_t o; + /* Make sure stack_top and m_stack_bottom are properly aligned as GC + expects. */ + Lisp_Object o; + void *p; #ifndef HAVE___BUILTIN_UNWIND_INIT sys_jmp_buf j; char c; @@ -4861,12 +5003,10 @@ typedef union #ifdef HAVE___BUILTIN_UNWIND_INIT # define SET_STACK_TOP_ADDRESS(p) \ stacktop_sentry sentry; \ - __builtin_unwind_init (); \ *(p) = NEAR_STACK_TOP (&sentry) #else # define SET_STACK_TOP_ADDRESS(p) \ stacktop_sentry sentry; \ - __builtin_unwind_init (); \ test_setjmp (); \ sys_setjmp (sentry.j); \ *(p) = NEAR_STACK_TOP (&sentry + (stack_bottom < &sentry.c)) @@ -4930,8 +5070,9 @@ mark_stack (char const *bottom, char const *end) #endif } -/* This is a trampoline function that flushes registers to the stack, - and then calls FUNC. ARG is passed through to FUNC verbatim. +/* flush_stack_call_func is the trampoline function that flushes + registers to the stack, and then calls FUNC. ARG is passed through + to FUNC verbatim. This function must be called whenever Emacs is about to release the global interpreter lock. This lets the garbage collector easily @@ -4939,10 +5080,23 @@ mark_stack (char const *bottom, char const *end) Lisp. It is invalid to run any Lisp code or to allocate any GC memory - from FUNC. */ + from FUNC. + + Note: all register spilling is done in flush_stack_call_func before + flush_stack_call_func1 is activated. + + flush_stack_call_func1 is responsible for identifying the stack + address range to be scanned. It *must* be carefully kept as + noinline to make sure that registers has been spilled before it is + called, otherwise given __builtin_frame_address (0) typically + returns the frame pointer (base pointer) and not the stack pointer + [1] GC will miss to scan callee-saved registers content + (Bug#41357). + + [1] <https://gcc.gnu.org/onlinedocs/gcc/Return-Address.html>. */ NO_INLINE void -flush_stack_call_func (void (*func) (void *arg), void *arg) +flush_stack_call_func1 (void (*func) (void *arg), void *arg) { void *end; struct thread_state *self = current_thread; @@ -5032,9 +5186,6 @@ valid_lisp_object_p (Lisp_Object obj) case MEM_TYPE_SPARE: return 0; - case MEM_TYPE_BUFFER: - return live_buffer_p (m, p) ? 1 : 2; - case MEM_TYPE_CONS: return live_cons_p (m, p); @@ -5048,8 +5199,10 @@ valid_lisp_object_p (Lisp_Object obj) return live_float_p (m, p); case MEM_TYPE_VECTORLIKE: + return live_large_vector_p (m, p); + case MEM_TYPE_VECTOR_BLOCK: - return live_vector_p (m, p); + return live_small_vector_p (m, p); default: break; @@ -5571,7 +5724,7 @@ compact_font_cache_entry (Lisp_Object entry) struct font *font = GC_XFONT_OBJECT (val); if (!NILP (AREF (val, FONT_TYPE_INDEX)) - && vectorlike_marked_p(&font->header)) + && vectorlike_marked_p (&font->header)) break; } if (CONSP (objlist)) @@ -5851,7 +6004,7 @@ maybe_garbage_collect (void) void garbage_collect (void) { - struct buffer *nextb; + Lisp_Object tail, buffer; char stack_top_variable; bool message_p; ptrdiff_t count = SPECPDL_INDEX (); @@ -5867,8 +6020,8 @@ garbage_collect (void) /* Don't keep undo information around forever. Do this early on, so it is no problem if the user quits. */ - FOR_EACH_BUFFER (nextb) - compact_buffer (nextb); + FOR_EACH_LIVE_BUFFER (tail, buffer) + compact_buffer (XBUFFER (buffer)); byte_ct tot_before = (profiler_memory_running ? total_bytes_of_live_objects () @@ -5958,8 +6111,9 @@ garbage_collect (void) compact_font_caches (); - FOR_EACH_BUFFER (nextb) + FOR_EACH_LIVE_BUFFER (tail, buffer) { + struct buffer *nextb = XBUFFER (buffer); if (!EQ (BVAR (nextb, undo_list), Qt)) bset_undo_list (nextb, compact_undo_list (BVAR (nextb, undo_list))); /* Now that we have stripped the elements that need not be @@ -6224,7 +6378,12 @@ mark_buffer (struct buffer *buffer) /* For now, we just don't mark the undo_list. It's done later in a special way just before the sweep phase, and after stripping - some of its elements that are not needed any more. */ + some of its elements that are not needed any more. + Note: this later processing is only done for live buffers, so + for dead buffers, the undo_list should be nil (set by Fkill_buffer), + but just to be on the safe side, we mark it here. */ + if (!BUFFER_LIVE_P (buffer)) + mark_object (BVAR (buffer, undo_list)); mark_overlay (buffer->overlays_before); mark_overlay (buffer->overlays_after); @@ -6404,7 +6563,7 @@ mark_object (Lisp_Object arg) structure allocated from the heap. */ #define CHECK_ALLOCATED() \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ { \ if (!pdumper_object_p_precise (po)) \ emacs_abort (); \ @@ -6417,19 +6576,19 @@ mark_object (Lisp_Object arg) /* Check that the object pointed to by PO is live, using predicate function LIVEP. */ -#define CHECK_LIVE(LIVEP) \ +#define CHECK_LIVE(LIVEP, MEM_TYPE) \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ break; \ - if (!LIVEP (m, po)) \ + if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ emacs_abort (); \ } while (0) /* Check both of the above conditions, for non-symbols. */ -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) \ +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ do { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (LIVEP); \ + CHECK_LIVE (LIVEP, MEM_TYPE); \ } while (false) /* Check both of the above conditions, for symbols. */ @@ -6438,15 +6597,14 @@ mark_object (Lisp_Object arg) if (!c_symbol_p (ptr)) \ { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (live_symbol_p); \ + CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ } \ } while (false) #else /* not GC_CHECK_MARKED_OBJECTS */ -#define CHECK_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) #endif /* not GC_CHECK_MARKED_OBJECTS */ @@ -6457,7 +6615,7 @@ mark_object (Lisp_Object arg) register struct Lisp_String *ptr = XSTRING (obj); if (string_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_string_p); + CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); set_string_marked (ptr); mark_interval_tree (ptr->u.s.intervals); #ifdef GC_CHECK_STRING_BYTES @@ -6475,36 +6633,25 @@ mark_object (Lisp_Object arg) if (vector_marked_p (ptr)) break; + enum pvec_type pvectype + = PSEUDOVECTOR_TYPE (ptr); + #ifdef GC_CHECK_MARKED_OBJECTS - if (!pdumper_object_p(po)) + if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) { m = mem_find (po); - if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po)) + if (m == MEM_NIL) emacs_abort (); + if (m->type == MEM_TYPE_VECTORLIKE) + CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); + else + CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); } -#endif /* GC_CHECK_MARKED_OBJECTS */ - - enum pvec_type pvectype - = PSEUDOVECTOR_TYPE (ptr); - - if (pvectype != PVEC_SUBR && - pvectype != PVEC_BUFFER && - !main_thread_p (po)) - CHECK_LIVE (live_vector_p); +#endif switch (pvectype) { case PVEC_BUFFER: -#if GC_CHECK_MARKED_OBJECTS - { - struct buffer *b; - FOR_EACH_BUFFER (b) - if (b == po) - break; - if (b == NULL) - emacs_abort (); - } -#endif /* GC_CHECK_MARKED_OBJECTS */ mark_buffer ((struct buffer *) ptr); break; @@ -6539,7 +6686,7 @@ mark_object (Lisp_Object arg) /* bool vectors in a dump are permanently "marked", since they're in the old section and don't have mark bits. If we're looking at a dumped bool vector, we should - have aborted above when we called vector_marked_p(), so + have aborted above when we called vector_marked_p, so we should never get here. */ eassert (!pdumper_object_p (ptr)); set_vector_marked (ptr); @@ -6570,7 +6717,7 @@ mark_object (Lisp_Object arg) if (symbol_marked_p (ptr)) break; CHECK_ALLOCATED_AND_LIVE_SYMBOL (); - set_symbol_marked(ptr); + set_symbol_marked (ptr); /* Attempt to catch bogus objects. */ eassert (valid_lisp_object_p (ptr->u.s.function)); mark_object (ptr->u.s.function); @@ -6611,7 +6758,7 @@ mark_object (Lisp_Object arg) struct Lisp_Cons *ptr = XCONS (obj); if (cons_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_cons_p); + CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); set_cons_marked (ptr); /* If the cdr is nil, avoid recursion for the car. */ if (NILP (ptr->u.s.u.cdr)) @@ -6629,7 +6776,7 @@ mark_object (Lisp_Object arg) } case Lisp_Float: - CHECK_ALLOCATED_AND_LIVE (live_float_p); + CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); /* Do not mark floats stored in a dump image: these floats are "cold" and do not have mark bits. */ if (pdumper_object_p (XFLOAT (obj))) @@ -6983,25 +7130,17 @@ NO_INLINE /* For better stack traces */ static void sweep_buffers (void) { - struct buffer *buffer, **bprev = &all_buffers; + Lisp_Object tail, buf; gcstat.total_buffers = 0; - for (buffer = all_buffers; buffer; buffer = *bprev) - if (!vectorlike_marked_p (&buffer->header)) - { - *bprev = buffer->next; - lisp_free (buffer); - } - else - { - if (!pdumper_object_p (buffer)) - XUNMARK_VECTOR (buffer); - /* Do not use buffer_(set|get)_intervals here. */ - buffer->text->intervals = balance_intervals (buffer->text->intervals); - unchain_dead_markers (buffer); - gcstat.total_buffers++; - bprev = &buffer->next; - } + FOR_EACH_LIVE_BUFFER (tail, buf) + { + struct buffer *buffer = XBUFFER (buf); + /* Do not use buffer_(set|get)_intervals here. */ + buffer->text->intervals = balance_intervals (buffer->text->intervals); + unchain_dead_markers (buffer); + gcstat.total_buffers++; + } } /* Sweep: find all structures not marked, and free them. */ |