/* Storage allocation and gc for GNU Emacs Lisp interpreter.
-Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
+Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
Foundation, Inc.
This file is part of GNU Emacs.
#endif /* HAVE_WINDOW_SYSTEM */
#include <verify.h>
+#include <execinfo.h> /* For backtrace. */
#if (defined ENABLE_CHECKING \
&& defined HAVE_VALGRIND_VALGRIND_H \
const char *pending_malloc_warning;
+#if 0 /* Normally, pointer sanity only on request... */
+#ifdef ENABLE_CHECKING
+#define SUSPICIOUS_OBJECT_CHECKING 1
+#endif
+#endif
+
+/* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
+ bug is unresolved. */
+#define SUSPICIOUS_OBJECT_CHECKING 1
+
+#ifdef SUSPICIOUS_OBJECT_CHECKING
+struct suspicious_free_record
+{
+ void *suspicious_object;
+ void *backtrace[128];
+};
+static void *suspicious_objects[32];
+static int suspicious_object_index;
+struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
+static int suspicious_free_history_index;
+/* Find the first currently-monitored suspicious pointer in range
+ [begin,end) or NULL if no such pointer exists. */
+static void *find_suspicious_object_in_range (void *begin, void *end);
+static void detect_suspicious_free (void *ptr);
+#else
+# define find_suspicious_object_in_range(begin, end) NULL
+# define detect_suspicious_free(ptr) (void)
+#endif
+
/* Maximum amount of C stack to save when a GC happens. */
#ifndef MAX_SAVE_STACK
#if MAX_SAVE_STACK > 0
static char *stack_copy;
static ptrdiff_t stack_copy_size;
-#endif
+
+/* Copy to DEST a block of memory from SRC of size SIZE bytes,
+ avoiding any address sanitization. */
+
+static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
+no_sanitize_memcpy (void *dest, void const *src, size_t size)
+{
+ if (! ADDRESS_SANITIZER)
+ return memcpy (dest, src, size);
+ else
+ {
+ size_t i;
+ char *d = dest;
+ char const *s = src;
+ for (i = 0; i < size; i++)
+ d[i] = s[i];
+ return dest;
+ }
+}
+
+#endif /* MAX_SAVE_STACK > 0 */
static Lisp_Object Qconses;
static Lisp_Object Qsymbols;
static void *pure_alloc (size_t, int);
+/* Return X rounded to the next multiple of Y. Arguments should not
+ have side effects, as they are evaluated more than once. Assume X
+ + Y - 1 does not overflow. Tune for Y being a power of 2. */
+
+#define ROUNDUP(x, y) ((y) & ((y) - 1) \
+ ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \
+ : ((x) + (y) - 1) & ~ ((y) - 1))
-/* Value is SZ rounded up to the next multiple of ALIGNMENT.
- ALIGNMENT must be a power of 2. */
+/* Return PTR rounded up to the next multiple of ALIGNMENT. */
-#define ALIGN(ptr, ALIGNMENT) \
- ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
- & ~ ((ALIGNMENT) - 1)))
+static void *
+ALIGN (void *ptr, int alignment)
+{
+ return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
+}
static void
XFLOAT_INIT (Lisp_Object f, double n)
XFLOAT (f)->u.data = n;
}
+static bool
+pointers_fit_in_lispobj_p (void)
+{
+ return (UINTPTR_MAX <= VAL_MAX) || USE_LSB_TAG;
+}
+
+static bool
+mmap_lisp_allowed_p (void)
+{
+ /* If we can't store all memory addresses in our lisp objects, it's
+ risky to let the heap use mmap and give us addresses from all
+ over our address space. We also can't use mmap for lisp objects
+ if we might dump: unexec doesn't preserve the contents of mmaped
+ regions. */
+ return pointers_fit_in_lispobj_p () && !might_dump;
+}
+
\f
/************************************************************************
Malloc
return memcpy (xmalloc (size), SSDATA (string), size);
}
+/* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
+ pointed to. If STRING is null, assign it without copying anything.
+ Allocate before freeing, to avoid a dangling pointer if allocation
+ fails. */
+
+void
+dupstring (char **ptr, char const *string)
+{
+ char *old = *ptr;
+ *ptr = string ? xstrdup (string) : 0;
+ xfree (old);
+}
+
+
/* Like putenv, but (1) use the equivalent of xmalloc and (2) the
argument is a const pointer. */
/* The entry point is lisp_align_malloc which returns blocks of at most
BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
-#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
-#define USE_POSIX_MEMALIGN 1
+/* 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. */
+
+#if ! ADDRESS_SANITIZER
+# if !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC
+# define USE_ALIGNED_ALLOC 1
+/* Defined in gmalloc.c. */
+void *aligned_alloc (size_t, size_t);
+# elif defined HAVE_ALIGNED_ALLOC
+# define USE_ALIGNED_ALLOC 1
+# elif defined HAVE_POSIX_MEMALIGN
+# define USE_ALIGNED_ALLOC 1
+static void *
+aligned_alloc (size_t alignment, size_t size)
+{
+ void *p;
+ return posix_memalign (&p, alignment, size) == 0 ? p : 0;
+}
+# endif
#endif
/* BLOCK_ALIGN has to be a power of 2. */
malloc a chance to minimize the amount of memory wasted to alignment.
It should be tuned to the particular malloc library used.
On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
- posix_memalign on the other hand would ideally prefer a value of 4
+ aligned_alloc on the other hand would ideally prefer a value of 4
because otherwise, there's 1020 bytes wasted between each ablocks.
In Emacs, testing shows that those 1020 can most of the time be
efficiently used by malloc to place other objects, so a value of 0 can
struct ablock blocks[ABLOCKS_SIZE];
};
-/* Size of the block requested from malloc or posix_memalign. */
+/* Size of the block requested from malloc or aligned_alloc. */
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
#define ABLOCK_ABASE(block) \
#define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
/* Pointer to the (not necessarily aligned) malloc block. */
-#ifdef USE_POSIX_MEMALIGN
+#ifdef USE_ALIGNED_ALLOC
#define ABLOCKS_BASE(abase) (abase)
#else
#define ABLOCKS_BASE(abase) \
intptr_t aligned; /* int gets warning casting to 64-bit pointer. */
#ifdef DOUG_LEA_MALLOC
- /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
- because mapped region contents are not preserved in
- a dumped Emacs. */
- mallopt (M_MMAP_MAX, 0);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, 0);
#endif
-#ifdef USE_POSIX_MEMALIGN
- {
- int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
- if (err)
- base = NULL;
- abase = base;
- }
+#ifdef USE_ALIGNED_ALLOC
+ abase = base = aligned_alloc (BLOCK_ALIGN, ABLOCKS_BYTES);
#else
base = malloc (ABLOCKS_BYTES);
abase = ALIGN (base, BLOCK_ALIGN);
((void **) abase)[-1] = base;
#ifdef DOUG_LEA_MALLOC
- /* Back to a reasonable maximum of mmap'ed areas. */
- mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
#if ! USE_LSB_TAG
}
abase = ABLOCK_ABASE (free_ablock);
- ABLOCKS_BUSY (abase) =
- (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase));
+ ABLOCKS_BUSY (abase)
+ = (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase));
val = free_ablock;
free_ablock = free_ablock->x.next_free;
#define LARGE_STRING_BYTES 1024
-/* Struct or union describing string memory sub-allocated from an sblock.
- This is where the contents of Lisp strings are stored. */
-
-#ifdef GC_CHECK_STRING_BYTES
+/* The SDATA typedef is a struct or union describing string memory
+ sub-allocated from an sblock. This is where the contents of Lisp
+ strings are stored. */
-typedef struct
+struct sdata
{
/* Back-pointer to the string this sdata belongs to. If null, this
- structure is free, and the NBYTES member of the union below
+ structure is free, and NBYTES (in this structure or in the union below)
contains the string's byte size (the same value that STRING_BYTES
would return if STRING were non-null). If non-null, STRING_BYTES
(STRING) is the size of the data, and DATA contains the string's
contents. */
struct Lisp_String *string;
+#ifdef GC_CHECK_STRING_BYTES
ptrdiff_t nbytes;
+#endif
+
unsigned char data[FLEXIBLE_ARRAY_MEMBER];
-} sdata;
+};
+#ifdef GC_CHECK_STRING_BYTES
+
+typedef struct sdata sdata;
#define SDATA_NBYTES(S) (S)->nbytes
#define SDATA_DATA(S) (S)->data
-#define SDATA_SELECTOR(member) member
#else
{
struct Lisp_String *string;
- /* When STRING is non-null. */
- struct
- {
- struct Lisp_String *string;
- unsigned char data[FLEXIBLE_ARRAY_MEMBER];
- } u;
+ /* When STRING is nonnull, this union is actually of type 'struct sdata',
+ which has a flexible array member. However, if implemented by
+ giving this union a member of type 'struct sdata', the union
+ could not be the last (flexible) member of 'struct sblock',
+ because C99 prohibits a flexible array member from having a type
+ that is itself a flexible array. So, comment this member out here,
+ but remember that the option's there when using this union. */
+#if 0
+ struct sdata u;
+#endif
/* When STRING is null. */
struct
} sdata;
#define SDATA_NBYTES(S) (S)->n.nbytes
-#define SDATA_DATA(S) (S)->u.data
-#define SDATA_SELECTOR(member) u.member
+#define SDATA_DATA(S) ((struct sdata *) (S))->data
#endif /* not GC_CHECK_STRING_BYTES */
-#define SDATA_DATA_OFFSET offsetof (sdata, SDATA_SELECTOR (data))
-
+enum { SDATA_DATA_OFFSET = offsetof (struct sdata, data) };
/* Structure describing a block of memory which is sub-allocated to
obtain string data memory for strings. Blocks for small strings
of the sblock if there isn't any space left in this block. */
sdata *next_free;
- /* Start of data. */
- sdata first_data;
+ /* String data. */
+ sdata data[FLEXIBLE_ARRAY_MEMBER];
};
/* Number of Lisp strings in a string_block structure. The 1020 is
min (STRING_BYTES_BOUND,
((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD
- GC_STRING_EXTRA
- - offsetof (struct sblock, first_data)
+ - offsetof (struct sblock, data)
- SDATA_DATA_OFFSET)
& ~(sizeof (EMACS_INT) - 1)));
end = b->next_free;
- for (from = &b->first_data; from < end; from = from_end)
+ for (from = b->data; from < end; from = from_end)
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
for (b = large_sblocks; b; b = b->next)
{
- struct Lisp_String *s = b->first_data.string;
+ struct Lisp_String *s = b->data[0].string;
if (s)
string_bytes (s);
}
if (nbytes > LARGE_STRING_BYTES)
{
- size_t size = offsetof (struct sblock, first_data) + needed;
+ size_t size = offsetof (struct sblock, data) + needed;
#ifdef DOUG_LEA_MALLOC
- /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
- because mapped region contents are not preserved in
- a dumped Emacs.
-
- In case you think of allowing it in a dumped Emacs at the
- cost of not being able to re-dump, there's another reason:
- mmap'ed data typically have an address towards the top of the
- address space, which won't fit into an EMACS_INT (at least on
- 32-bit systems with the current tagging scheme). --fx */
- mallopt (M_MMAP_MAX, 0);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, 0);
#endif
b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
#ifdef DOUG_LEA_MALLOC
- /* Back to a reasonable maximum of mmap'ed areas. */
- mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
- b->next_free = &b->first_data;
- b->first_data.string = NULL;
+ b->next_free = b->data;
+ b->data[0].string = NULL;
b->next = large_sblocks;
large_sblocks = b;
}
{
/* Not enough room in the current sblock. */
b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
- b->next_free = &b->first_data;
- b->first_data.string = NULL;
+ b->next_free = b->data;
+ b->data[0].string = NULL;
b->next = NULL;
if (current_sblock)
/* Sweep and compact strings. */
+NO_INLINE /* For better stack traces */
static void
sweep_strings (void)
{
{
next = b->next;
- if (b->first_data.string == NULL)
+ if (b->data[0].string == NULL)
lisp_free (b);
else
{
to, and TB_END is the end of TB. */
tb = oldest_sblock;
tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
- to = &tb->first_data;
+ to = tb->data;
/* Step through the blocks from the oldest to the youngest. We
expect that old blocks will stabilize over time, so that less
end = b->next_free;
eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
- for (from = &b->first_data; from < end; from = from_end)
+ for (from = b->data; from < end; from = from_end)
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
tb->next_free = to;
tb = tb->next;
tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
- to = &tb->first_data;
+ to = tb->data;
to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
}
return val;
}
-verify (sizeof (size_t) * CHAR_BIT == BITS_PER_BITS_WORD);
-verify ((BITS_PER_BITS_WORD & (BITS_PER_BITS_WORD - 1)) == 0);
+/* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
+ Return A. */
-static ptrdiff_t
-bool_vector_payload_bytes (ptrdiff_t nr_bits,
- ptrdiff_t *exact_needed_bytes_out)
+Lisp_Object
+bool_vector_fill (Lisp_Object a, Lisp_Object init)
{
- ptrdiff_t exact_needed_bytes;
- ptrdiff_t needed_bytes;
-
- eassume (nr_bits >= 0);
-
- exact_needed_bytes = ROUNDUP ((size_t) nr_bits, CHAR_BIT) / CHAR_BIT;
- needed_bytes = ROUNDUP ((size_t) nr_bits, BITS_PER_BITS_WORD) / CHAR_BIT;
-
- if (needed_bytes == 0)
+ EMACS_INT nbits = bool_vector_size (a);
+ if (0 < nbits)
{
- /* Always allocate at least one machine word of payload so that
- bool-vector operations in data.c don't need a special case
- for empty vectors. */
- needed_bytes = sizeof (bits_word);
+ unsigned char *data = bool_vector_uchar_data (a);
+ int pattern = NILP (init) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR) - 1;
+ ptrdiff_t nbytes = bool_vector_bytes (nbits);
+ int last_mask = ~ (~0u << ((nbits - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1));
+ memset (data, pattern, nbytes - 1);
+ data[nbytes - 1] = pattern & last_mask;
}
+ return a;
+}
+
+/* Return a newly allocated, uninitialized bool vector of size NBITS. */
+
+Lisp_Object
+make_uninit_bool_vector (EMACS_INT nbits)
+{
+ Lisp_Object val;
+ EMACS_INT words = bool_vector_words (nbits);
+ EMACS_INT word_bytes = words * sizeof (bits_word);
+ EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes
+ + word_size - 1)
+ / word_size);
+ struct Lisp_Bool_Vector *p
+ = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements);
+ XSETVECTOR (val, p);
+ XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0);
+ p->size = nbits;
- if (exact_needed_bytes_out != NULL)
- *exact_needed_bytes_out = exact_needed_bytes;
+ /* Clear padding at the end. */
+ if (words)
+ p->data[words - 1] = 0;
- return needed_bytes;
+ return val;
}
DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
LENGTH must be a number. INIT matters only in whether it is t or nil. */)
(Lisp_Object length, Lisp_Object init)
{
- register Lisp_Object val;
- struct Lisp_Bool_Vector *p;
- ptrdiff_t exact_payload_bytes;
- ptrdiff_t total_payload_bytes;
- ptrdiff_t needed_elements;
+ Lisp_Object val;
CHECK_NATNUM (length);
- if (PTRDIFF_MAX < XFASTINT (length))
- memory_full (SIZE_MAX);
-
- total_payload_bytes = bool_vector_payload_bytes
- (XFASTINT (length), &exact_payload_bytes);
-
- eassume (exact_payload_bytes <= total_payload_bytes);
- eassume (0 <= exact_payload_bytes);
-
- needed_elements = ROUNDUP ((size_t) ((bool_header_size - header_size)
- + total_payload_bytes),
- word_size) / word_size;
-
- p = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements);
- XSETVECTOR (val, p);
- XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0);
-
- p->size = XFASTINT (length);
- if (exact_payload_bytes)
- {
- memset (p->data, ! NILP (init) ? -1 : 0, exact_payload_bytes);
+ val = make_uninit_bool_vector (XFASTINT (length));
+ return bool_vector_fill (val, init);
+}
- /* Clear any extraneous bits in the last byte. */
- p->data[exact_payload_bytes - 1]
- &= (1 << ((XFASTINT (length) - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1)) - 1;
- }
+DEFUN ("bool-vector", Fbool_vector, Sbool_vector, 0, MANY, 0,
+ doc: /* Return a new bool-vector with specified arguments as elements.
+Any number of arguments, even zero arguments, are allowed.
+usage: (bool-vector &rest OBJECTS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ ptrdiff_t i;
+ Lisp_Object vector;
- /* Clear padding at the end. */
- memset (p->data + exact_payload_bytes,
- 0,
- total_payload_bytes - exact_payload_bytes);
+ vector = make_uninit_bool_vector (nargs);
+ for (i = 0; i < nargs; i++)
+ bool_vector_set (vector, i, !NILP (args[i]));
- return val;
+ return vector;
}
-
/* Make a string from NBYTES bytes at CONTENTS, and compute the number
of characters from the contents. This string may be unibyte or
multibyte, depending on the contents. */
#define FLOAT_BLOCK_SIZE \
(((BLOCK_BYTES - sizeof (struct float_block *) \
/* The compiler might add padding at the end. */ \
- - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
+ - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
/ (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
#define GETMARKBIT(block,n) \
- (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
- >> ((n) % (sizeof (int) * CHAR_BIT))) \
+ (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
+ >> ((n) % BITS_PER_BITS_WORD)) \
& 1)
#define SETMARKBIT(block,n) \
- (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
- |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
+ ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
+ |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
#define UNSETMARKBIT(block,n) \
- (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
- &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
+ ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
+ &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
#define FLOAT_BLOCK(fptr) \
((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
{
/* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
- int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
+ bits_word gcmarkbits[1 + FLOAT_BLOCK_SIZE / BITS_PER_BITS_WORD];
struct float_block *next;
};
#define CONS_BLOCK_SIZE \
(((BLOCK_BYTES - sizeof (struct cons_block *) \
/* The compiler might add padding at the end. */ \
- - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
+ - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
/ (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
#define CONS_BLOCK(fptr) \
{
/* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
struct Lisp_Cons conses[CONS_BLOCK_SIZE];
- int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
+ bits_word gcmarkbits[1 + CONS_BLOCK_SIZE / BITS_PER_BITS_WORD];
struct cons_block *next;
};
Vector Allocation
***********************************************************************/
+/* Sometimes a vector's contents are merely a pointer internally used
+ in vector allocation code. On the rare platforms where a null
+ pointer cannot be tagged, represent it with a Lisp 0.
+ Usually you don't want to touch this. */
+
+static struct Lisp_Vector *
+next_vector (struct Lisp_Vector *v)
+{
+ return XUNTAG (v->contents[0], 0);
+}
+
+static void
+set_next_vector (struct Lisp_Vector *v, struct Lisp_Vector *p)
+{
+ v->contents[0] = make_lisp_ptr (p, 0);
+}
+
/* This value is balanced well enough to avoid too much internal overhead
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
-/* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
enum
{
- roundup_size = COMMON_MULTIPLE (word_size, USE_LSB_TAG ? GCALIGNMENT : 1)
+ /* Alignment of struct Lisp_Vector objects. */
+ vector_alignment = COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR,
+ USE_LSB_TAG ? GCALIGNMENT : 1),
+
+ /* Vector size requests are a multiple of this. */
+ roundup_size = COMMON_MULTIPLE (vector_alignment, word_size)
};
/* Verify assumptions described above. */
verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
/* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
-#define vroundup_ct(x) ROUNDUP ((size_t) (x), roundup_size)
+#define vroundup_ct(x) ROUNDUP (x, roundup_size)
/* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
#define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
eassert ((nbytes) % roundup_size == 0); \
(tmp) = VINDEX (nbytes); \
eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
- v->u.next = vector_free_lists[tmp]; \
+ set_next_vector (v, vector_free_lists[tmp]); \
vector_free_lists[tmp] = (v); \
total_free_vector_slots += (nbytes) / word_size; \
} while (0)
/* This internal type is used to maintain the list of large vectors
- which are allocated at their own, e.g. outside of vector blocks. */
+ which are allocated at their own, e.g. outside of vector blocks.
+
+ struct large_vector itself cannot contain a struct Lisp_Vector, as
+ the latter contains a flexible array member and C99 does not allow
+ such structs to be nested. Instead, each struct large_vector
+ object LV is followed by a struct Lisp_Vector, which is at offset
+ large_vector_offset from LV, and whose address is therefore
+ large_vector_vec (&LV). */
struct large_vector
{
- union {
- struct large_vector *vector;
-#if USE_LSB_TAG
- /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
- unsigned char c[vroundup_ct (sizeof (struct large_vector *))];
-#endif
- } next;
- struct Lisp_Vector v;
+ struct large_vector *next;
+};
+
+enum
+{
+ large_vector_offset = ROUNDUP (sizeof (struct large_vector), vector_alignment)
};
+static struct Lisp_Vector *
+large_vector_vec (struct large_vector *p)
+{
+ return (struct Lisp_Vector *) ((char *) p + large_vector_offset);
+}
+
/* This internal type is used to maintain an underlying storage
for small vectors. */
if (vector_free_lists[index])
{
vector = vector_free_lists[index];
- vector_free_lists[index] = vector->u.next;
+ vector_free_lists[index] = next_vector (vector);
total_free_vector_slots -= nbytes / word_size;
return vector;
}
{
/* This vector is larger than requested. */
vector = vector_free_lists[index];
- vector_free_lists[index] = vector->u.next;
+ vector_free_lists[index] = next_vector (vector);
total_free_vector_slots -= nbytes / word_size;
/* Excess bytes are used for the smaller vector,
vector_nbytes (struct Lisp_Vector *v)
{
ptrdiff_t size = v->header.size & ~ARRAY_MARK_FLAG;
+ ptrdiff_t nwords;
if (size & PSEUDOVECTOR_FLAG)
{
if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR))
{
struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) v;
- ptrdiff_t payload_bytes =
- bool_vector_payload_bytes (bv->size, NULL);
-
- eassume (payload_bytes >= 0);
- size = bool_header_size + ROUNDUP (payload_bytes, word_size);
+ ptrdiff_t word_bytes = (bool_vector_words (bv->size)
+ * sizeof (bits_word));
+ ptrdiff_t boolvec_bytes = bool_header_size + word_bytes;
+ verify (header_size <= bool_header_size);
+ nwords = (boolvec_bytes - header_size + word_size - 1) / word_size;
}
else
- size = (header_size
- + ((size & PSEUDOVECTOR_SIZE_MASK)
- + ((size & PSEUDOVECTOR_REST_MASK)
- >> PSEUDOVECTOR_SIZE_BITS)) * word_size);
+ nwords = ((size & PSEUDOVECTOR_SIZE_MASK)
+ + ((size & PSEUDOVECTOR_REST_MASK)
+ >> PSEUDOVECTOR_SIZE_BITS));
}
else
- size = header_size + size * word_size;
- return vroundup (size);
+ nwords = size;
+ return vroundup (header_size + word_size * nwords);
}
/* Release extra resources still in use by VECTOR, which may be any
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 *) vector)->driver->close ((struct font *) vector);
+ {
+ struct font_driver *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)
+ {
+ /* Attempt to catch subtle bugs like Bug#16140. */
+ eassert (valid_font_driver (drv));
+ drv->close ((struct font *) vector);
+ }
+ }
}
/* Reclaim space used by unmarked vectors. */
+NO_INLINE /* For better stack traces */
static void
sweep_vectors (void)
{
if (vector == (struct Lisp_Vector *) block->data
&& !VECTOR_IN_BLOCK (next, block))
- /* This block should be freed because all of it's
+ /* This block should be freed because all of its
space was coalesced into the only free vector. */
free_this_block = 1;
else
for (lv = large_vectors; lv; lv = *lvprev)
{
- vector = &lv->v;
+ vector = large_vector_vec (lv);
if (VECTOR_MARKED_P (vector))
{
VECTOR_UNMARK (vector);
else
total_vector_slots
+= header_size / word_size + vector->header.size;
- lvprev = &lv->next.vector;
+ lvprev = &lv->next;
}
else
{
- *lvprev = lv->next.vector;
+ *lvprev = lv->next;
lisp_free (lv);
}
}
size_t nbytes = header_size + len * word_size;
#ifdef DOUG_LEA_MALLOC
- /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
- because mapped region contents are not preserved in
- a dumped Emacs. */
- mallopt (M_MMAP_MAX, 0);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, 0);
#endif
if (nbytes <= VBLOCK_BYTES_MAX)
else
{
struct large_vector *lv
- = lisp_malloc ((offsetof (struct large_vector, v.u.contents)
+ = lisp_malloc ((large_vector_offset + header_size
+ len * word_size),
MEM_TYPE_VECTORLIKE);
- lv->next.vector = large_vectors;
+ lv->next = large_vectors;
large_vectors = lv;
- p = &lv->v;
+ p = large_vector_vec (lv);
}
#ifdef DOUG_LEA_MALLOC
- /* Back to a reasonable maximum of mmap'ed areas. */
- mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
+ if (find_suspicious_object_in_range (p, (char *) p + nbytes))
+ emacs_abort ();
+
consing_since_gc += nbytes;
vector_cells_consed += len;
}
/* Only the first lisplen slots will be traced normally by the GC. */
for (i = 0; i < lisplen; ++i)
- v->u.contents[i] = Qnil;
+ v->contents[i] = Qnil;
XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen);
return v;
p = allocate_vector (XFASTINT (length));
sizei = XFASTINT (length);
for (i = 0; i < sizei; i++)
- p->u.contents[i] = init;
+ p->contents[i] = init;
XSETVECTOR (vector, p);
return vector;
register struct Lisp_Vector *p = XVECTOR (val);
for (i = 0; i < nargs; i++)
- p->u.contents[i] = args[i];
+ p->contents[i] = args[i];
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->u.contents[1])
- && STRING_MULTIBYTE (v->u.contents[1]))
+ /* 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->u.contents[1] = Fstring_as_unibyte (v->u.contents[1]);
+ v->contents[1] = Fstring_as_unibyte (v->contents[1]);
XSETPVECTYPE (v, PVEC_COMPILED);
}
to be setcar'd). */
for (i = 0; i < nargs; i++)
- p->u.contents[i] = args[i];
+ p->contents[i] = args[i];
make_byte_code (p);
XSETCOMPILED (val, p);
return val;
static struct symbol_block *symbol_block;
static int symbol_block_index = SYMBOL_BLOCK_SIZE;
+/* Pointer to the first symbol_block that contains pinned symbols.
+ Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
+ 10K of which are pinned (and all but 250 of them are interned in obarray),
+ whereas a "typical session" has in the order of 30K symbols.
+ `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
+ than 30K to find the 10K symbols we need to mark. */
+static struct symbol_block *symbol_block_pinned;
/* List of free symbols. */
SET_SYMBOL_VAL (p, Qunbound);
set_symbol_function (val, Qnil);
set_symbol_next (val, NULL);
- p->gcmarkbit = 0;
+ p->gcmarkbit = false;
p->interned = SYMBOL_UNINTERNED;
p->constant = 0;
- p->declared_special = 0;
+ p->declared_special = false;
+ p->pinned = false;
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
total_free_symbols--;
return val;
}
-#if defined HAVE_MENUS && ! (defined USE_X_TOOLKIT || defined USE_GTK)
+#if ! (defined USE_X_TOOLKIT || defined USE_GTK)
Lisp_Object
make_save_ptr_ptr (void *a, void *b)
{
memory_full_cons_threshold = sizeof (struct cons_block);
/* The first time we get here, free the spare memory. */
- for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
+ for (i = 0; i < ARRAYELTS (spare_memory); i++)
if (spare_memory[i])
{
if (i == 0)
vector = ADVANCE (vector, vector_nbytes (vector));
}
}
- else if (m->type == MEM_TYPE_VECTORLIKE
- && (char *) p == ((char *) m->start
- + offsetof (struct large_vector, v)))
+ else if (m->type == MEM_TYPE_VECTORLIKE && p == large_vector_vec (m->start))
/* This memory node corresponds to a large vector. */
return 1;
return 0;
void dump_zombies (void) EXTERNALLY_VISIBLE;
/* Array of objects that are kept alive because the C stack contains
- a pattern that looks like a reference to them . */
+ a pattern that looks like a reference to them. */
#define MAX_ZOMBIES 10
static Lisp_Object zombies[MAX_ZOMBIES];
}
}
+/* Return true if P can point to Lisp data, and false otherwise.
+ USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
+ Otherwise, assume that Lisp data is aligned on even addresses. */
+
+static bool
+maybe_lisp_pointer (void *p)
+{
+ return !((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2));
+}
/* If P points to Lisp data, mark that as live if it isn't already
marked. */
VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
#endif
- /* Quickly rule out some values which can't point to Lisp data.
- USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
- Otherwise, assume that Lisp data is aligned on even addresses. */
- if ((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2))
+ if (!maybe_lisp_pointer (p))
return;
m = mem_find (p);
/* Mark Lisp objects referenced from the address range START+OFFSET..END
or END+OFFSET..START. */
-static void
+static void ATTRIBUTE_NO_SANITIZE_ADDRESS
mark_memory (void *start, void *end)
-#if defined (__clang__) && defined (__has_feature)
-#if __has_feature(address_sanitizer)
- /* Do not allow -faddress-sanitizer to check this function, since it
- crosses the function stack boundary, and thus would yield many
- false positives. */
- __attribute__((no_address_safety_analysis))
-#endif
-#endif
{
void **pp;
int i;
from the stack start. */
static void
-mark_stack (void)
+mark_stack (void *end)
{
- void *end;
-
-#ifdef HAVE___BUILTIN_UNWIND_INIT
- /* Force callee-saved registers and register windows onto the stack.
- This is the preferred method if available, obviating the need for
- machine dependent methods. */
- __builtin_unwind_init ();
- end = &end;
-#else /* not HAVE___BUILTIN_UNWIND_INIT */
-#ifndef GC_SAVE_REGISTERS_ON_STACK
- /* jmp_buf may not be aligned enough on darwin-ppc64 */
- union aligned_jmpbuf {
- Lisp_Object o;
- sys_jmp_buf j;
- } j;
- volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
-#endif
- /* This trick flushes the register windows so that all the state of
- the process is contained in the stack. */
- /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
- needed on ia64 too. See mach_dep.c, where it also says inline
- assembler doesn't work with relevant proprietary compilers. */
-#ifdef __sparc__
-#if defined (__sparc64__) && defined (__FreeBSD__)
- /* FreeBSD does not have a ta 3 handler. */
- asm ("flushw");
-#else
- asm ("ta 3");
-#endif
-#endif
-
- /* Save registers that we need to see on the stack. We need to see
- registers used to hold register variables and registers used to
- pass parameters. */
-#ifdef GC_SAVE_REGISTERS_ON_STACK
- GC_SAVE_REGISTERS_ON_STACK (end);
-#else /* not GC_SAVE_REGISTERS_ON_STACK */
-
-#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
- setjmp will definitely work, test it
- and print a message with the result
- of the test. */
- if (!setjmp_tested_p)
- {
- setjmp_tested_p = 1;
- test_setjmp ();
- }
-#endif /* GC_SETJMP_WORKS */
-
- sys_setjmp (j.j);
- end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
-#endif /* not GC_SAVE_REGISTERS_ON_STACK */
-#endif /* not HAVE___BUILTIN_UNWIND_INIT */
/* This assumes that the stack is a contiguous region in memory. If
that's not the case, something has to be done here to iterate
#endif
}
+/* If GC_MARK_STACK, return 1 if STR is a relocatable data of Lisp_String
+ (i.e. there is a non-pure Lisp_Object X so that SDATA (X) == STR) and 0
+ if not. Otherwise we can't rely on valid_lisp_object_p and return -1.
+ This function is slow and should be used for debugging purposes. */
+int
+relocatable_string_data_p (const char *str)
+{
+ if (PURE_POINTER_P (str))
+ return 0;
+#if GC_MARK_STACK
+ if (str)
+ {
+ struct sdata *sdata
+ = (struct sdata *) (str - offsetof (struct sdata, data));
+
+ if (valid_pointer_p (sdata)
+ && valid_pointer_p (sdata->string)
+ && maybe_lisp_pointer (sdata->string))
+ return (valid_lisp_object_p
+ (make_lisp_ptr (sdata->string, Lisp_String))
+ && (const char *) sdata->string->data == str);
+ }
+ return 0;
+#endif /* GC_MARK_STACK */
+ return -1;
+}
-\f
/***********************************************************************
Pure Storage Management
***********************************************************************/
return string;
}
+static Lisp_Object purecopy (Lisp_Object obj);
+
/* Return a cons allocated from pure space. Give it pure copies
of CAR as car and CDR as cdr. */
Lisp_Object new;
struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons);
XSETCONS (new, p);
- XSETCAR (new, Fpurecopy (car));
- XSETCDR (new, Fpurecopy (cdr));
+ XSETCAR (new, purecopy (car));
+ XSETCDR (new, purecopy (cdr));
return new;
}
{
if (NILP (Vpurify_flag))
return obj;
-
- if (PURE_POINTER_P (XPNTR (obj)))
+ else if (MARKERP (obj) || OVERLAYP (obj)
+ || HASH_TABLE_P (obj) || SYMBOLP (obj))
+ /* Can't purify those. */
return obj;
+ else
+ return purecopy (obj);
+}
+
+static Lisp_Object
+purecopy (Lisp_Object obj)
+{
+ if (PURE_POINTER_P (XPNTR (obj)) || INTEGERP (obj) || SUBRP (obj))
+ return obj; /* Already pure. */
if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
{
size &= PSEUDOVECTOR_SIZE_MASK;
vec = XVECTOR (make_pure_vector (size));
for (i = 0; i < size; i++)
- vec->u.contents[i] = Fpurecopy (AREF (obj, i));
+ vec->contents[i] = purecopy (AREF (obj, i));
if (COMPILEDP (obj))
{
XSETPVECTYPE (vec, PVEC_COMPILED);
else
XSETVECTOR (obj, vec);
}
- else if (MARKERP (obj))
- error ("Attempt to copy a marker to pure storage");
+ else if (SYMBOLP (obj))
+ {
+ if (!XSYMBOL (obj)->pinned)
+ { /* We can't purify them, but they appear in many pure objects.
+ Mark them as `pinned' so we know to mark them at every GC cycle. */
+ XSYMBOL (obj)->pinned = true;
+ symbol_block_pinned = symbol_block;
+ }
+ return obj;
+ }
else
- /* Not purified, don't hash-cons. */
- return obj;
+ {
+ Lisp_Object args[2];
+ args[0] = build_pure_c_string ("Don't know how to purify: %S");
+ args[1] = obj;
+ Fsignal (Qerror, (Fcons (Fformat (2, args), Qnil)));
+ }
if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
Fputhash (obj, obj, Vpurify_flag);
#ifdef HAVE_WINDOW_SYSTEM
+/* This code has a few issues on MS-Windows, see Bug#15876 and Bug#16140. */
+
+#if !defined (HAVE_NTGUI)
+
/* Remove unmarked font-spec and font-entity objects from ENTRY, which is
(DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
return entry;
}
+#endif /* not HAVE_NTGUI */
+
/* Compact font caches on all terminals and mark
everything which is still here after compaction. */
for (t = terminal_list; t; t = t->next_terminal)
{
Lisp_Object cache = TERMINAL_FONT_CACHE (t);
-
+#if !defined (HAVE_NTGUI)
if (CONSP (cache))
{
Lisp_Object entry;
for (entry = XCDR (cache); CONSP (entry); entry = XCDR (entry))
XSETCAR (entry, compact_font_cache_entry (XCAR (entry)));
}
+#endif /* not HAVE_NTGUI */
mark_object (cache);
}
}
return list;
}
-DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
- doc: /* Reclaim storage for Lisp objects no longer needed.
-Garbage collection happens automatically if you cons more than
-`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
-`garbage-collect' normally returns a list with info on amount of space in use,
-where each entry has the form (NAME SIZE USED FREE), where:
-- NAME is a symbol describing the kind of objects this entry represents,
-- SIZE is the number of bytes used by each one,
-- USED is the number of those objects that were found live in the heap,
-- FREE is the number of those objects that are not live but that Emacs
- keeps around for future allocations (maybe because it does not know how
- to return them to the OS).
-However, if there was overflow in pure space, `garbage-collect'
-returns nil, because real GC can't be done.
-See Info node `(elisp)Garbage Collection'. */)
- (void)
+static void
+mark_pinned_symbols (void)
+{
+ struct symbol_block *sblk;
+ int lim = (symbol_block_pinned == symbol_block
+ ? symbol_block_index : SYMBOL_BLOCK_SIZE);
+
+ for (sblk = symbol_block_pinned; sblk; sblk = sblk->next)
+ {
+ union aligned_Lisp_Symbol *sym = sblk->symbols, *end = sym + lim;
+ for (; sym < end; ++sym)
+ if (sym->s.pinned)
+ mark_object (make_lisp_ptr (&sym->s, Lisp_Symbol));
+
+ lim = SYMBOL_BLOCK_SIZE;
+ }
+}
+
+/* Subroutine of Fgarbage_collect that does most of the work. It is a
+ separate function so that we could limit mark_stack in searching
+ the stack frames below this function, thus avoiding the rare cases
+ where mark_stack finds values that look like live Lisp objects on
+ portions of stack that couldn't possibly contain such live objects.
+ For more details of this, see the discussion at
+ http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */
+static Lisp_Object
+garbage_collect_1 (void *end)
{
struct buffer *nextb;
char stack_top_variable;
stack_copy = xrealloc (stack_copy, stack_size);
stack_copy_size = stack_size;
}
- memcpy (stack_copy, stack, stack_size);
+ no_sanitize_memcpy (stack_copy, stack, stack_size);
}
}
#endif /* MAX_SAVE_STACK > 0 */
for (i = 0; i < staticidx; i++)
mark_object (*staticvec[i]);
+ mark_pinned_symbols ();
mark_specpdl ();
mark_terminals ();
mark_kboards ();
#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
|| GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
- mark_stack ();
+ mark_stack (end);
#else
{
register struct gcpro *tail;
#endif
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- mark_stack ();
+ mark_stack (end);
#endif
/* Everything is now marked, except for the data in font caches
return retval;
}
-
-/* Mark Lisp objects in glyph matrix MATRIX. Currently the
- only interesting objects referenced from glyphs are strings. */
-
-static void
-mark_glyph_matrix (struct glyph_matrix *matrix)
-{
- struct glyph_row *row = matrix->rows;
- struct glyph_row *end = row + matrix->nrows;
-
- for (; row < end; ++row)
- if (row->enabled_p)
- {
- int area;
+DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
+ doc: /* Reclaim storage for Lisp objects no longer needed.
+Garbage collection happens automatically if you cons more than
+`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
+`garbage-collect' normally returns a list with info on amount of space in use,
+where each entry has the form (NAME SIZE USED FREE), where:
+- NAME is a symbol describing the kind of objects this entry represents,
+- SIZE is the number of bytes used by each one,
+- USED is the number of those objects that were found live in the heap,
+- FREE is the number of those objects that are not live but that Emacs
+ keeps around for future allocations (maybe because it does not know how
+ to return them to the OS).
+However, if there was overflow in pure space, `garbage-collect'
+returns nil, because real GC can't be done.
+See Info node `(elisp)Garbage Collection'. */)
+ (void)
+{
+#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
+ || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS \
+ || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
+ void *end;
+
+#ifdef HAVE___BUILTIN_UNWIND_INIT
+ /* Force callee-saved registers and register windows onto the stack.
+ This is the preferred method if available, obviating the need for
+ machine dependent methods. */
+ __builtin_unwind_init ();
+ end = &end;
+#else /* not HAVE___BUILTIN_UNWIND_INIT */
+#ifndef GC_SAVE_REGISTERS_ON_STACK
+ /* jmp_buf may not be aligned enough on darwin-ppc64 */
+ union aligned_jmpbuf {
+ Lisp_Object o;
+ sys_jmp_buf j;
+ } j;
+ volatile bool stack_grows_down_p = (char *) &j > (char *) stack_base;
+#endif
+ /* This trick flushes the register windows so that all the state of
+ the process is contained in the stack. */
+ /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
+ needed on ia64 too. See mach_dep.c, where it also says inline
+ assembler doesn't work with relevant proprietary compilers. */
+#ifdef __sparc__
+#if defined (__sparc64__) && defined (__FreeBSD__)
+ /* FreeBSD does not have a ta 3 handler. */
+ asm ("flushw");
+#else
+ asm ("ta 3");
+#endif
+#endif
+
+ /* Save registers that we need to see on the stack. We need to see
+ registers used to hold register variables and registers used to
+ pass parameters. */
+#ifdef GC_SAVE_REGISTERS_ON_STACK
+ GC_SAVE_REGISTERS_ON_STACK (end);
+#else /* not GC_SAVE_REGISTERS_ON_STACK */
+
+#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
+ setjmp will definitely work, test it
+ and print a message with the result
+ of the test. */
+ if (!setjmp_tested_p)
+ {
+ setjmp_tested_p = 1;
+ test_setjmp ();
+ }
+#endif /* GC_SETJMP_WORKS */
+
+ sys_setjmp (j.j);
+ end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
+#endif /* not GC_SAVE_REGISTERS_ON_STACK */
+#endif /* not HAVE___BUILTIN_UNWIND_INIT */
+ return garbage_collect_1 (end);
+#elif (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE)
+ /* Old GCPROs-based method without stack marking. */
+ return garbage_collect_1 (NULL);
+#else
+ emacs_abort ();
+#endif /* GC_MARK_STACK */
+}
+
+/* Mark Lisp objects in glyph matrix MATRIX. Currently the
+ only interesting objects referenced from glyphs are strings. */
+
+static void
+mark_glyph_matrix (struct glyph_matrix *matrix)
+{
+ struct glyph_row *row = matrix->rows;
+ struct glyph_row *end = row + matrix->nrows;
+
+ for (; row < end; ++row)
+ if (row->enabled_p)
+ {
+ int area;
for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
{
struct glyph *glyph = row->glyphs[area];
The distinction is used e.g. by Lisp_Process which places extra
non-Lisp_Object fields at the end of the structure... */
for (i = 0; i < size; i++) /* ...and then mark its elements. */
- mark_object (ptr->u.contents[i]);
+ mark_object (ptr->contents[i]);
}
/* Like mark_vectorlike but optimized for char-tables (and
VECTOR_MARK (ptr);
for (i = 0; i < size; i++)
{
- Lisp_Object val = ptr->u.contents[i];
+ Lisp_Object val = ptr->contents[i];
if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->gcmarkbit))
continue;
}
}
+NO_INLINE /* To reduce stack depth in mark_object. */
+static Lisp_Object
+mark_compiled (struct Lisp_Vector *ptr)
+{
+ int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
+
+ VECTOR_MARK (ptr);
+ for (i = 0; i < size; i++)
+ if (i != COMPILED_CONSTANTS)
+ mark_object (ptr->contents[i]);
+ return size > COMPILED_CONSTANTS ? ptr->contents[COMPILED_CONSTANTS] : Qnil;
+}
+
/* Mark the chain of overlays starting at PTR. */
static void
/* Mark Lisp faces in the face cache C. */
+NO_INLINE /* To reduce stack depth in mark_object. */
static void
mark_face_cache (struct face_cache *c)
{
}
}
+NO_INLINE /* To reduce stack depth in mark_object. */
+static void
+mark_localized_symbol (struct Lisp_Symbol *ptr)
+{
+ struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
+ Lisp_Object where = blv->where;
+ /* If the value is set up for a killed buffer or deleted
+ frame, restore its global binding. If the value is
+ forwarded to a C variable, either it's not a Lisp_Object
+ var, or it's staticpro'd already. */
+ if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
+ || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
+ swap_in_global_binding (ptr);
+ mark_object (blv->where);
+ mark_object (blv->valcell);
+ 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 (GC_MARK_STACK && 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. */
return list;
}
-/* Determine type of generic Lisp_Object and mark it accordingly. */
+/* Determine type of generic Lisp_Object and mark it accordingly.
+
+ This function implements a straightforward depth-first marking
+ algorithm and so the recursion depth may be very high (a few
+ tens of thousands is not uncommon). To minimize stack usage,
+ a few cold paths are moved out to NO_INLINE functions above.
+ In general, inlining them doesn't help you to gain more speed. */
void
mark_object (Lisp_Object arg)
break;
case PVEC_COMPILED:
- { /* We could treat this just like a vector, but it is better
- to save the COMPILED_CONSTANTS element for last and avoid
- recursion there. */
- int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
- int i;
-
- VECTOR_MARK (ptr);
- for (i = 0; i < size; i++)
- if (i != COMPILED_CONSTANTS)
- mark_object (ptr->u.contents[i]);
- if (size > COMPILED_CONSTANTS)
- {
- obj = ptr->u.contents[COMPILED_CONSTANTS];
- goto loop;
- }
- }
+ /* Although we could treat this just like a vector, mark_compiled
+ returns the COMPILED_CONSTANTS element, which is marked at the
+ next iteration of goto-loop here. This is done to avoid a few
+ recursive calls to mark_object. */
+ obj = mark_compiled (ptr);
+ if (!NILP (obj))
+ goto loop;
break;
case PVEC_FRAME:
case Lisp_Symbol:
{
register struct Lisp_Symbol *ptr = XSYMBOL (obj);
- struct Lisp_Symbol *ptrx;
-
+ nextsym:
if (ptr->gcmarkbit)
break;
CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
ptr->gcmarkbit = 1;
+ /* Attempt to catch bogus objects. */
+ eassert (valid_lisp_object_p (ptr->function) >= 1);
mark_object (ptr->function);
mark_object (ptr->plist);
switch (ptr->redirect)
break;
}
case SYMBOL_LOCALIZED:
- {
- struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
- Lisp_Object where = blv->where;
- /* If the value is set up for a killed buffer or deleted
- frame, restore it's global binding. If the value is
- forwarded to a C variable, either it's not a Lisp_Object
- var, or it's staticpro'd already. */
- if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
- || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
- swap_in_global_binding (ptr);
- mark_object (blv->where);
- mark_object (blv->valcell);
- mark_object (blv->defcell);
- break;
- }
+ mark_localized_symbol (ptr);
+ break;
case SYMBOL_FORWARDED:
/* If the value is forwarded to a buffer or keyboard field,
these are marked when we see the corresponding object.
if (!PURE_POINTER_P (XSTRING (ptr->name)))
MARK_STRING (XSTRING (ptr->name));
MARK_INTERVAL_TREE (string_intervals (ptr->name));
-
+ /* Inner loop to mark next symbol in this bucket, if any. */
ptr = ptr->next;
if (ptr)
- {
- ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun. */
- XSETSYMBOL (obj, ptrx);
- goto loop;
- }
+ goto nextsym;
}
break;
case Lisp_Misc_Save_Value:
XMISCANY (obj)->gcmarkbit = 1;
- {
- struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
- /* If `save_type' is zero, `data[0].pointer' is the address
- of a memory area containing `data[1].integer' potential
- Lisp_Objects. */
- if (GC_MARK_STACK && 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);
- }
- }
+ mark_save_value (XSAVE_VALUE (obj));
break;
case Lisp_Misc_Overlay:
\f
-/* Sweep: find all structures not marked, and free them. */
+NO_INLINE /* For better stack traces */
static void
-gc_sweep (void)
+sweep_conses (void)
{
- /* Remove or mark entries in weak hash tables.
- This must be done before any object is unmarked. */
- sweep_weak_hash_tables ();
-
- sweep_strings ();
- check_string_bytes (!noninteractive);
+ struct cons_block *cblk;
+ struct cons_block **cprev = &cons_block;
+ int lim = cons_block_index;
+ EMACS_INT num_free = 0, num_used = 0;
- /* Put all unmarked conses on free list */
- {
- register struct cons_block *cblk;
- struct cons_block **cprev = &cons_block;
- register int lim = cons_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+ cons_free_list = 0;
- cons_free_list = 0;
-
- for (cblk = cons_block; cblk; cblk = *cprev)
- {
- register int i = 0;
- int this_free = 0;
- int ilim = (lim + BITS_PER_INT - 1) / BITS_PER_INT;
+ for (cblk = cons_block; cblk; cblk = *cprev)
+ {
+ int i = 0;
+ int this_free = 0;
+ int ilim = (lim + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD;
- /* Scan the mark bits an int at a time. */
- for (i = 0; i < ilim; i++)
- {
- if (cblk->gcmarkbits[i] == -1)
- {
- /* Fast path - all cons cells for this int are marked. */
- cblk->gcmarkbits[i] = 0;
- num_used += BITS_PER_INT;
- }
- else
- {
- /* Some cons cells for this int are not marked.
- Find which ones, and free them. */
- int start, pos, stop;
-
- start = i * BITS_PER_INT;
- stop = lim - start;
- if (stop > BITS_PER_INT)
- stop = BITS_PER_INT;
- stop += start;
-
- for (pos = start; pos < stop; pos++)
- {
- if (!CONS_MARKED_P (&cblk->conses[pos]))
- {
- this_free++;
- cblk->conses[pos].u.chain = cons_free_list;
- cons_free_list = &cblk->conses[pos];
+ /* Scan the mark bits an int at a time. */
+ for (i = 0; i < ilim; i++)
+ {
+ if (cblk->gcmarkbits[i] == BITS_WORD_MAX)
+ {
+ /* Fast path - all cons cells for this int are marked. */
+ cblk->gcmarkbits[i] = 0;
+ num_used += BITS_PER_BITS_WORD;
+ }
+ else
+ {
+ /* Some cons cells for this int are not marked.
+ Find which ones, and free them. */
+ int start, pos, stop;
+
+ start = i * BITS_PER_BITS_WORD;
+ stop = lim - start;
+ if (stop > BITS_PER_BITS_WORD)
+ stop = BITS_PER_BITS_WORD;
+ stop += start;
+
+ for (pos = start; pos < stop; pos++)
+ {
+ if (!CONS_MARKED_P (&cblk->conses[pos]))
+ {
+ this_free++;
+ cblk->conses[pos].u.chain = cons_free_list;
+ cons_free_list = &cblk->conses[pos];
#if GC_MARK_STACK
- cons_free_list->car = Vdead;
+ cons_free_list->car = Vdead;
#endif
- }
- else
- {
- num_used++;
- CONS_UNMARK (&cblk->conses[pos]);
- }
- }
- }
- }
+ }
+ else
+ {
+ num_used++;
+ CONS_UNMARK (&cblk->conses[pos]);
+ }
+ }
+ }
+ }
- lim = CONS_BLOCK_SIZE;
- /* If this block contains only free conses and we have already
- seen more than two blocks worth of free conses then deallocate
- this block. */
- if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
- {
- *cprev = cblk->next;
- /* Unhook from the free list. */
- cons_free_list = cblk->conses[0].u.chain;
- lisp_align_free (cblk);
- }
- else
- {
- num_free += this_free;
- cprev = &cblk->next;
- }
- }
- total_conses = num_used;
- total_free_conses = num_free;
- }
+ lim = CONS_BLOCK_SIZE;
+ /* If this block contains only free conses and we have already
+ seen more than two blocks worth of free conses then deallocate
+ this block. */
+ if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
+ {
+ *cprev = cblk->next;
+ /* Unhook from the free list. */
+ cons_free_list = cblk->conses[0].u.chain;
+ lisp_align_free (cblk);
+ }
+ else
+ {
+ num_free += this_free;
+ cprev = &cblk->next;
+ }
+ }
+ total_conses = num_used;
+ total_free_conses = num_free;
+}
- /* Put all unmarked floats on free list */
- {
- register struct float_block *fblk;
- struct float_block **fprev = &float_block;
- register int lim = float_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+NO_INLINE /* For better stack traces */
+static void
+sweep_floats (void)
+{
+ register struct float_block *fblk;
+ struct float_block **fprev = &float_block;
+ register int lim = float_block_index;
+ EMACS_INT num_free = 0, num_used = 0;
- float_free_list = 0;
+ float_free_list = 0;
- for (fblk = float_block; fblk; fblk = *fprev)
- {
- 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]);
- }
- 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
- this block. */
- if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
- {
- *fprev = fblk->next;
- /* Unhook from the free list. */
- float_free_list = fblk->floats[0].u.chain;
- lisp_align_free (fblk);
- }
- else
- {
- num_free += this_free;
- fprev = &fblk->next;
- }
- }
- total_floats = num_used;
- total_free_floats = num_free;
- }
+ for (fblk = float_block; fblk; fblk = *fprev)
+ {
+ 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]);
+ }
+ 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
+ this block. */
+ if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
+ {
+ *fprev = fblk->next;
+ /* Unhook from the free list. */
+ float_free_list = fblk->floats[0].u.chain;
+ lisp_align_free (fblk);
+ }
+ else
+ {
+ num_free += this_free;
+ fprev = &fblk->next;
+ }
+ }
+ total_floats = num_used;
+ total_free_floats = num_free;
+}
- /* Put all unmarked intervals on free list */
- {
- register struct interval_block *iblk;
- struct interval_block **iprev = &interval_block;
- register int lim = interval_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+NO_INLINE /* For better stack traces */
+static void
+sweep_intervals (void)
+{
+ register struct interval_block *iblk;
+ struct interval_block **iprev = &interval_block;
+ register int lim = interval_block_index;
+ EMACS_INT num_free = 0, num_used = 0;
- interval_free_list = 0;
+ interval_free_list = 0;
- for (iblk = interval_block; iblk; iblk = *iprev)
- {
- register int i;
- int this_free = 0;
+ for (iblk = interval_block; iblk; iblk = *iprev)
+ {
+ register int i;
+ int this_free = 0;
- for (i = 0; i < lim; i++)
- {
- if (!iblk->intervals[i].gcmarkbit)
- {
- set_interval_parent (&iblk->intervals[i], interval_free_list);
- interval_free_list = &iblk->intervals[i];
- this_free++;
- }
- else
- {
- num_used++;
- iblk->intervals[i].gcmarkbit = 0;
- }
- }
- lim = INTERVAL_BLOCK_SIZE;
- /* If this block contains only free intervals and we have already
- seen more than two blocks worth of free intervals then
- deallocate this block. */
- if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
- {
- *iprev = iblk->next;
- /* Unhook from the free list. */
- interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
- lisp_free (iblk);
- }
- else
- {
- num_free += this_free;
- iprev = &iblk->next;
- }
- }
- total_intervals = num_used;
- total_free_intervals = num_free;
- }
+ for (i = 0; i < lim; i++)
+ {
+ if (!iblk->intervals[i].gcmarkbit)
+ {
+ set_interval_parent (&iblk->intervals[i], interval_free_list);
+ interval_free_list = &iblk->intervals[i];
+ this_free++;
+ }
+ else
+ {
+ num_used++;
+ iblk->intervals[i].gcmarkbit = 0;
+ }
+ }
+ lim = INTERVAL_BLOCK_SIZE;
+ /* If this block contains only free intervals and we have already
+ seen more than two blocks worth of free intervals then
+ deallocate this block. */
+ if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
+ {
+ *iprev = iblk->next;
+ /* Unhook from the free list. */
+ interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
+ lisp_free (iblk);
+ }
+ else
+ {
+ num_free += this_free;
+ iprev = &iblk->next;
+ }
+ }
+ total_intervals = num_used;
+ total_free_intervals = num_free;
+}
- /* Put all unmarked symbols on free list */
- {
- register struct symbol_block *sblk;
- struct symbol_block **sprev = &symbol_block;
- register int lim = symbol_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+NO_INLINE /* For better stack traces */
+static void
+sweep_symbols (void)
+{
+ register struct symbol_block *sblk;
+ struct symbol_block **sprev = &symbol_block;
+ register int lim = symbol_block_index;
+ EMACS_INT num_free = 0, num_used = 0;
- symbol_free_list = NULL;
+ symbol_free_list = NULL;
- for (sblk = symbol_block; sblk; sblk = *sprev)
- {
- int this_free = 0;
- union aligned_Lisp_Symbol *sym = sblk->symbols;
- union aligned_Lisp_Symbol *end = sym + lim;
+ for (sblk = symbol_block; sblk; sblk = *sprev)
+ {
+ int this_free = 0;
+ union aligned_Lisp_Symbol *sym = sblk->symbols;
+ union aligned_Lisp_Symbol *end = sym + lim;
- for (; sym < end; ++sym)
- {
- /* Check if the symbol was created during loadup. In such a case
- it might be pointed to by pure bytecode which we don't trace,
- so we conservatively assume that it is live. */
- bool pure_p = PURE_POINTER_P (XSTRING (sym->s.name));
-
- if (!sym->s.gcmarkbit && !pure_p)
- {
- if (sym->s.redirect == SYMBOL_LOCALIZED)
- xfree (SYMBOL_BLV (&sym->s));
- sym->s.next = symbol_free_list;
- symbol_free_list = &sym->s;
+ for (; sym < end; ++sym)
+ {
+ if (!sym->s.gcmarkbit)
+ {
+ if (sym->s.redirect == SYMBOL_LOCALIZED)
+ xfree (SYMBOL_BLV (&sym->s));
+ sym->s.next = symbol_free_list;
+ symbol_free_list = &sym->s;
#if GC_MARK_STACK
- symbol_free_list->function = Vdead;
+ symbol_free_list->function = Vdead;
#endif
- ++this_free;
- }
- else
- {
- ++num_used;
- if (!pure_p)
- UNMARK_STRING (XSTRING (sym->s.name));
- sym->s.gcmarkbit = 0;
- }
- }
+ ++this_free;
+ }
+ else
+ {
+ ++num_used;
+ sym->s.gcmarkbit = 0;
+ /* Attempt to catch bogus objects. */
+ eassert (valid_lisp_object_p (sym->s.function) >= 1);
+ }
+ }
- lim = SYMBOL_BLOCK_SIZE;
- /* If this block contains only free symbols and we have already
- seen more than two blocks worth of free symbols then deallocate
- this block. */
- if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
- {
- *sprev = sblk->next;
- /* Unhook from the free list. */
- symbol_free_list = sblk->symbols[0].s.next;
- lisp_free (sblk);
- }
- else
- {
- num_free += this_free;
- sprev = &sblk->next;
- }
- }
- total_symbols = num_used;
- total_free_symbols = num_free;
- }
+ lim = SYMBOL_BLOCK_SIZE;
+ /* If this block contains only free symbols and we have already
+ seen more than two blocks worth of free symbols then deallocate
+ this block. */
+ if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
+ {
+ *sprev = sblk->next;
+ /* Unhook from the free list. */
+ symbol_free_list = sblk->symbols[0].s.next;
+ lisp_free (sblk);
+ }
+ else
+ {
+ num_free += this_free;
+ sprev = &sblk->next;
+ }
+ }
+ total_symbols = num_used;
+ total_free_symbols = num_free;
+}
- /* Put all unmarked misc's on free list.
- For a marker, first unchain it from the buffer it points into. */
- {
- 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;
+NO_INLINE /* For better stack traces */
+static void
+sweep_misc (void)
+{
+ 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;
- marker_free_list = 0;
+ /* Put all unmarked misc's on free list. For a marker, first
+ unchain it from the buffer it points into. */
- for (mblk = marker_block; mblk; mblk = *mprev)
- {
- register int i;
- int this_free = 0;
+ marker_free_list = 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);
- /* 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;
- }
- }
+ for (mblk = marker_block; mblk; mblk = *mprev)
+ {
+ register int i;
+ int this_free = 0;
- total_markers = num_used;
- total_free_markers = num_free;
- }
+ 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);
+ /* 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;
+ }
+ }
- /* Free all unmarked buffers */
- {
- register struct buffer *buffer, **bprev = &all_buffers;
+ total_markers = num_used;
+ total_free_markers = num_free;
+}
- total_buffers = 0;
- for (buffer = all_buffers; buffer; buffer = *bprev)
- if (!VECTOR_MARKED_P (buffer))
- {
- *bprev = buffer->next;
- lisp_free (buffer);
- }
- else
- {
- VECTOR_UNMARK (buffer);
- /* Do not use buffer_(set|get)_intervals here. */
- buffer->text->intervals = balance_intervals (buffer->text->intervals);
- total_buffers++;
- bprev = &buffer->next;
- }
- }
+NO_INLINE /* For better stack traces */
+static void
+sweep_buffers (void)
+{
+ register struct buffer *buffer, **bprev = &all_buffers;
- sweep_vectors ();
- check_string_bytes (!noninteractive);
+ total_buffers = 0;
+ for (buffer = all_buffers; buffer; buffer = *bprev)
+ if (!VECTOR_MARKED_P (buffer))
+ {
+ *bprev = buffer->next;
+ lisp_free (buffer);
+ }
+ else
+ {
+ VECTOR_UNMARK (buffer);
+ /* Do not use buffer_(set|get)_intervals here. */
+ buffer->text->intervals = balance_intervals (buffer->text->intervals);
+ total_buffers++;
+ bprev = &buffer->next;
+ }
}
+/* Sweep: find all structures not marked, and free them. */
+static void
+gc_sweep (void)
+{
+ /* Remove or mark entries in weak hash tables.
+ This must be done before any object is unmarked. */
+ sweep_weak_hash_tables ();
+ sweep_strings ();
+ check_string_bytes (!noninteractive);
+ sweep_conses ();
+ sweep_floats ();
+ sweep_intervals ();
+ sweep_symbols ();
+ sweep_misc ();
+ sweep_buffers ();
+ sweep_vectors ();
+ check_string_bytes (!noninteractive);
+}
\f
/* Debugging aids. */
{
Lisp_Object end;
+#ifdef HAVE_NS
+ /* 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;
}
return found;
}
+#ifdef SUSPICIOUS_OBJECT_CHECKING
+
+static void *
+find_suspicious_object_in_range (void *begin, void *end)
+{
+ char *begin_a = begin;
+ char *end_a = end;
+ int i;
+
+ for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
+ {
+ char *suspicious_object = suspicious_objects[i];
+ if (begin_a <= suspicious_object && suspicious_object < end_a)
+ return suspicious_object;
+ }
+
+ return NULL;
+}
+
+static void
+note_suspicious_free (void* ptr)
+{
+ struct suspicious_free_record* rec;
+
+ rec = &suspicious_free_history[suspicious_free_history_index++];
+ if (suspicious_free_history_index ==
+ ARRAYELTS (suspicious_free_history))
+ {
+ suspicious_free_history_index = 0;
+ }
+
+ memset (rec, 0, sizeof (*rec));
+ rec->suspicious_object = ptr;
+ backtrace (&rec->backtrace[0], ARRAYELTS (rec->backtrace));
+}
+
+static void
+detect_suspicious_free (void* ptr)
+{
+ int i;
+
+ eassert (ptr != NULL);
+
+ for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
+ if (suspicious_objects[i] == ptr)
+ {
+ note_suspicious_free (ptr);
+ suspicious_objects[i] = NULL;
+ }
+}
+
+#endif /* SUSPICIOUS_OBJECT_CHECKING */
+
+DEFUN ("suspicious-object", Fsuspicious_object, Ssuspicious_object, 1, 1, 0,
+ doc: /* Return OBJ, maybe marking it for extra scrutiny.
+If Emacs is compiled with suspicous object checking, capture
+a stack trace when OBJ is freed in order to help track down
+garbage collection bugs. Otherwise, do nothing and return OBJ. */)
+ (Lisp_Object obj)
+{
+#ifdef SUSPICIOUS_OBJECT_CHECKING
+ /* Right now, we care only about vectors. */
+ if (VECTORLIKEP (obj))
+ {
+ suspicious_objects[suspicious_object_index++] = XVECTOR (obj);
+ if (suspicious_object_index == ARRAYELTS (suspicious_objects))
+ suspicious_object_index = 0;
+ }
+#endif
+ return obj;
+}
+
#ifdef ENABLE_CHECKING
bool suppress_checking;
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);
+ defsubr (&Sbool_vector);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
defsubr (&Sgarbage_collect);
defsubr (&Smemory_limit);
defsubr (&Smemory_use_counts);
+ defsubr (&Ssuspicious_object);
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
defsubr (&Sgc_status);
enum char_bits char_bits;
enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE;
enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE;
- enum enum_USE_LSB_TAG enum_USE_LSB_TAG;
- enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE;
enum Lisp_Bits Lisp_Bits;
enum Lisp_Compiled Lisp_Compiled;
enum maxargs maxargs;
HCoop / bpt / emacs.git / blobdiff