diff options
Diffstat (limited to 'src/alloc.c')
| -rw-r--r-- | src/alloc.c | 1044 |
1 files changed, 417 insertions, 627 deletions
diff --git a/src/alloc.c b/src/alloc.c index 3654d301828..c9788ab4c6b 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -33,6 +33,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "dispextern.h" #include "intervals.h" +#include "ptr-bounds.h" #include "puresize.h" #include "sheap.h" #include "systime.h" @@ -103,7 +104,7 @@ static bool valgrind_p; #include "w32heap.h" /* for sbrk */ #endif -#ifdef GNU_LINUX +#if defined GNU_LINUX && !defined CANNOT_DUMP /* The address where the heap starts. */ void * my_heap_start (void) @@ -171,6 +172,7 @@ malloc_initialize_hook (void) /* Declare the malloc initialization hook, which runs before 'main' starts. EXTERNALLY_VISIBLE works around Bug#22522. */ +typedef void (*voidfuncptr) (void); # ifndef __MALLOC_HOOK_VOLATILE # define __MALLOC_HOOK_VOLATILE # endif @@ -245,8 +247,8 @@ bool gc_in_progress; /* Number of live and free conses etc. */ -static EMACS_INT total_conses, total_markers, total_symbols, total_buffers; -static EMACS_INT total_free_conses, total_free_markers, total_free_symbols; +static EMACS_INT total_conses, total_symbols, total_buffers; +static EMACS_INT total_free_conses, total_free_symbols; static EMACS_INT total_free_floats, total_floats; /* Points to memory space allocated as "spare", to be freed if we run @@ -354,6 +356,7 @@ no_sanitize_memcpy (void *dest, void const *src, size_t size) #endif /* MAX_SAVE_STACK > 0 */ +static void unchain_finalizer (struct Lisp_Finalizer *); static void mark_terminals (void); static void gc_sweep (void); static Lisp_Object make_pure_vector (ptrdiff_t); @@ -376,7 +379,6 @@ enum mem_type MEM_TYPE_BUFFER, MEM_TYPE_CONS, MEM_TYPE_STRING, - MEM_TYPE_MISC, MEM_TYPE_SYMBOL, MEM_TYPE_FLOAT, /* Since all non-bool pseudovectors are small enough to be @@ -502,30 +504,36 @@ pointer_align (void *ptr, int alignment) return (void *) ROUNDUP ((uintptr_t) ptr, alignment); } -/* Extract the pointer hidden within A, if A is not a symbol. - If A is a symbol, extract the hidden pointer's offset from lispsym, - converted to void *. */ - -#define macro_XPNTR_OR_SYMBOL_OFFSET(a) \ - ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK)) - -/* Extract the pointer hidden within A. */ +/* Define PNTR_ADD and XPNTR as functions, which are cleaner and can + be used in debuggers. Also, define them as macros if + DEFINE_KEY_OPS_AS_MACROS, for performance in that case. + The macro_* macros are private to this section of code. */ -#define macro_XPNTR(a) \ - ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \ - + (SYMBOLP (a) ? (char *) lispsym : NULL))) +/* Add a pointer P to an integer I without gcc -fsanitize complaining + about the result being out of range of the underlying array. */ -/* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as - functions, as functions are cleaner and can be used in debuggers. - Also, define them as macros if being compiled with GCC without - optimization, for performance in that case. The macro_* names are - private to this section of code. */ +#define macro_PNTR_ADD(p, i) ((p) + (i)) -static ATTRIBUTE_UNUSED void * -XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a) +static ATTRIBUTE_NO_SANITIZE_UNDEFINED ATTRIBUTE_UNUSED char * +PNTR_ADD (char *p, EMACS_UINT i) { - return macro_XPNTR_OR_SYMBOL_OFFSET (a); + return macro_PNTR_ADD (p, i); } + +#if DEFINE_KEY_OPS_AS_MACROS +# define PNTR_ADD(p, i) macro_PNTR_ADD (p, i) +#endif + +/* Extract the pointer hidden within O. */ + +#define macro_XPNTR(o) \ + ((void *) \ + (SYMBOLP (o) \ + ? PNTR_ADD ((char *) lispsym, \ + (XLI (o) \ + - ((EMACS_UINT) Lisp_Symbol << (USE_LSB_TAG ? 0 : VALBITS)))) \ + : (char *) XLP (o) - (XLI (o) & ~VALMASK))) + static ATTRIBUTE_UNUSED void * XPNTR (Lisp_Object a) { @@ -533,7 +541,6 @@ XPNTR (Lisp_Object a) } #if DEFINE_KEY_OPS_AS_MACROS -# define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a) # define XPNTR(a) macro_XPNTR (a) #endif @@ -627,6 +634,27 @@ 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. However, it is not + worth the hassle to avoid this waste. */ +enum { LISP_ALIGNMENT = alignof (union { max_align_t x; GCALIGNED_UNION }) }; +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 + 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 }; + #ifndef XMALLOC_OVERRUN_CHECK #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0 #else @@ -647,18 +675,13 @@ buffer_memory_full (ptrdiff_t nbytes) #define XMALLOC_OVERRUN_CHECK_OVERHEAD \ (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE) -#define XMALLOC_BASE_ALIGNMENT alignof (max_align_t) - -#define XMALLOC_HEADER_ALIGNMENT \ - COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT) - /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to hold a size_t value and (2) the header size is a multiple of the alignment that Emacs needs for C types and for USE_LSB_TAG. */ #define XMALLOC_OVERRUN_SIZE_SIZE \ (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \ - + XMALLOC_HEADER_ALIGNMENT - 1) \ - / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \ + + LISP_ALIGNMENT - 1) \ + / LISP_ALIGNMENT * LISP_ALIGNMENT) \ - XMALLOC_OVERRUN_CHECK_SIZE) static char const xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE] = @@ -1140,11 +1163,10 @@ lisp_free (void *block) verify (POWER_OF_2 (BLOCK_ALIGN)); /* Use aligned_alloc if it or a simple substitute is available. - Address sanitization breaks aligned allocation, as of gcc 4.8.2 and - clang 3.3 anyway. Aligned allocation is incompatible with - unexmacosx.c, so don't use it on Darwin. */ + Aligned allocation is incompatible with unexmacosx.c, so don't use + it on Darwin unless CANNOT_DUMP. */ -#if ! ADDRESS_SANITIZER && !defined DARWIN_OS +#if !defined DARWIN_OS || defined CANNOT_DUMP # if (defined HAVE_ALIGNED_ALLOC \ || (defined HYBRID_MALLOC \ ? defined HAVE_POSIX_MEMALIGN \ @@ -1160,9 +1182,11 @@ aligned_alloc (size_t alignment, size_t size) Verify this for all arguments this function is given. */ verify (BLOCK_ALIGN % sizeof (void *) == 0 && POWER_OF_2 (BLOCK_ALIGN / sizeof (void *))); - verify (GCALIGNMENT % sizeof (void *) == 0 - && POWER_OF_2 (GCALIGNMENT / sizeof (void *))); - eassert (alignment == BLOCK_ALIGN || alignment == GCALIGNMENT); + verify (MALLOC_IS_LISP_ALIGNED + || (LISP_ALIGNMENT % sizeof (void *) == 0 + && POWER_OF_2 (LISP_ALIGNMENT / sizeof (void *)))); + eassert (alignment == BLOCK_ALIGN + || (!MALLOC_IS_LISP_ALIGNED && alignment == LISP_ALIGNMENT)); void *p; return posix_memalign (&p, alignment, size) == 0 ? p : 0; @@ -1394,31 +1418,15 @@ lisp_align_free (void *block) MALLOC_UNBLOCK_INPUT; } -#if !defined __GNUC__ && !defined __alignof__ -# define __alignof__(type) alignof (type) -#endif - -/* True if malloc (N) is known to return a multiple of GCALIGNMENT - whenever N is also a multiple. In practice this is true if - __alignof__ (max_align_t) is a multiple as well, assuming - GCALIGNMENT is 8; other values of GCALIGNMENT have not been looked - into. Use __alignof__ if available, as otherwise - MALLOC_IS_GC_ALIGNED would be false on GCC x86 even though the - alignment is OK there. - - This is a macro, not an enum constant, for portability to HP-UX - 10.20 cc and AIX 3.2.5 xlc. */ -#define MALLOC_IS_GC_ALIGNED \ - (GCALIGNMENT == 8 && __alignof__ (max_align_t) % GCALIGNMENT == 0) - /* True if a malloc-returned pointer P is suitably aligned for SIZE, - where Lisp alignment may be needed if SIZE is Lisp-aligned. */ + where Lisp object alignment may be needed if SIZE is a multiple of + LISP_ALIGNMENT. */ static bool laligned (void *p, size_t size) { - return (MALLOC_IS_GC_ALIGNED || (intptr_t) p % GCALIGNMENT == 0 - || size % GCALIGNMENT != 0); + return (MALLOC_IS_LISP_ALIGNED || (intptr_t) p % LISP_ALIGNMENT == 0 + || size % LISP_ALIGNMENT != 0); } /* Like malloc and realloc except that if SIZE is Lisp-aligned, make @@ -1440,9 +1448,9 @@ laligned (void *p, size_t size) static void * lmalloc (size_t size) { -#if USE_ALIGNED_ALLOC - if (! MALLOC_IS_GC_ALIGNED && size % GCALIGNMENT == 0) - return aligned_alloc (GCALIGNMENT, size); +#ifdef USE_ALIGNED_ALLOC + if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0) + return aligned_alloc (LISP_ALIGNMENT, size); #endif while (true) @@ -1451,7 +1459,7 @@ lmalloc (size_t size) if (laligned (p, size)) return p; free (p); - size_t bigger = size + GCALIGNMENT; + size_t bigger = size + LISP_ALIGNMENT; if (size < bigger) size = bigger; } @@ -1465,7 +1473,7 @@ lrealloc (void *p, size_t size) p = realloc (p, size); if (laligned (p, size)) return p; - size_t bigger = size + GCALIGNMENT; + size_t bigger = size + LISP_ALIGNMENT; if (size < bigger) size = bigger; } @@ -1737,7 +1745,8 @@ static EMACS_INT total_string_bytes; a pointer to the `u.data' member of its sdata structure; the structure starts at a constant offset in front of that. */ -#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET)) +#define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \ + - SDATA_DATA_OFFSET)) #ifdef GC_CHECK_STRING_OVERRUN @@ -1929,7 +1938,7 @@ allocate_string (void) /* Every string on a free list should have NULL data pointer. */ s->u.s.data = NULL; NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = s; + string_free_list = ptr_bounds_clip (s, sizeof *s); } total_free_strings += STRING_BLOCK_SIZE; @@ -2044,7 +2053,7 @@ allocate_string_data (struct Lisp_String *s, MALLOC_UNBLOCK_INPUT; - s->u.s.data = SDATA_DATA (data); + s->u.s.data = ptr_bounds_clip (SDATA_DATA (data), nbytes + 1); #ifdef GC_CHECK_STRING_BYTES SDATA_NBYTES (data) = nbytes; #endif @@ -2130,7 +2139,7 @@ sweep_strings (void) /* Put the string on the free-list. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = s; + string_free_list = ptr_bounds_clip (s, sizeof *s); ++nfree; } } @@ -2138,7 +2147,7 @@ sweep_strings (void) { /* S was on the free-list before. Put it there again. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = s; + string_free_list = ptr_bounds_clip (s, sizeof *s); ++nfree; } } @@ -2234,9 +2243,9 @@ compact_small_strings (void) nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from); eassert (nbytes <= LARGE_STRING_BYTES); - nbytes = SDATA_SIZE (nbytes); + ptrdiff_t size = SDATA_SIZE (nbytes); sdata *from_end = (sdata *) ((char *) from - + nbytes + GC_STRING_EXTRA); + + size + GC_STRING_EXTRA); #ifdef GC_CHECK_STRING_OVERRUN if (memcmp (string_overrun_cookie, @@ -2250,22 +2259,23 @@ compact_small_strings (void) { /* If TB is full, proceed with the next sblock. */ sdata *to_end = (sdata *) ((char *) to - + nbytes + GC_STRING_EXTRA); + + size + GC_STRING_EXTRA); if (to_end > tb_end) { tb->next_free = to; tb = tb->next; tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE); to = tb->data; - to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA); + to_end = (sdata *) ((char *) to + size + GC_STRING_EXTRA); } /* Copy, and update the string's `data' pointer. */ if (from != to) { eassert (tb != b || to < from); - memmove (to, from, nbytes + GC_STRING_EXTRA); - to->string->u.s.data = SDATA_DATA (to); + memmove (to, from, size + GC_STRING_EXTRA); + to->string->u.s.data + = ptr_bounds_clip (SDATA_DATA (to), nbytes + 1); } /* Advance past the sdata we copied to. */ @@ -2299,23 +2309,25 @@ string_overflow (void) error ("Maximum string size exceeded"); } -DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, +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. -INIT must be an integer that represents a character. */) - (Lisp_Object length, Lisp_Object init) +INIT must be an integer that represents a character. +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; EMACS_INT nbytes; - CHECK_NATNUM (length); + CHECK_FIXNAT (length); CHECK_CHARACTER (init); - c = XFASTINT (init); - if (ASCII_CHAR_P (c)) + c = XFIXNAT (init); + if (ASCII_CHAR_P (c) && NILP (multibyte)) { - nbytes = XINT (length); + nbytes = XFIXNUM (length); val = make_uninit_string (nbytes); if (nbytes) { @@ -2327,7 +2339,7 @@ INIT must be an integer that represents a character. */) { unsigned char str[MAX_MULTIBYTE_LENGTH]; ptrdiff_t len = CHAR_STRING (c, str); - EMACS_INT string_len = XINT (length); + EMACS_INT string_len = XFIXNUM (length); unsigned char *p, *beg, *end; if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes)) @@ -2403,8 +2415,8 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */) { Lisp_Object val; - CHECK_NATNUM (length); - val = make_uninit_bool_vector (XFASTINT (length)); + CHECK_FIXNAT (length); + val = make_uninit_bool_vector (XFIXNAT (length)); return bool_vector_fill (val, init); } @@ -2878,9 +2890,9 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, (Lisp_Object length, Lisp_Object init) { Lisp_Object val = Qnil; - CHECK_NATNUM (length); + CHECK_FIXNAT (length); - for (EMACS_INT size = XFASTINT (length); 0 < size; size--) + for (EMACS_INT size = XFIXNAT (length); 0 < size; size--) { val = Fcons (init, val); rarely_quit (size); @@ -2903,7 +2915,7 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, static struct Lisp_Vector * next_vector (struct Lisp_Vector *v) { - return XUNTAG (v->contents[0], Lisp_Int0); + return XUNTAG (v->contents[0], Lisp_Int0, struct Lisp_Vector); } static void @@ -2916,18 +2928,10 @@ set_next_vector (struct Lisp_Vector *v, struct Lisp_Vector *p) for the most common cases; it's not required to be a power of two, but it's expected to be a mult-of-ROUNDUP_SIZE (see below). */ -#define VECTOR_BLOCK_SIZE 4096 - -/* Alignment of struct Lisp_Vector objects. Because pseudovectors - can contain any C type, align at least as strictly as - max_align_t. On x86 and x86-64 this can waste up to 8 bytes - for typical vectors, since alignof (max_align_t) is 16 but - typical vectors need only an alignment of 8. However, it is - not worth the hassle to avoid wasting those bytes. */ -enum {vector_alignment = COMMON_MULTIPLE (alignof (max_align_t), GCALIGNMENT)}; +enum { VECTOR_BLOCK_SIZE = 4096 }; /* Vector size requests are a multiple of this. */ -enum { roundup_size = COMMON_MULTIPLE (vector_alignment, word_size) }; +enum { roundup_size = COMMON_MULTIPLE (LISP_ALIGNMENT, word_size) }; /* Verify assumptions described above. */ verify (VECTOR_BLOCK_SIZE % roundup_size == 0); @@ -2940,22 +2944,21 @@ verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS)); /* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */ -#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *))) +enum {VECTOR_BLOCK_BYTES = VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *))}; /* Size of the minimal vector allocated from block. */ -#define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object)) +enum { VBLOCK_BYTES_MIN = vroundup_ct (header_size + sizeof (Lisp_Object)) }; /* Size of the largest vector allocated from block. */ -#define VBLOCK_BYTES_MAX \ - vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size) +enum { VBLOCK_BYTES_MAX = vroundup_ct ((VECTOR_BLOCK_BYTES / 2) - word_size) }; /* We maintain one free list for each possible block-allocated vector size, and this is the number of free lists we have. */ -#define VECTOR_MAX_FREE_LIST_INDEX \ - ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1) +enum { VECTOR_MAX_FREE_LIST_INDEX = + (VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1 }; /* Common shortcut to advance vector pointer over a block data. */ @@ -2994,7 +2997,7 @@ struct large_vector enum { - large_vector_offset = ROUNDUP (sizeof (struct large_vector), vector_alignment) + large_vector_offset = ROUNDUP (sizeof (struct large_vector), LISP_ALIGNMENT) }; static struct Lisp_Vector * @@ -3042,6 +3045,7 @@ static EMACS_INT total_vector_slots, total_free_vector_slots; static void setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes) { + v = ptr_bounds_clip (v, nbytes); eassume (header_size <= nbytes); ptrdiff_t nwords = (nbytes - header_size) / word_size; XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords); @@ -3081,14 +3085,14 @@ init_vectors (void) /* Allocate vector from a vector block. */ static struct Lisp_Vector * -allocate_vector_from_block (size_t nbytes) +allocate_vector_from_block (ptrdiff_t nbytes) { struct Lisp_Vector *vector; struct vector_block *block; size_t index, restbytes; - eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX); - eassert (nbytes % roundup_size == 0); + eassume (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX); + eassume (nbytes % roundup_size == 0); /* First, try to allocate from a free list containing vectors of the requested size. */ @@ -3173,35 +3177,63 @@ vector_nbytes (struct Lisp_Vector *v) return vroundup (header_size + word_size * nwords); } +/* Convert a pseudovector pointer P to its underlying struct T pointer. + Verify that the struct is small, since cleanup_vector is called + only on small vector-like objects. */ + +#define PSEUDOVEC_STRUCT(p, t) \ + verify_expr ((header_size + VECSIZE (struct t) * word_size \ + <= VBLOCK_BYTES_MAX), \ + (struct t *) (p)) + /* Release extra resources still in use by VECTOR, which may be any - vector-like object. */ + small vector-like object. */ static void cleanup_vector (struct Lisp_Vector *vector) { detect_suspicious_free (vector); - if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT) - && ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) - == FONT_OBJECT_MAX)) - { - struct font_driver const *drv = ((struct font *) vector)->driver; - /* The font driver might sometimes be NULL, e.g. if Emacs was - interrupted before it had time to set it up. */ - if (drv) + if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BIGNUM)) + mpz_clear (PSEUDOVEC_STRUCT (vector, Lisp_Bignum)->value); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FINALIZER)) + unchain_finalizer (PSEUDOVEC_STRUCT (vector, Lisp_Finalizer)); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT)) + { + if ((vector->header.size & PSEUDOVECTOR_SIZE_MASK) == FONT_OBJECT_MAX) { - /* Attempt to catch subtle bugs like Bug#16140. */ - eassert (valid_font_driver (drv)); - drv->close ((struct font *) vector); + struct font *font = PSEUDOVEC_STRUCT (vector, font); + struct font_driver const *drv = font->driver; + + /* The font driver might sometimes be NULL, e.g. if Emacs was + interrupted before it had time to set it up. */ + if (drv) + { + /* Attempt to catch subtle bugs like Bug#16140. */ + eassert (valid_font_driver (drv)); + drv->close (font); + } } } - - if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) - finalize_one_thread ((struct thread_state *) vector); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD)) + finalize_one_thread (PSEUDOVEC_STRUCT (vector, thread_state)); else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX)) - finalize_one_mutex ((struct Lisp_Mutex *) vector); + finalize_one_mutex (PSEUDOVEC_STRUCT (vector, Lisp_Mutex)); else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR)) - finalize_one_condvar ((struct Lisp_CondVar *) vector); + finalize_one_condvar (PSEUDOVEC_STRUCT (vector, Lisp_CondVar)); + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MARKER)) + { + /* sweep_buffer should already have unchained this from its buffer. */ + eassert (! PSEUDOVEC_STRUCT (vector, Lisp_Marker)->buffer); + } +#ifdef HAVE_MODULES + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_USER_PTR)) + { + struct Lisp_User_Ptr *uptr = PSEUDOVEC_STRUCT (vector, Lisp_User_Ptr); + if (uptr->finalizer) + uptr->finalizer (uptr->p); + } +#endif } /* Reclaim space used by unmarked vectors. */ @@ -3311,15 +3343,14 @@ sweep_vectors (void) static struct Lisp_Vector * allocate_vectorlike (ptrdiff_t len) { - struct Lisp_Vector *p; - - MALLOC_BLOCK_INPUT; - if (len == 0) - p = XVECTOR (zero_vector); + return XVECTOR (zero_vector); else { size_t nbytes = header_size + len * word_size; + struct Lisp_Vector *p; + + MALLOC_BLOCK_INPUT; #ifdef DOUG_LEA_MALLOC if (!mmap_lisp_allowed_p ()) @@ -3349,11 +3380,11 @@ allocate_vectorlike (ptrdiff_t len) consing_since_gc += nbytes; vector_cells_consed += len; - } - MALLOC_UNBLOCK_INPUT; + MALLOC_UNBLOCK_INPUT; - return p; + return ptr_bounds_clip (p, nbytes); + } } @@ -3431,8 +3462,8 @@ symbol or a type descriptor. SLOTS is the number of non-type slots, each initialized to INIT. */) (Lisp_Object type, Lisp_Object slots, Lisp_Object init) { - CHECK_NATNUM (slots); - EMACS_INT size = XFASTINT (slots) + 1; + CHECK_FIXNAT (slots); + EMACS_INT size = XFIXNAT (slots) + 1; struct Lisp_Vector *p = allocate_record (size); p->contents[0] = type; for (ptrdiff_t i = 1; i < size; i++) @@ -3460,9 +3491,9 @@ DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, See also the function `vector'. */) (Lisp_Object length, Lisp_Object init) { - CHECK_NATNUM (length); - struct Lisp_Vector *p = allocate_vector (XFASTINT (length)); - for (ptrdiff_t i = 0; i < XFASTINT (length); i++) + CHECK_FIXNAT (length); + struct Lisp_Vector *p = allocate_vector (XFIXNAT (length)); + for (ptrdiff_t i = 0; i < XFIXNAT (length); i++) p->contents[i] = init; return make_lisp_ptr (p, Lisp_Vectorlike); } @@ -3633,205 +3664,27 @@ Its value is void, and its function definition and property list are nil. */) -/*********************************************************************** - Marker (Misc) Allocation - ***********************************************************************/ - -/* Like union Lisp_Misc, but padded so that its size is a multiple of - the required alignment. */ - -union aligned_Lisp_Misc -{ - union Lisp_Misc m; - unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1) - & -GCALIGNMENT]; -}; - -/* Allocation of markers and other objects that share that structure. - Works like allocation of conses. */ - -#define MARKER_BLOCK_SIZE \ - ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc)) - -struct marker_block -{ - /* Place `markers' first, to preserve alignment. */ - union aligned_Lisp_Misc markers[MARKER_BLOCK_SIZE]; - struct marker_block *next; -}; - -static struct marker_block *marker_block; -static int marker_block_index = MARKER_BLOCK_SIZE; - -static union Lisp_Misc *marker_free_list; - -/* Return a newly allocated Lisp_Misc object of specified TYPE. */ - -static Lisp_Object -allocate_misc (enum Lisp_Misc_Type type) -{ - Lisp_Object val; - - MALLOC_BLOCK_INPUT; - - if (marker_free_list) - { - XSETMISC (val, marker_free_list); - marker_free_list = marker_free_list->u_free.chain; - } - else - { - if (marker_block_index == MARKER_BLOCK_SIZE) - { - struct marker_block *new = lisp_malloc (sizeof *new, MEM_TYPE_MISC); - new->next = marker_block; - marker_block = new; - marker_block_index = 0; - total_free_markers += MARKER_BLOCK_SIZE; - } - XSETMISC (val, &marker_block->markers[marker_block_index].m); - marker_block_index++; - } - - MALLOC_UNBLOCK_INPUT; - - --total_free_markers; - consing_since_gc += sizeof (union Lisp_Misc); - misc_objects_consed++; - XMISCANY (val)->type = type; - XMISCANY (val)->gcmarkbit = 0; - return val; -} - -/* Free a Lisp_Misc object. */ - -void -free_misc (Lisp_Object misc) -{ - XMISCANY (misc)->type = Lisp_Misc_Free; - XMISC (misc)->u_free.chain = marker_free_list; - marker_free_list = XMISC (misc); - consing_since_gc -= sizeof (union Lisp_Misc); - total_free_markers++; -} - -/* Verify properties of Lisp_Save_Value's representation - that are assumed here and elsewhere. */ - -verify (SAVE_UNUSED == 0); -verify (((SAVE_INTEGER | SAVE_POINTER | SAVE_FUNCPOINTER | SAVE_OBJECT) - >> SAVE_SLOT_BITS) - == 0); - -/* Return Lisp_Save_Value objects for the various combinations - that callers need. */ - -Lisp_Object -make_save_int_int_int (ptrdiff_t a, ptrdiff_t b, ptrdiff_t c) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_INT_INT_INT; - p->data[0].integer = a; - p->data[1].integer = b; - p->data[2].integer = c; - return val; -} - -Lisp_Object -make_save_obj_obj_obj_obj (Lisp_Object a, Lisp_Object b, Lisp_Object c, - Lisp_Object d) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_OBJ_OBJ_OBJ_OBJ; - p->data[0].object = a; - p->data[1].object = b; - p->data[2].object = c; - p->data[3].object = d; - return val; -} - -Lisp_Object -make_save_ptr (void *a) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_POINTER; - p->data[0].pointer = a; - return val; -} - Lisp_Object -make_save_ptr_int (void *a, ptrdiff_t b) +make_misc_ptr (void *a) { - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_PTR_INT; - p->data[0].pointer = a; - p->data[1].integer = b; - return val; -} - -Lisp_Object -make_save_ptr_ptr (void *a, void *b) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_PTR_PTR; - p->data[0].pointer = a; - p->data[1].pointer = b; - return val; -} - -Lisp_Object -make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_FUNCPTR_PTR_OBJ; - p->data[0].funcpointer = a; - p->data[1].pointer = b; - p->data[2].object = c; - return val; -} - -/* Return a Lisp_Save_Value object that represents an array A - of N Lisp objects. */ - -Lisp_Object -make_save_memory (Lisp_Object *a, ptrdiff_t n) -{ - Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value); - struct Lisp_Save_Value *p = XSAVE_VALUE (val); - p->save_type = SAVE_TYPE_MEMORY; - p->data[0].pointer = a; - p->data[1].integer = n; - return val; -} - -/* Free a Lisp_Save_Value object. Do not use this function - if SAVE contains pointer other than returned by xmalloc. */ - -void -free_save_value (Lisp_Object save) -{ - xfree (XSAVE_POINTER (save, 0)); - free_misc (save); + struct Lisp_Misc_Ptr *p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Misc_Ptr, pointer, + PVEC_MISC_PTR); + p->pointer = a; + return make_lisp_ptr (p, Lisp_Vectorlike); } -/* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */ +/* Return a new overlay with specified START, END and PLIST. */ Lisp_Object build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist) { - register Lisp_Object overlay; - - overlay = allocate_misc (Lisp_Misc_Overlay); + struct Lisp_Overlay *p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Overlay, next, + PVEC_OVERLAY); + Lisp_Object overlay = make_lisp_ptr (p, Lisp_Vectorlike); OVERLAY_START (overlay) = start; OVERLAY_END (overlay) = end; set_overlay_plist (overlay, plist); - XOVERLAY (overlay)->next = NULL; + p->next = NULL; return overlay; } @@ -3839,18 +3692,15 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, doc: /* Return a newly allocated marker which does not point at any place. */) (void) { - register Lisp_Object val; - register struct Lisp_Marker *p; - - val = allocate_misc (Lisp_Misc_Marker); - p = XMARKER (val); + struct Lisp_Marker *p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Marker, buffer, + PVEC_MARKER); p->buffer = 0; p->bytepos = 0; p->charpos = 0; p->next = NULL; p->insertion_type = 0; p->need_adjustment = 0; - return val; + return make_lisp_ptr (p, Lisp_Vectorlike); } /* Return a newly allocated marker which points into BUF @@ -3859,17 +3709,14 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, Lisp_Object build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos) { - Lisp_Object obj; - struct Lisp_Marker *m; - /* No dead buffers here. */ eassert (BUFFER_LIVE_P (buf)); /* Every character is at least one byte. */ eassert (charpos <= bytepos); - obj = allocate_misc (Lisp_Misc_Marker); - m = XMARKER (obj); + struct Lisp_Marker *m = ALLOCATE_PSEUDOVECTOR (struct Lisp_Marker, buffer, + PVEC_MARKER); m->buffer = buf; m->charpos = charpos; m->bytepos = bytepos; @@ -3877,7 +3724,84 @@ build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos) m->need_adjustment = 0; m->next = BUF_MARKERS (buf); BUF_MARKERS (buf) = m; - return obj; + return make_lisp_ptr (m, Lisp_Vectorlike); +} + + + +Lisp_Object +make_bignum_str (const char *num, int base) +{ + struct Lisp_Bignum *b = ALLOCATE_PSEUDOVECTOR (struct Lisp_Bignum, value, + PVEC_BIGNUM); + mpz_init (b->value); + int check = mpz_set_str (b->value, num, base); + eassert (check == 0); + return make_lisp_ptr (b, Lisp_Vectorlike); +} + +/* Given an mpz_t, make a number. This may return a bignum or a + fixnum depending on VALUE. */ + +Lisp_Object +make_number (mpz_t value) +{ + size_t bits = mpz_sizeinbase (value, 2); + + if (bits <= FIXNUM_BITS) + { + EMACS_INT v = 0; + int i = 0, shift = 0; + + do + { + EMACS_INT limb = mpz_getlimbn (value, i++); + v += limb << shift; + shift += GMP_NUMB_BITS; + } + while (shift < bits); + + if (mpz_sgn (value) < 0) + v = -v; + + if (!FIXNUM_OVERFLOW_P (v)) + return make_fixnum (v); + } + + /* The documentation says integer-width should be nonnegative, so + a single comparison suffices even though 'bits' is unsigned. */ + if (integer_width < bits) + range_error (); + + struct Lisp_Bignum *b = ALLOCATE_PSEUDOVECTOR (struct Lisp_Bignum, value, + PVEC_BIGNUM); + /* We could mpz_init + mpz_swap here, to avoid a copy, but the + resulting API seemed possibly confusing. */ + mpz_init_set (b->value, value); + + return make_lisp_ptr (b, Lisp_Vectorlike); +} + +void +mpz_set_intmax_slow (mpz_t result, intmax_t v) +{ + /* If V fits in long, a faster path is taken. */ + eassert (! (LONG_MIN <= v && v <= LONG_MAX)); + + bool complement = v < 0; + if (complement) + v = -1 - v; + + enum { nails = sizeof v * CHAR_BIT - INTMAX_WIDTH }; +# ifndef HAVE_GMP + /* mini-gmp requires NAILS to be zero, which is true for all + likely Emacs platforms. Sanity-check this. */ + verify (nails == 0); +# endif + + mpz_import (result, 1, -1, sizeof v, 0, nails, &v); + if (complement) + mpz_com (result, result); } @@ -3896,8 +3820,8 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args) /* The things that fit in a string are characters that are in 0...127, after discarding the meta bit and all the bits above it. */ - if (!INTEGERP (args[i]) - || (XINT (args[i]) & ~(-CHAR_META)) >= 0200) + if (!FIXNUMP (args[i]) + || (XFIXNUM (args[i]) & ~(-CHAR_META)) >= 0200) return Fvector (nargs, args); /* Since the loop exited, we know that all the things in it are @@ -3905,12 +3829,12 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args) { Lisp_Object result; - result = Fmake_string (make_number (nargs), make_number (0)); + result = Fmake_string (make_fixnum (nargs), make_fixnum (0), Qnil); for (i = 0; i < nargs; i++) { - SSET (result, i, XINT (args[i])); + SSET (result, i, XFIXNUM (args[i])); /* Move the meta bit to the right place for a string char. */ - if (XINT (args[i]) & CHAR_META) + if (XFIXNUM (args[i]) & CHAR_META) SSET (result, i, SREF (result, i) | 0x80); } @@ -3923,14 +3847,11 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args) Lisp_Object make_user_ptr (void (*finalizer) (void *), void *p) { - Lisp_Object obj; - struct Lisp_User_Ptr *uptr; - - obj = allocate_misc (Lisp_Misc_User_Ptr); - uptr = XUSER_PTR (obj); + struct Lisp_User_Ptr *uptr = ALLOCATE_PSEUDOVECTOR (struct Lisp_User_Ptr, + finalizer, PVEC_USER_PTR); uptr->finalizer = finalizer; uptr->p = p; - return obj; + return make_lisp_ptr (uptr, Lisp_Vectorlike); } #endif @@ -3973,7 +3894,7 @@ mark_finalizer_list (struct Lisp_Finalizer *head) finalizer != head; finalizer = finalizer->next) { - finalizer->base.gcmarkbit = true; + VECTOR_MARK (finalizer); mark_object (finalizer->function); } } @@ -3990,7 +3911,7 @@ queue_doomed_finalizers (struct Lisp_Finalizer *dest, while (finalizer != src) { struct Lisp_Finalizer *next = finalizer->next; - if (!finalizer->base.gcmarkbit && !NILP (finalizer->function)) + if (!VECTOR_MARKED_P (finalizer) && !NILP (finalizer->function)) { unchain_finalizer (finalizer); finalizer_insert (dest, finalizer); @@ -4026,7 +3947,6 @@ run_finalizers (struct Lisp_Finalizer *finalizers) while (finalizers->next != finalizers) { finalizer = finalizers->next; - eassert (finalizer->base.type == Lisp_Misc_Finalizer); unchain_finalizer (finalizer); function = finalizer->function; if (!NILP (function)) @@ -4046,12 +3966,12 @@ count as reachable for the purpose of deciding whether to run FUNCTION. FUNCTION will be run once per finalizer object. */) (Lisp_Object function) { - Lisp_Object val = allocate_misc (Lisp_Misc_Finalizer); - struct Lisp_Finalizer *finalizer = XFINALIZER (val); + struct Lisp_Finalizer *finalizer + = ALLOCATE_PSEUDOVECTOR (struct Lisp_Finalizer, prev, PVEC_FINALIZER); finalizer->function = function; finalizer->prev = finalizer->next = NULL; finalizer_insert (&finalizers, finalizer); - return val; + return make_lisp_ptr (finalizer, Lisp_Vectorlike); } @@ -4561,6 +4481,7 @@ live_string_holding (struct mem_node *m, void *p) 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); @@ -4595,6 +4516,7 @@ live_cons_holding (struct mem_node *m, void *p) && (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 (!EQ (s->u.s.car, Vdead)) return make_lisp_ptr (s, Lisp_Cons); @@ -4630,6 +4552,7 @@ live_symbol_holding (struct mem_node *m, void *p) && (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 (!EQ (s->u.s.function, Vdead)) return make_lisp_symbol (s); @@ -4669,40 +4592,6 @@ live_float_p (struct mem_node *m, void *p) return 0; } - -/* If P is a pointer to a live Lisp Misc on the heap, return the object. - Otherwise, return nil. M is a pointer to the mem_block for P. */ - -static Lisp_Object -live_misc_holding (struct mem_node *m, void *p) -{ - if (m->type == MEM_TYPE_MISC) - { - struct marker_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->markers[0]; - - /* P must point into a Lisp_Misc, not be - one of the unused cells in the current misc block, - and not be on the free-list. */ - if (0 <= offset && offset < MARKER_BLOCK_SIZE * sizeof b->markers[0] - && (b != marker_block - || offset / sizeof b->markers[0] < marker_block_index)) - { - union Lisp_Misc *s = p = cp -= offset % sizeof b->markers[0]; - if (s->u_any.type != Lisp_Misc_Free) - return make_lisp_ptr (s, Lisp_Misc); - } - } - return Qnil; -} - -static bool -live_misc_p (struct mem_node *m, void *p) -{ - return !NILP (live_misc_holding (m, p)); -} - /* If P is a pointer to a live vector-like object, return the object. Otherwise, return nil. M is a pointer to the mem_block for P. */ @@ -4788,7 +4677,7 @@ mark_maybe_object (Lisp_Object obj) VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); #endif - if (INTEGERP (obj)) + if (FIXNUMP (obj)) return; void *po = XPNTR (obj); @@ -4821,10 +4710,6 @@ mark_maybe_object (Lisp_Object obj) || EQ (obj, live_buffer_holding (m, po))); break; - case Lisp_Misc: - mark_p = EQ (obj, live_misc_holding (m, po)); - break; - default: break; } @@ -4834,14 +4719,23 @@ mark_maybe_object (Lisp_Object obj) } } -/* Return true if P can point to Lisp data, and false otherwise. +void +mark_maybe_objects (Lisp_Object *array, ptrdiff_t nelts) +{ + for (Lisp_Object *lim = array + nelts; array < lim; array++) + mark_maybe_object (*array); +} + +/* Return true if P might point to Lisp data that can be garbage + collected, and false otherwise (i.e., false if it is easy to see + that P cannot point to Lisp data that can be garbage collected). Symbols are implemented via offsets not pointers, but the offsets - are also multiples of GCALIGNMENT. */ + are also multiples of LISP_ALIGNMENT. */ static bool maybe_lisp_pointer (void *p) { - return (uintptr_t) p % GCALIGNMENT == 0; + return (uintptr_t) p % LISP_ALIGNMENT == 0; } #ifndef HAVE_MODULES @@ -4870,7 +4764,7 @@ mark_maybe_pointer (void *p) { /* For the wide-int case, also mark emacs_value tagged pointers, which can be generated by emacs-module.c's value_to_lisp. */ - p = (void *) ((uintptr_t) p & ~(GCALIGNMENT - 1)); + p = (void *) ((uintptr_t) p & ~((1 << GCTYPEBITS) - 1)); } m = mem_find (p); @@ -4897,10 +4791,6 @@ mark_maybe_pointer (void *p) obj = live_string_holding (m, p); break; - case MEM_TYPE_MISC: - obj = live_misc_holding (m, p); - break; - case MEM_TYPE_SYMBOL: obj = live_symbol_holding (m, p); break; @@ -5253,15 +5143,13 @@ valid_pointer_p (void *p) /* Return 2 if OBJ is a killed or special buffer object, 1 if OBJ is a valid lisp object, 0 if OBJ is NOT a valid lisp object, or -1 if we - cannot validate OBJ. This function can be quite slow, so its primary - use is the manual debugging. The only exception is print_object, where - we use it to check whether the memory referenced by the pointer of - Lisp_Save_Value object contains valid objects. */ + cannot validate OBJ. This function can be quite slow, and is used + only in debugging. */ int valid_lisp_object_p (Lisp_Object obj) { - if (INTEGERP (obj)) + if (FIXNUMP (obj)) return 1; void *p = XPNTR (obj); @@ -5303,9 +5191,6 @@ valid_lisp_object_p (Lisp_Object obj) case MEM_TYPE_STRING: return live_string_p (m, p); - case MEM_TYPE_MISC: - return live_misc_p (m, p); - case MEM_TYPE_SYMBOL: return live_symbol_p (m, p); @@ -5341,7 +5226,7 @@ pure_alloc (size_t size, int type) { /* Allocate space for a Lisp object from the beginning of the free space with taking account of alignment. */ - result = pointer_align (purebeg + pure_bytes_used_lisp, GCALIGNMENT); + result = pointer_align (purebeg + pure_bytes_used_lisp, LISP_ALIGNMENT); pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size; } else @@ -5354,7 +5239,7 @@ pure_alloc (size_t size, int type) pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; if (pure_bytes_used <= pure_size) - return result; + return ptr_bounds_clip (result, size); /* Don't allocate a large amount here, because it might get mmap'd and then its address @@ -5439,7 +5324,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes) /* Check the remaining characters. */ if (memcmp (data, non_lisp_beg + start, nbytes) == 0) /* Found. */ - return non_lisp_beg + start; + return ptr_bounds_clip (non_lisp_beg + start, nbytes + 1); start += last_char_skip; } @@ -5522,6 +5407,32 @@ make_pure_float (double num) return new; } +/* Value is a bignum object with value VALUE allocated from pure + space. */ + +static Lisp_Object +make_pure_bignum (struct Lisp_Bignum *value) +{ + size_t i, nlimbs = mpz_size (value->value); + size_t nbytes = nlimbs * sizeof (mp_limb_t); + mp_limb_t *pure_limbs; + mp_size_t new_size; + + struct Lisp_Bignum *b = pure_alloc (sizeof *b, Lisp_Vectorlike); + XSETPVECTYPESIZE (b, PVEC_BIGNUM, 0, VECSIZE (struct Lisp_Bignum)); + + pure_limbs = pure_alloc (nbytes, -1); + for (i = 0; i < nlimbs; ++i) + pure_limbs[i] = mpz_getlimbn (value->value, i); + + new_size = nlimbs; + if (mpz_sgn (value->value) < 0) + new_size = -new_size; + + mpz_roinit_n (b->value, pure_limbs, new_size); + + return make_lisp_ptr (b, Lisp_Vectorlike); +} /* Return a vector with room for LEN Lisp_Objects allocated from pure space. */ @@ -5594,8 +5505,8 @@ static struct pinned_object static Lisp_Object purecopy (Lisp_Object obj) { - if (INTEGERP (obj) - || (! SYMBOLP (obj) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj))) + if (FIXNUMP (obj) + || (! SYMBOLP (obj) && PURE_P (XPNTR (obj))) || SUBRP (obj)) return obj; /* Already pure. */ @@ -5663,6 +5574,8 @@ purecopy (Lisp_Object obj) /* Don't hash-cons it. */ return obj; } + else if (BIGNUMP (obj)) + obj = make_pure_bignum (XBIGNUM (obj)); else { AUTO_STRING (fmt, "Don't know how to purify: %S"); @@ -5704,7 +5617,7 @@ inhibit_garbage_collection (void) { ptrdiff_t count = SPECPDL_INDEX (); - specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM)); + specbind (Qgc_cons_threshold, make_fixnum (MOST_POSITIVE_FIXNUM)); return count; } @@ -5714,7 +5627,7 @@ inhibit_garbage_collection (void) static Lisp_Object bounded_number (EMACS_INT number) { - return make_number (min (MOST_POSITIVE_FIXNUM, number)); + return make_fixnum (min (MOST_POSITIVE_FIXNUM, number)); } /* Calculate total bytes of live objects. */ @@ -5725,7 +5638,6 @@ total_bytes_of_live_objects (void) size_t tot = 0; tot += total_conses * sizeof (struct Lisp_Cons); tot += total_symbols * sizeof (struct Lisp_Symbol); - tot += total_markers * sizeof (union Lisp_Misc); tot += total_string_bytes; tot += total_vector_slots * word_size; tot += total_floats * sizeof (struct Lisp_Float); @@ -5846,7 +5758,7 @@ compact_undo_list (Lisp_Object list) { if (CONSP (XCAR (tail)) && MARKERP (XCAR (XCAR (tail))) - && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit) + && !VECTOR_MARKED_P (XMARKER (XCAR (XCAR (tail))))) *prev = XCDR (tail); else prev = xcdr_addr (tail); @@ -5956,6 +5868,7 @@ garbage_collect_1 (void *end) stack_copy = xrealloc (stack_copy, stack_size); stack_copy_size = stack_size; } + stack = ptr_bounds_set (stack, stack_size); no_sanitize_memcpy (stack_copy, stack, stack_size); } } @@ -6066,37 +5979,34 @@ garbage_collect_1 (void *end) unbind_to (count, Qnil); Lisp_Object total[] = { - list4 (Qconses, make_number (sizeof (struct Lisp_Cons)), + list4 (Qconses, make_fixnum (sizeof (struct Lisp_Cons)), bounded_number (total_conses), bounded_number (total_free_conses)), - list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)), + list4 (Qsymbols, make_fixnum (sizeof (struct Lisp_Symbol)), bounded_number (total_symbols), bounded_number (total_free_symbols)), - list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)), - bounded_number (total_markers), - bounded_number (total_free_markers)), - list4 (Qstrings, make_number (sizeof (struct Lisp_String)), + list4 (Qstrings, make_fixnum (sizeof (struct Lisp_String)), bounded_number (total_strings), bounded_number (total_free_strings)), - list3 (Qstring_bytes, make_number (1), + list3 (Qstring_bytes, make_fixnum (1), bounded_number (total_string_bytes)), list3 (Qvectors, - make_number (header_size + sizeof (Lisp_Object)), + make_fixnum (header_size + sizeof (Lisp_Object)), bounded_number (total_vectors)), - list4 (Qvector_slots, make_number (word_size), + list4 (Qvector_slots, make_fixnum (word_size), bounded_number (total_vector_slots), bounded_number (total_free_vector_slots)), - list4 (Qfloats, make_number (sizeof (struct Lisp_Float)), + list4 (Qfloats, make_fixnum (sizeof (struct Lisp_Float)), bounded_number (total_floats), bounded_number (total_free_floats)), - list4 (Qintervals, make_number (sizeof (struct interval)), + list4 (Qintervals, make_fixnum (sizeof (struct interval)), bounded_number (total_intervals), bounded_number (total_free_intervals)), - list3 (Qbuffers, make_number (sizeof (struct buffer)), + list3 (Qbuffers, make_fixnum (sizeof (struct buffer)), bounded_number (total_buffers)), #ifdef DOUG_LEA_MALLOC - list4 (Qheap, make_number (1024), + list4 (Qheap, make_fixnum (1024), bounded_number ((mallinfo ().uordblks + 1023) >> 10), bounded_number ((mallinfo ().fordblks + 1023) >> 10)), #endif @@ -6185,11 +6095,7 @@ mark_glyph_matrix (struct glyph_matrix *matrix) } } -/* Mark reference to a Lisp_Object. - If the object referred to has not been seen yet, recursively mark - all the references contained in it. */ - -#define LAST_MARKED_SIZE 500 +enum { LAST_MARKED_SIZE = 1 << 9 }; /* Must be a power of 2. */ Lisp_Object last_marked[LAST_MARKED_SIZE] EXTERNALLY_VISIBLE; static int last_marked_index; @@ -6235,7 +6141,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype) { Lisp_Object val = ptr->contents[i]; - if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->u.s.gcmarkbit)) + if (FIXNUMP (val) || (SYMBOLP (val) && XSYMBOL (val)->u.s.gcmarkbit)) continue; if (SUB_CHAR_TABLE_P (val)) { @@ -6265,12 +6171,12 @@ mark_compiled (struct Lisp_Vector *ptr) static void mark_overlay (struct Lisp_Overlay *ptr) { - for (; ptr && !ptr->gcmarkbit; ptr = ptr->next) + for (; ptr && !VECTOR_MARKED_P (ptr); ptr = ptr->next) { - ptr->gcmarkbit = 1; + VECTOR_MARK (ptr); /* These two are always markers and can be marked fast. */ - XMARKER (ptr->start)->gcmarkbit = 1; - XMARKER (ptr->end)->gcmarkbit = 1; + VECTOR_MARK (XMARKER (ptr->start)); + VECTOR_MARK (XMARKER (ptr->end)); mark_object (ptr->plist); } } @@ -6338,30 +6244,6 @@ mark_localized_symbol (struct Lisp_Symbol *ptr) mark_object (blv->defcell); } -NO_INLINE /* To reduce stack depth in mark_object. */ -static void -mark_save_value (struct Lisp_Save_Value *ptr) -{ - /* If `save_type' is zero, `data[0].pointer' is the address - of a memory area containing `data[1].integer' potential - Lisp_Objects. */ - if (ptr->save_type == SAVE_TYPE_MEMORY) - { - Lisp_Object *p = ptr->data[0].pointer; - ptrdiff_t nelt; - for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++) - mark_maybe_object (*p); - } - else - { - /* Find Lisp_Objects in `data[N]' slots and mark them. */ - int i; - for (i = 0; i < SAVE_VALUE_SLOTS; i++) - if (save_type (ptr, i) == SAVE_OBJECT) - mark_object (ptr->data[i].object); - } -} - /* Remove killed buffers or items whose car is a killed buffer from LIST, and mark other items. Return changed LIST, which is marked. */ @@ -6415,8 +6297,7 @@ mark_object (Lisp_Object arg) return; last_marked[last_marked_index++] = obj; - if (last_marked_index == LAST_MARKED_SIZE) - last_marked_index = 0; + last_marked_index &= LAST_MARKED_SIZE - 1; /* Perform some sanity checks on the objects marked here. Abort if we encounter an object we know is bogus. This increases GC time @@ -6596,9 +6477,8 @@ mark_object (Lisp_Object arg) mark_char_table (ptr, (enum pvec_type) pvectype); break; - case PVEC_BOOL_VECTOR: - /* No Lisp_Objects to mark in a bool vector. */ - VECTOR_MARK (ptr); + case PVEC_OVERLAY: + mark_overlay (XOVERLAY (obj)); break; case PVEC_SUBR: @@ -6608,6 +6488,8 @@ mark_object (Lisp_Object arg) emacs_abort (); default: + /* A regular vector, or a pseudovector needing no special + treatment. */ mark_vectorlike (ptr); } } @@ -6656,55 +6538,15 @@ mark_object (Lisp_Object arg) } break; - case Lisp_Misc: - CHECK_ALLOCATED_AND_LIVE (live_misc_p); - - if (XMISCANY (obj)->gcmarkbit) - break; - - switch (XMISCTYPE (obj)) - { - case Lisp_Misc_Marker: - /* DO NOT mark thru the marker's chain. - The buffer's markers chain does not preserve markers from gc; - instead, markers are removed from the chain when freed by gc. */ - XMISCANY (obj)->gcmarkbit = 1; - break; - - case Lisp_Misc_Save_Value: - XMISCANY (obj)->gcmarkbit = 1; - mark_save_value (XSAVE_VALUE (obj)); - break; - - case Lisp_Misc_Overlay: - mark_overlay (XOVERLAY (obj)); - break; - - case Lisp_Misc_Finalizer: - XMISCANY (obj)->gcmarkbit = true; - mark_object (XFINALIZER (obj)->function); - break; - -#ifdef HAVE_MODULES - case Lisp_Misc_User_Ptr: - XMISCANY (obj)->gcmarkbit = true; - break; -#endif - - default: - emacs_abort (); - } - break; - case Lisp_Cons: { - register struct Lisp_Cons *ptr = XCONS (obj); + struct Lisp_Cons *ptr = XCONS (obj); if (CONS_MARKED_P (ptr)) break; CHECK_ALLOCATED_AND_LIVE (live_cons_p); CONS_MARK (ptr); /* If the cdr is nil, avoid recursion for the car. */ - if (EQ (ptr->u.s.u.cdr, Qnil)) + if (NILP (ptr->u.s.u.cdr)) { obj = ptr->u.s.car; cdr_count = 0; @@ -6775,10 +6617,6 @@ survives_gc_p (Lisp_Object obj) survives_p = XSYMBOL (obj)->u.s.gcmarkbit; break; - case Lisp_Misc: - survives_p = XMISCANY (obj)->gcmarkbit; - break; - case Lisp_String: survives_p = STRING_MARKED_P (XSTRING (obj)); break; @@ -6845,7 +6683,9 @@ sweep_conses (void) for (pos = start; pos < stop; pos++) { - if (!CONS_MARKED_P (&cblk->conses[pos])) + struct Lisp_Cons *acons + = ptr_bounds_copy (&cblk->conses[pos], cblk); + if (!CONS_MARKED_P (acons)) { this_free++; cblk->conses[pos].u.s.u.chain = cons_free_list; @@ -6855,7 +6695,7 @@ sweep_conses (void) else { num_used++; - CONS_UNMARK (&cblk->conses[pos]); + CONS_UNMARK (acons); } } } @@ -6898,17 +6738,20 @@ sweep_floats (void) register int i; int this_free = 0; for (i = 0; i < lim; i++) - if (!FLOAT_MARKED_P (&fblk->floats[i])) - { - this_free++; - fblk->floats[i].u.chain = float_free_list; - float_free_list = &fblk->floats[i]; - } - else - { - num_used++; - FLOAT_UNMARK (&fblk->floats[i]); - } + { + struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk); + if (!FLOAT_MARKED_P (afloat)) + { + this_free++; + fblk->floats[i].u.chain = float_free_list; + float_free_list = &fblk->floats[i]; + } + else + { + num_used++; + FLOAT_UNMARK (afloat); + } + } lim = FLOAT_BLOCK_SIZE; /* If this block contains only free floats and we have already seen more than two blocks worth of free floats then deallocate @@ -7050,75 +6893,21 @@ sweep_symbols (void) total_free_symbols = num_free; } -NO_INLINE /* For better stack traces. */ +/* Remove BUFFER's markers that are due to be swept. This is needed since + we treat BUF_MARKERS and markers's `next' field as weak pointers. */ static void -sweep_misc (void) +unchain_dead_markers (struct buffer *buffer) { - register struct marker_block *mblk; - struct marker_block **mprev = &marker_block; - register int lim = marker_block_index; - EMACS_INT num_free = 0, num_used = 0; - - /* Put all unmarked misc's on free list. For a marker, first - unchain it from the buffer it points into. */ - - marker_free_list = 0; - - for (mblk = marker_block; mblk; mblk = *mprev) - { - register int i; - int this_free = 0; - - for (i = 0; i < lim; i++) - { - if (!mblk->markers[i].m.u_any.gcmarkbit) - { - if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker) - unchain_marker (&mblk->markers[i].m.u_marker); - else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer) - unchain_finalizer (&mblk->markers[i].m.u_finalizer); -#ifdef HAVE_MODULES - else if (mblk->markers[i].m.u_any.type == Lisp_Misc_User_Ptr) - { - struct Lisp_User_Ptr *uptr = &mblk->markers[i].m.u_user_ptr; - if (uptr->finalizer) - uptr->finalizer (uptr->p); - } -#endif - /* Set the type of the freed object to Lisp_Misc_Free. - We could leave the type alone, since nobody checks it, - but this might catch bugs faster. */ - mblk->markers[i].m.u_marker.type = Lisp_Misc_Free; - mblk->markers[i].m.u_free.chain = marker_free_list; - marker_free_list = &mblk->markers[i].m; - this_free++; - } - else - { - num_used++; - mblk->markers[i].m.u_any.gcmarkbit = 0; - } - } - lim = MARKER_BLOCK_SIZE; - /* If this block contains only free markers and we have already - seen more than two blocks worth of free markers then deallocate - this block. */ - if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE) - { - *mprev = mblk->next; - /* Unhook from the free list. */ - marker_free_list = mblk->markers[0].m.u_free.chain; - lisp_free (mblk); - } - else - { - num_free += this_free; - mprev = &mblk->next; - } - } + struct Lisp_Marker *this, **prev = &BUF_MARKERS (buffer); - total_markers = num_used; - total_free_markers = num_free; + while ((this = *prev)) + if (VECTOR_MARKED_P (this)) + prev = &this->next; + else + { + this->buffer = NULL; + *prev = this->next; + } } NO_INLINE /* For better stack traces */ @@ -7139,6 +6928,7 @@ sweep_buffers (void) VECTOR_UNMARK (buffer); /* Do not use buffer_(set|get)_intervals here. */ buffer->text->intervals = balance_intervals (buffer->text->intervals); + unchain_dead_markers (buffer); total_buffers++; bprev = &buffer->next; } @@ -7158,7 +6948,6 @@ gc_sweep (void) sweep_floats (); sweep_intervals (); sweep_symbols (); - sweep_misc (); sweep_buffers (); sweep_vectors (); check_string_bytes (!noninteractive); @@ -7214,46 +7003,26 @@ or memory information can't be obtained, return nil. */) /* Debugging aids. */ -DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0, - doc: /* Return the address of the last byte Emacs has allocated, divided by 1024. -This may be helpful in debugging Emacs's memory usage. -We divide the value by 1024 to make sure it fits in a Lisp integer. */) - (void) -{ - Lisp_Object end; - -#if defined HAVE_NS || defined __APPLE__ || !HAVE_SBRK - /* Avoid warning. sbrk has no relation to memory allocated anyway. */ - XSETINT (end, 0); -#else - XSETINT (end, (intptr_t) (char *) sbrk (0) / 1024); -#endif - - return end; -} - DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0, doc: /* Return a list of counters that measure how much consing there has been. Each of these counters increments for a certain kind of object. The counters wrap around from the largest positive integer to zero. Garbage collection does not decrease them. The elements of the value are as follows: - (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS) + (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS INTERVALS STRINGS) All are in units of 1 = one object consed except for VECTOR-CELLS and STRING-CHARS, which count the total length of objects consed. -MISCS include overlays, markers, and some internal types. Frames, windows, buffers, and subprocesses count as vectors (but the contents of a buffer's text do not count here). */) (void) { - return listn (CONSTYPE_HEAP, 8, + return listn (CONSTYPE_HEAP, 7, bounded_number (cons_cells_consed), bounded_number (floats_consed), bounded_number (vector_cells_consed), bounded_number (symbols_consed), bounded_number (string_chars_consed), - bounded_number (misc_objects_consed), bounded_number (intervals_consed), bounded_number (strings_consed)); } @@ -7318,8 +7087,7 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max) } out: - unbind_to (gc_count, Qnil); - return found; + return unbind_to (gc_count, found); } #ifdef SUSPICIOUS_OBJECT_CHECKING @@ -7432,6 +7200,26 @@ verify_alloca (void) #endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */ +/* Memory allocation for GMP. */ + +void +range_error (void) +{ + xsignal0 (Qrange_error); +} + +static void * +xrealloc_for_gmp (void *ptr, size_t ignore, size_t size) +{ + return xrealloc (ptr, size); +} + +static void +xfree_for_gmp (void *ptr, size_t ignore) +{ + xfree (ptr); +} + /* Initialization. */ void @@ -7465,6 +7253,10 @@ init_alloc_once (void) void init_alloc (void) { + eassert (mp_bits_per_limb == GMP_NUMB_BITS); + integer_width = 1 << 16; + mp_set_memory_functions (xmalloc, xrealloc_for_gmp, xfree_for_gmp); + Vgc_elapsed = make_float (0.0); gcs_done = 0; @@ -7513,11 +7305,6 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */); DEFVAR_INT ("string-chars-consed", string_chars_consed, doc: /* Number of string characters that have been consed so far. */); - DEFVAR_INT ("misc-objects-consed", misc_objects_consed, - doc: /* Number of miscellaneous objects that have been consed so far. -These include markers and overlays, plus certain objects not visible -to users. */); - DEFVAR_INT ("intervals-consed", intervals_consed, doc: /* Number of intervals that have been consed so far. */); @@ -7553,7 +7340,6 @@ do hash-consing of the objects allocated to pure space. */); DEFSYM (Qconses, "conses"); DEFSYM (Qsymbols, "symbols"); - DEFSYM (Qmiscs, "miscs"); DEFSYM (Qstrings, "strings"); DEFSYM (Qvectors, "vectors"); DEFSYM (Qfloats, "floats"); @@ -7573,6 +7359,11 @@ The time is in seconds as a floating point value. */); DEFVAR_INT ("gcs-done", gcs_done, doc: /* Accumulated number of garbage collections done. */); + DEFVAR_INT ("integer-width", integer_width, + doc: /* Maximum number of bits in bignums. +Integers outside the fixnum range are limited to absolute values less +than 2**N, where N is this variable's value. N should be nonnegative. */); + defsubr (&Scons); defsubr (&Slist); defsubr (&Svector); @@ -7589,7 +7380,6 @@ The time is in seconds as a floating point value. */); defsubr (&Smake_finalizer); defsubr (&Spurecopy); defsubr (&Sgarbage_collect); - defsubr (&Smemory_limit); defsubr (&Smemory_info); defsubr (&Smemory_use_counts); defsubr (&Ssuspicious_object); |