/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
- Free Software Foundation, Inc.
+
+Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
+ Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <setjmp.h>
#include <verify.h>
+/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
+ Doable only if GC_MARK_STACK. */
+#if ! GC_MARK_STACK
+# undef GC_CHECK_MARKED_OBJECTS
+#endif
+
/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
- memory. Can do this only if using gmalloc.c. */
+ memory. Can do this only if using gmalloc.c and if not checking
+ marked objects. */
-#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
+#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
+ || defined GC_CHECK_MARKED_OBJECTS)
#undef GC_MALLOC_CHECK
#endif
#include <unistd.h>
#ifndef HAVE_UNISTD_H
-extern POINTER_TYPE *sbrk ();
+extern void *sbrk ();
#endif
#include <fcntl.h>
extern size_t _bytes_used;
extern size_t __malloc_extra_blocks;
+extern void *_malloc_internal (size_t);
+extern void _free_internal (void *);
#endif /* not DOUG_LEA_MALLOC */
remapping on more recent systems because this is less important
nowadays than in the days of small memories and timesharing. */
-#ifndef VIRT_ADDR_VARIES
-static
-#endif
EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
#define PUREBEG (char *) pure
/* Value is non-zero if P points into pure space. */
#define PURE_POINTER_P(P) \
- (((PNTR_COMPARISON_TYPE) (P) \
- < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
- && ((PNTR_COMPARISON_TYPE) (P) \
- >= (PNTR_COMPARISON_TYPE) purebeg))
+ ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
/* Index in pure at which next pure Lisp object will be allocated.. */
static void mark_buffer (Lisp_Object);
static void mark_terminals (void);
static void gc_sweep (void);
+static Lisp_Object make_pure_vector (ptrdiff_t);
static void mark_glyph_matrix (struct glyph_matrix *);
static void mark_face_cache (struct face_cache *);
static void free_large_strings (void);
static void sweep_strings (void);
static void free_misc (Lisp_Object);
+extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
/* When scanning the C stack for live Lisp objects, Emacs keeps track
of what memory allocated via lisp_malloc is intended for what
process, hash_table, frame, terminal, and window, but we never made
use of the distinction, so it only caused source-code complexity
and runtime slowdown. Minor but pointless. */
- MEM_TYPE_VECTORLIKE
+ MEM_TYPE_VECTORLIKE,
+ /* Special type to denote vector blocks. */
+ MEM_TYPE_VECTOR_BLOCK
};
-static POINTER_TYPE *lisp_align_malloc (size_t, enum mem_type);
-static POINTER_TYPE *lisp_malloc (size_t, enum mem_type);
+static void *lisp_malloc (size_t, enum mem_type);
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
on free lists recognizable in O(1). */
static Lisp_Object Vdead;
+#define DEADP(x) EQ (x, Vdead)
#ifdef GC_MALLOC_CHECK
enum mem_type allocated_mem_type;
-static int dont_register_blocks;
#endif /* GC_MALLOC_CHECK */
#define MEM_NIL &mem_z
static struct Lisp_Vector *allocate_vectorlike (ptrdiff_t);
-static void lisp_free (POINTER_TYPE *);
+static void lisp_free (void *);
static void mark_stack (void);
static int live_vector_p (struct mem_node *, void *);
static int live_buffer_p (struct mem_node *, void *);
static int live_float_p (struct mem_node *, void *);
static int live_misc_p (struct mem_node *, void *);
static void mark_maybe_object (Lisp_Object);
-static void mark_memory (void *, void *, int);
+static void mark_memory (void *, void *);
+#if GC_MARK_STACK || defined GC_MALLOC_CHECK
static void mem_init (void);
static struct mem_node *mem_insert (void *, void *, enum mem_type);
static void mem_insert_fixup (struct mem_node *);
+#endif
static void mem_rotate_left (struct mem_node *);
static void mem_rotate_right (struct mem_node *);
static void mem_delete (struct mem_node *);
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
+#ifndef DEADP
+# define DEADP(x) 0
+#endif
+
/* Recording what needs to be marked for gc. */
struct gcpro *gcprolist;
static int staticidx = 0;
-static POINTER_TYPE *pure_alloc (size_t, int);
+static void *pure_alloc (size_t, int);
/* Value is SZ rounded up to the next multiple of ALIGNMENT.
ALIGNMENT must be a power of 2. */
#define ALIGN(ptr, ALIGNMENT) \
- ((POINTER_TYPE *) ((((uintptr_t) (ptr)) + (ALIGNMENT) - 1) \
- & ~((ALIGNMENT) - 1)))
+ ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
+ & ~ ((ALIGNMENT) - 1)))
\f
xsignal (Qnil, Vmemory_signal_data);
}
+/* A common multiple of the positive integers A and B. Ideally this
+ would be the least common multiple, but there's no way to do that
+ as a constant expression in C, so do the best that we can easily do. */
+#define COMMON_MULTIPLE(a, b) \
+ ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
#ifndef XMALLOC_OVERRUN_CHECK
#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
char c; \
}, \
c)
+
#ifdef USE_LSB_TAG
-/* A common multiple of the positive integers A and B. Ideally this
- would be the least common multiple, but there's no way to do that
- as a constant expression in C, so do the best that we can easily do. */
-# define COMMON_MULTIPLE(a, b) \
- ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
# define XMALLOC_HEADER_ALIGNMENT \
COMMON_MULTIPLE (1 << GCTYPEBITS, XMALLOC_BASE_ALIGNMENT)
#else
/* Like malloc, but wraps allocated block with header and trailer. */
-static POINTER_TYPE *
+static void *
overrun_check_malloc (size_t size)
{
register unsigned char *val;
XMALLOC_OVERRUN_CHECK_SIZE);
}
--check_depth;
- return (POINTER_TYPE *)val;
+ return val;
}
/* Like realloc, but checks old block for overrun, and wraps new block
with header and trailer. */
-static POINTER_TYPE *
-overrun_check_realloc (POINTER_TYPE *block, size_t size)
+static void *
+overrun_check_realloc (void *block, size_t size)
{
register unsigned char *val = (unsigned char *) block;
int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0;
memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
}
- val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
+ val = realloc (val, size + overhead);
if (val && check_depth == 1)
{
XMALLOC_OVERRUN_CHECK_SIZE);
}
--check_depth;
- return (POINTER_TYPE *)val;
+ return val;
}
/* Like free, but checks block for overrun. */
static void
-overrun_check_free (POINTER_TYPE *block)
+overrun_check_free (void *block)
{
unsigned char *val = (unsigned char *) block;
/* Like malloc but check for no memory and block interrupt input.. */
-POINTER_TYPE *
+void *
xmalloc (size_t size)
{
- register POINTER_TYPE *val;
+ void *val;
MALLOC_BLOCK_INPUT;
- val = (POINTER_TYPE *) malloc (size);
+ val = malloc (size);
MALLOC_UNBLOCK_INPUT;
if (!val && size)
/* Like realloc but check for no memory and block interrupt input.. */
-POINTER_TYPE *
-xrealloc (POINTER_TYPE *block, size_t size)
+void *
+xrealloc (void *block, size_t size)
{
- register POINTER_TYPE *val;
+ void *val;
MALLOC_BLOCK_INPUT;
/* We must call malloc explicitly when BLOCK is 0, since some
reallocs don't do this. */
if (! block)
- val = (POINTER_TYPE *) malloc (size);
+ val = malloc (size);
else
- val = (POINTER_TYPE *) realloc (block, size);
+ val = realloc (block, size);
MALLOC_UNBLOCK_INPUT;
if (!val && size)
/* Like free but block interrupt input. */
void
-xfree (POINTER_TYPE *block)
+xfree (void *block)
{
if (!block)
return;
/* Like malloc but used for allocating Lisp data. NBYTES is the
number of bytes to allocate, TYPE describes the intended use of the
- allcated memory block (for strings, for conses, ...). */
+ allocated memory block (for strings, for conses, ...). */
#ifndef USE_LSB_TAG
static void *lisp_malloc_loser;
#endif
-static POINTER_TYPE *
+static void *
lisp_malloc (size_t nbytes, enum mem_type type)
{
register void *val;
call to lisp_malloc. */
static void
-lisp_free (POINTER_TYPE *block)
+lisp_free (void *block)
{
MALLOC_BLOCK_INPUT;
free (block);
MALLOC_UNBLOCK_INPUT;
}
-/* Allocation of aligned blocks of memory to store Lisp data. */
-/* 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. */
+/***** Allocation of aligned blocks of memory to store Lisp data. *****/
+
+/* 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. */
-/* Use posix_memalloc if the system has it and we're using the system's
- malloc (because our gmalloc.c routines don't have posix_memalign although
- its memalloc could be used). */
#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
#define USE_POSIX_MEMALIGN 1
#endif
struct ablock blocks[ABLOCKS_SIZE];
};
-/* Size of the block requested from malloc or memalign. */
+/* Size of the block requested from malloc or posix_memalign. */
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
#define ABLOCK_ABASE(block) \
/* Allocate an aligned block of nbytes.
Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
smaller or equal to BLOCK_BYTES. */
-static POINTER_TYPE *
+static void *
lisp_align_malloc (size_t nbytes, enum mem_type type)
{
void *base, *val;
#endif
/* Initialize the blocks and put them on the free list.
- Is `base' was not properly aligned, we can't use the last block. */
+ If `base' was not properly aligned, we can't use the last block. */
for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
{
abase->blocks[i].abase = abase;
}
static void
-lisp_align_free (POINTER_TYPE *block)
+lisp_align_free (void *block)
{
struct ablock *ablock = block;
struct ablocks *abase = ABLOCK_ABASE (ablock);
ablock->x.next_free = free_ablock;
free_ablock = ablock;
/* Update busy count. */
- ABLOCKS_BUSY (abase) =
- (struct ablocks *) (-2 + (intptr_t) ABLOCKS_BUSY (abase));
+ ABLOCKS_BUSY (abase)
+ = (struct ablocks *) (-2 + (intptr_t) ABLOCKS_BUSY (abase));
if (2 > (intptr_t) ABLOCKS_BUSY (abase))
{ /* All the blocks are free. */
# define BYTES_USED _bytes_used
#endif
+#ifdef GC_MALLOC_CHECK
+static int dont_register_blocks;
+#endif
+
static size_t bytes_used_when_reconsidered;
/* Value of _bytes_used, when spare_memory was freed. */
{
fprintf (stderr, "Malloc returned %p which is already in use\n",
value);
- fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n",
+ fprintf (stderr, "Region in use is %p...%p, %td bytes, type %d\n",
m->start, m->end, (char *) m->end - (char *) m->start,
m->type);
abort ();
#ifdef DOUG_LEA_MALLOC
pthread_mutexattr_t attr;
- /* GLIBC has a faster way to do this, but lets keep it portable.
+ /* GLIBC has a faster way to do this, but let's keep it portable.
This is according to the Single UNIX Specification. */
pthread_mutexattr_init (&attr);
pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
}
#endif
\f
+/* Convert the pointer-sized word P to EMACS_INT while preserving its
+ type and ptr fields. */
+static Lisp_Object
+widen_to_Lisp_Object (void *p)
+{
+ intptr_t i = (intptr_t) p;
+#ifdef USE_LISP_UNION_TYPE
+ Lisp_Object obj;
+ obj.i = i;
+ return obj;
+#else
+ return i;
+#endif
+}
+\f
/***********************************************************************
String Allocation
***********************************************************************/
GC are put on a free list to be reallocated before allocating
any new cons cells from the latest cons_block. */
-#define CONS_BLOCK_SIZE \
- (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
+#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) * CHAR_BIT + 1))
#define CONS_BLOCK(fptr) \
Vector Allocation
***********************************************************************/
-/* Singly-linked list of all vectors. */
+/* 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). */
-static struct Lisp_Vector *all_vectors;
+#define VECTOR_BLOCK_SIZE 4096
/* Handy constants for vectorlike objects. */
enum
{
header_size = offsetof (struct Lisp_Vector, contents),
- word_size = sizeof (Lisp_Object)
+ word_size = sizeof (Lisp_Object),
+ roundup_size = COMMON_MULTIPLE (sizeof (Lisp_Object),
+#ifdef USE_LSB_TAG
+ 8 /* Helps to maintain alignment constraints imposed by
+ assumption that least 3 bits of pointers are always 0. */
+#else
+ 1 /* If alignment doesn't matter, should round up
+ to sizeof (Lisp_Object) at least. */
+#endif
+ )
};
+/* Round up X to nearest mult-of-ROUNDUP_SIZE,
+ assuming ROUNDUP_SIZE is a power of 2. */
+
+#define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
+
+/* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
+
+#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
+
+/* Size of the minimal vector allocated from block. */
+
+#define VBLOCK_BYTES_MIN vroundup (sizeof (struct Lisp_Vector))
+
+/* Size of the largest vector allocated from block. */
+
+#define VBLOCK_BYTES_MAX \
+ vroundup ((VECTOR_BLOCK_BYTES / 2) - sizeof (Lisp_Object))
+
+/* 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)
+
+/* When the vector is on a free list, vectorlike_header.SIZE is set to
+ this special value ORed with vector's memory footprint size. */
+
+#define VECTOR_FREE_LIST_FLAG (~(ARRAY_MARK_FLAG | PSEUDOVECTOR_FLAG \
+ | (VECTOR_BLOCK_SIZE - 1)))
+
+/* Common shortcut to advance vector pointer over a block data. */
+
+#define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
+
+/* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
+
+#define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
+
+/* Common shortcut to setup vector on a free list. */
+
+#define SETUP_ON_FREE_LIST(v, nbytes, index) \
+ do { \
+ (v)->header.size = VECTOR_FREE_LIST_FLAG | (nbytes); \
+ eassert ((nbytes) % roundup_size == 0); \
+ (index) = VINDEX (nbytes); \
+ eassert ((index) < VECTOR_MAX_FREE_LIST_INDEX); \
+ (v)->header.next.vector = vector_free_lists[index]; \
+ vector_free_lists[index] = (v); \
+ } while (0)
+
+struct vector_block
+{
+ char data[VECTOR_BLOCK_BYTES];
+ struct vector_block *next;
+};
+
+/* Chain of vector blocks. */
+
+static struct vector_block *vector_blocks;
+
+/* Vector free lists, where NTH item points to a chain of free
+ vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
+
+static struct Lisp_Vector *vector_free_lists[VECTOR_MAX_FREE_LIST_INDEX];
+
+/* Singly-linked list of large vectors. */
+
+static struct Lisp_Vector *large_vectors;
+
+/* The only vector with 0 slots, allocated from pure space. */
+
+static struct Lisp_Vector *zero_vector;
+
+/* Get a new vector block. */
+
+static struct vector_block *
+allocate_vector_block (void)
+{
+ struct vector_block *block;
+
+#ifdef DOUG_LEA_MALLOC
+ mallopt (M_MMAP_MAX, 0);
+#endif
+
+ block = xmalloc (sizeof (struct vector_block));
+
+#ifdef DOUG_LEA_MALLOC
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+#endif
+
+#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+ mem_insert (block->data, block->data + VECTOR_BLOCK_BYTES,
+ MEM_TYPE_VECTOR_BLOCK);
+#endif
+
+ block->next = vector_blocks;
+ vector_blocks = block;
+ return block;
+}
+
+/* Called once to initialize vector allocation. */
+
+static void
+init_vectors (void)
+{
+ zero_vector = pure_alloc (header_size, Lisp_Vectorlike);
+ zero_vector->header.size = 0;
+}
+
+/* Allocate vector from a vector block. */
+
+static struct Lisp_Vector *
+allocate_vector_from_block (size_t nbytes)
+{
+ struct Lisp_Vector *vector, *rest;
+ struct vector_block *block;
+ size_t index, restbytes;
+
+ eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
+ eassert (nbytes % roundup_size == 0);
+
+ /* First, try to allocate from a free list
+ containing vectors of the requested size. */
+ index = VINDEX (nbytes);
+ if (vector_free_lists[index])
+ {
+ vector = vector_free_lists[index];
+ vector_free_lists[index] = vector->header.next.vector;
+ vector->header.next.nbytes = nbytes;
+ return vector;
+ }
+
+ /* Next, check free lists containing larger vectors. Since
+ we will split the result, we should have remaining space
+ large enough to use for one-slot vector at least. */
+ for (index = VINDEX (nbytes + VBLOCK_BYTES_MIN);
+ index < VECTOR_MAX_FREE_LIST_INDEX; index++)
+ if (vector_free_lists[index])
+ {
+ /* This vector is larger than requested. */
+ vector = vector_free_lists[index];
+ vector_free_lists[index] = vector->header.next.vector;
+ vector->header.next.nbytes = nbytes;
+
+ /* Excess bytes are used for the smaller vector,
+ which should be set on an appropriate free list. */
+ restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes;
+ eassert (restbytes % roundup_size == 0);
+ rest = ADVANCE (vector, nbytes);
+ SETUP_ON_FREE_LIST (rest, restbytes, index);
+ return vector;
+ }
+
+ /* Finally, need a new vector block. */
+ block = allocate_vector_block ();
+
+ /* New vector will be at the beginning of this block. */
+ vector = (struct Lisp_Vector *) block->data;
+ vector->header.next.nbytes = nbytes;
+
+ /* If the rest of space from this block is large enough
+ for one-slot vector at least, set up it on a free list. */
+ restbytes = VECTOR_BLOCK_BYTES - nbytes;
+ if (restbytes >= VBLOCK_BYTES_MIN)
+ {
+ eassert (restbytes % roundup_size == 0);
+ rest = ADVANCE (vector, nbytes);
+ SETUP_ON_FREE_LIST (rest, restbytes, index);
+ }
+ return vector;
+ }
+
+/* Return how many Lisp_Objects can be stored in V. */
+
+#define VECTOR_SIZE(v) ((v)->header.size & PSEUDOVECTOR_FLAG ? \
+ (PSEUDOVECTOR_SIZE_MASK & (v)->header.size) : \
+ (v)->header.size)
+
+/* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
+
+#define VECTOR_IN_BLOCK(vector, block) \
+ ((char *) (vector) <= (block)->data \
+ + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
+
+/* Reclaim space used by unmarked vectors. */
+
+static void
+sweep_vectors (void)
+{
+ struct vector_block *block = vector_blocks, **bprev = &vector_blocks;
+ struct Lisp_Vector *vector, *next, **vprev = &large_vectors;
+
+ total_vector_size = 0;
+ memset (vector_free_lists, 0, sizeof (vector_free_lists));
+
+ /* Looking through vector blocks. */
+
+ for (block = vector_blocks; block; block = *bprev)
+ {
+ int free_this_block = 0;
+
+ for (vector = (struct Lisp_Vector *) block->data;
+ VECTOR_IN_BLOCK (vector, block); vector = next)
+ {
+ if (VECTOR_MARKED_P (vector))
+ {
+ VECTOR_UNMARK (vector);
+ total_vector_size += VECTOR_SIZE (vector);
+ next = ADVANCE (vector, vector->header.next.nbytes);
+ }
+ else
+ {
+ ptrdiff_t nbytes;
+
+ if ((vector->header.size & VECTOR_FREE_LIST_FLAG)
+ == VECTOR_FREE_LIST_FLAG)
+ vector->header.next.nbytes =
+ vector->header.size & (VECTOR_BLOCK_SIZE - 1);
+
+ next = ADVANCE (vector, vector->header.next.nbytes);
+
+ /* While NEXT is not marked, try to coalesce with VECTOR,
+ thus making VECTOR of the largest possible size. */
+
+ while (VECTOR_IN_BLOCK (next, block))
+ {
+ if (VECTOR_MARKED_P (next))
+ break;
+ if ((next->header.size & VECTOR_FREE_LIST_FLAG)
+ == VECTOR_FREE_LIST_FLAG)
+ nbytes = next->header.size & (VECTOR_BLOCK_SIZE - 1);
+ else
+ nbytes = next->header.next.nbytes;
+ vector->header.next.nbytes += nbytes;
+ next = ADVANCE (next, nbytes);
+ }
+
+ eassert (vector->header.next.nbytes % roundup_size == 0);
+
+ if (vector == (struct Lisp_Vector *) block->data
+ && !VECTOR_IN_BLOCK (next, block))
+ /* This block should be freed because all of it's
+ space was coalesced into the only free vector. */
+ free_this_block = 1;
+ else
+ SETUP_ON_FREE_LIST (vector, vector->header.next.nbytes, nbytes);
+ }
+ }
+
+ if (free_this_block)
+ {
+ *bprev = block->next;
+#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+ mem_delete (mem_find (block->data));
+#endif
+ xfree (block);
+ }
+ else
+ bprev = &block->next;
+ }
+
+ /* Sweep large vectors. */
+
+ for (vector = large_vectors; vector; vector = *vprev)
+ {
+ if (VECTOR_MARKED_P (vector))
+ {
+ VECTOR_UNMARK (vector);
+ total_vector_size += VECTOR_SIZE (vector);
+ vprev = &vector->header.next.vector;
+ }
+ else
+ {
+ *vprev = vector->header.next.vector;
+ lisp_free (vector);
+ }
+ }
+}
+
/* Value is a pointer to a newly allocated Lisp_Vector structure
with room for LEN Lisp_Objects. */
/* This gets triggered by code which I haven't bothered to fix. --Stef */
/* eassert (!handling_signal); */
+ if (len == 0)
+ return zero_vector;
+
nbytes = header_size + len * word_size;
- p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
+
+ if (nbytes <= VBLOCK_BYTES_MAX)
+ p = allocate_vector_from_block (vroundup (nbytes));
+ else
+ {
+ p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
+ p->header.next.vector = large_vectors;
+ large_vectors = p;
+ }
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
consing_since_gc += nbytes;
vector_cells_consed += len;
- p->header.next.vector = all_vectors;
- all_vectors = p;
-
MALLOC_UNBLOCK_INPUT;
return p;
Symbol Allocation
***********************************************************************/
+/* Like struct Lisp_Symbol, but padded so that the size is a multiple
+ of the required alignment if LSB tags are used. */
+
+union aligned_Lisp_Symbol
+{
+ struct Lisp_Symbol s;
+#ifdef USE_LSB_TAG
+ unsigned char c[(sizeof (struct Lisp_Symbol) + (1 << GCTYPEBITS) - 1)
+ & -(1 << GCTYPEBITS)];
+#endif
+};
+
/* Each symbol_block is just under 1020 bytes long, since malloc
really allocates in units of powers of two and uses 4 bytes for its
own overhead. */
#define SYMBOL_BLOCK_SIZE \
- ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
+ ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
struct symbol_block
{
/* Place `symbols' first, to preserve alignment. */
- struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
+ union aligned_Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
struct symbol_block *next;
};
symbol_block = new;
symbol_block_index = 0;
}
- XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
+ XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index].s);
symbol_block_index++;
}
Marker (Misc) Allocation
***********************************************************************/
+/* Like union Lisp_Misc, but padded so that its size is a multiple of
+ the required alignment when LSB tags are used. */
+
+union aligned_Lisp_Misc
+{
+ union Lisp_Misc m;
+#ifdef USE_LSB_TAG
+ unsigned char c[(sizeof (union Lisp_Misc) + (1 << GCTYPEBITS) - 1)
+ & -(1 << GCTYPEBITS)];
+#endif
+};
+
/* 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 Lisp_Misc))
+ ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
struct marker_block
{
/* Place `markers' first, to preserve alignment. */
- union Lisp_Misc markers[MARKER_BLOCK_SIZE];
+ union aligned_Lisp_Misc markers[MARKER_BLOCK_SIZE];
struct marker_block *next;
};
marker_block_index = 0;
total_free_markers += MARKER_BLOCK_SIZE;
}
- XSETMISC (val, &marker_block->markers[marker_block_index]);
+ XSETMISC (val, &marker_block->markers[marker_block_index].m);
marker_block_index++;
}
static inline int
live_vector_p (struct mem_node *m, void *p)
{
- return (p == m->start && m->type == MEM_TYPE_VECTORLIKE);
+ if (m->type == MEM_TYPE_VECTOR_BLOCK)
+ {
+ /* This memory node corresponds to a vector block. */
+ struct vector_block *block = (struct vector_block *) m->start;
+ struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
+
+ /* P is in the block's allocation range. Scan the block
+ up to P and see whether P points to the start of some
+ vector which is not on a free list. FIXME: check whether
+ some allocation patterns (probably a lot of short vectors)
+ may cause a substantial overhead of this loop. */
+ while (VECTOR_IN_BLOCK (vector, block)
+ && vector <= (struct Lisp_Vector *) p)
+ {
+ if ((vector->header.size & VECTOR_FREE_LIST_FLAG)
+ == VECTOR_FREE_LIST_FLAG)
+ vector = ADVANCE (vector, (vector->header.size
+ & (VECTOR_BLOCK_SIZE - 1)));
+ else if (vector == p)
+ return 1;
+ else
+ vector = ADVANCE (vector, vector->header.next.nbytes);
+ }
+ }
+ else if (m->type == MEM_TYPE_VECTORLIKE && p == m->start)
+ /* This memory node corresponds to a large vector. */
+ return 1;
+ return 0;
}
{
Lisp_Object args[8], zombie_list = Qnil;
EMACS_INT i;
- for (i = 0; i < nzombies; i++)
+ for (i = 0; i < min (MAX_ZOMBIES, nzombies); i++)
zombie_list = Fcons (zombies[i], zombie_list);
args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
args[1] = make_number (ngcs);
break;
case MEM_TYPE_VECTORLIKE:
+ case MEM_TYPE_VECTOR_BLOCK:
if (live_vector_p (m, p))
{
Lisp_Object tem;
}
+/* Alignment of pointer values. Use offsetof, as it sometimes returns
+ a smaller alignment than GCC's __alignof__ and mark_memory might
+ miss objects if __alignof__ were used. */
+#define GC_POINTER_ALIGNMENT offsetof (struct {char a; void *b;}, b)
+
+/* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
+ not suffice, which is the typical case. A host where a Lisp_Object is
+ wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
+ If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
+ suffice to widen it to to a Lisp_Object and check it that way. */
+#if defined USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
+# if !defined USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
+ /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
+ nor mark_maybe_object can follow the pointers. This should not occur on
+ any practical porting target. */
+# error "MSB type bits straddle pointer-word boundaries"
+# endif
+ /* Marking via C pointers does not suffice, because Lisp_Objects contain
+ pointer words that hold pointers ORed with type bits. */
+# define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
+#else
+ /* Marking via C pointers suffices, because Lisp_Objects contain pointer
+ words that hold unmodified pointers. */
+# define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
+#endif
+
/* Mark Lisp objects referenced from the address range START+OFFSET..END
or END+OFFSET..START. */
static void
-mark_memory (void *start, void *end, int offset)
+mark_memory (void *start, void *end)
{
- Lisp_Object *p;
void **pp;
+ int i;
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
nzombies = 0;
end = tem;
}
- /* Mark Lisp_Objects. */
- for (p = (Lisp_Object *) ((char *) start + offset); (void *) p < end; ++p)
- mark_maybe_object (*p);
-
/* Mark Lisp data pointed to. This is necessary because, in some
situations, the C compiler optimizes Lisp objects away, so that
only a pointer to them remains. Example:
away. The only reference to the life string is through the
pointer `s'. */
- for (pp = (void **) ((char *) start + offset); (void *) pp < end; ++pp)
- mark_maybe_pointer (*pp);
+ for (pp = start; (void *) pp < end; pp++)
+ for (i = 0; i < sizeof *pp; i += GC_POINTER_ALIGNMENT)
+ {
+ void *p = *(void **) ((char *) pp + i);
+ mark_maybe_pointer (p);
+ if (POINTERS_MIGHT_HIDE_IN_OBJECTS)
+ mark_maybe_object (widen_to_Lisp_Object (p));
+ }
}
/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
{
int i;
- fprintf (stderr, "\nZombies kept alive = %"pI":\n", nzombies);
+ fprintf (stderr, "\nZombies kept alive = %"pI"d:\n", nzombies);
for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
{
fprintf (stderr, " %d = ", i);
pass starting at the start of the stack + 2. Likewise, if the
minimal alignment of Lisp_Objects on the stack is 1, four passes
would be necessary, each one starting with one byte more offset
- from the stack start.
-
- The current code assumes by default that Lisp_Objects are aligned
- equally on the stack. */
+ from the stack start. */
static void
mark_stack (void)
{
- int i;
void *end;
#ifdef 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
over the stack segments. */
-#ifndef GC_LISP_OBJECT_ALIGNMENT
-#ifdef __GNUC__
-#define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
-#else
-#define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
-#endif
-#endif
- for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
- mark_memory (stack_base, end, i);
+ mark_memory (stack_base, end);
+
/* Allow for marking a secondary stack, like the register stack on the
ia64. */
#ifdef GC_MARK_SECONDARY_STACK
return live_float_p (m, p);
case MEM_TYPE_VECTORLIKE:
+ case MEM_TYPE_VECTOR_BLOCK:
return live_vector_p (m, p);
default:
pointer to it. TYPE is the Lisp type for which the memory is
allocated. TYPE < 0 means it's not used for a Lisp object. */
-static POINTER_TYPE *
+static void *
pure_alloc (size_t size, int type)
{
- POINTER_TYPE *result;
+ void *result;
#ifdef USE_LSB_TAG
size_t alignment = (1 << GCTYPEBITS);
#else
/* Return a vector with room for LEN Lisp_Objects allocated from
pure space. */
-Lisp_Object
+static Lisp_Object
make_pure_vector (ptrdiff_t len)
{
Lisp_Object new;
`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:
((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
- (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
+ (USED-MISCS . FREE-MISCS) USED-STRING-CHARS USED-VECTOR-SLOTS
(USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
(USED-STRINGS . FREE-STRINGS))
However, if there was overflow in pure space, `garbage-collect'
-returns nil, because real GC can't be done. */)
+returns nil, because real GC can't be done.
+See Info node `(elisp)Garbage Collection'. */)
(void)
{
register struct specbinding *bind;
}
/* Mark the Lisp pointers in the terminal objects.
- Called by the Fgarbage_collector. */
+ Called by Fgarbage_collect. */
static void
mark_terminals (void)
for (sblk = symbol_block; sblk; sblk = *sprev)
{
int this_free = 0;
- struct Lisp_Symbol *sym = sblk->symbols;
- struct Lisp_Symbol *end = sym + lim;
+ 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. */
- int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
+ int pure_p = PURE_POINTER_P (XSTRING (sym->s.xname));
- if (!sym->gcmarkbit && !pure_p)
+ if (!sym->s.gcmarkbit && !pure_p)
{
- if (sym->redirect == SYMBOL_LOCALIZED)
- xfree (SYMBOL_BLV (sym));
- sym->next = symbol_free_list;
- symbol_free_list = sym;
+ 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;
#endif
{
++num_used;
if (!pure_p)
- UNMARK_STRING (XSTRING (sym->xname));
- sym->gcmarkbit = 0;
+ UNMARK_STRING (XSTRING (sym->s.xname));
+ sym->s.gcmarkbit = 0;
}
}
{
*sprev = sblk->next;
/* Unhook from the free list. */
- symbol_free_list = sblk->symbols[0].next;
+ symbol_free_list = sblk->symbols[0].s.next;
lisp_free (sblk);
}
else
for (i = 0; i < lim; i++)
{
- if (!mblk->markers[i].u_any.gcmarkbit)
+ if (!mblk->markers[i].m.u_any.gcmarkbit)
{
- if (mblk->markers[i].u_any.type == Lisp_Misc_Marker)
- unchain_marker (&mblk->markers[i].u_marker);
+ 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].u_marker.type = Lisp_Misc_Free;
- mblk->markers[i].u_free.chain = marker_free_list;
- marker_free_list = &mblk->markers[i];
+ 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].u_any.gcmarkbit = 0;
+ mblk->markers[i].m.u_any.gcmarkbit = 0;
}
}
lim = MARKER_BLOCK_SIZE;
{
*mprev = mblk->next;
/* Unhook from the free list. */
- marker_free_list = mblk->markers[0].u_free.chain;
+ marker_free_list = mblk->markers[0].m.u_free.chain;
lisp_free (mblk);
}
else
}
}
- /* Free all unmarked vectors */
- {
- register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
- total_vector_size = 0;
-
- while (vector)
- if (!VECTOR_MARKED_P (vector))
- {
- if (prev)
- prev->header.next = vector->header.next;
- else
- all_vectors = vector->header.next.vector;
- next = vector->header.next.vector;
- lisp_free (vector);
- vector = next;
-
- }
- else
- {
- VECTOR_UNMARK (vector);
- if (vector->header.size & PSEUDOVECTOR_FLAG)
- total_vector_size += PSEUDOVECTOR_SIZE_MASK & vector->header.size;
- else
- total_vector_size += vector->header.size;
- prev = vector, vector = vector->header.next.vector;
- }
- }
+ sweep_vectors ();
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive)
return Flist (8, consed);
}
+/* Find at most FIND_MAX symbols which have OBJ as their value or
+ function. This is used in gdbinit's `xwhichsymbols' command. */
+
+Lisp_Object
+which_symbols (Lisp_Object obj, EMACS_INT find_max)
+{
+ struct symbol_block *sblk;
+ ptrdiff_t gc_count = inhibit_garbage_collection ();
+ Lisp_Object found = Qnil;
+
+ if (! DEADP (obj))
+ {
+ for (sblk = symbol_block; sblk; sblk = sblk->next)
+ {
+ union aligned_Lisp_Symbol *aligned_sym = sblk->symbols;
+ int bn;
+
+ for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, aligned_sym++)
+ {
+ struct Lisp_Symbol *sym = &aligned_sym->s;
+ Lisp_Object val;
+ Lisp_Object tem;
+
+ if (sblk == symbol_block && bn >= symbol_block_index)
+ break;
+
+ XSETSYMBOL (tem, sym);
+ val = find_symbol_value (tem);
+ if (EQ (val, obj)
+ || EQ (sym->function, obj)
+ || (!NILP (sym->function)
+ && COMPILEDP (sym->function)
+ && EQ (AREF (sym->function, COMPILED_BYTECODE), obj))
+ || (!NILP (val)
+ && COMPILEDP (val)
+ && EQ (AREF (val, COMPILED_BYTECODE), obj)))
+ {
+ found = Fcons (tem, found);
+ if (--find_max == 0)
+ goto out;
+ }
+ }
+ }
+ }
+
+ out:
+ unbind_to (gc_count, Qnil);
+ return found;
+}
+
#ifdef ENABLE_CHECKING
int suppress_checking;
Vdead = make_pure_string ("DEAD", 4, 4, 0);
#endif
- all_vectors = 0;
ignore_warnings = 1;
#ifdef DOUG_LEA_MALLOC
mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
init_marker ();
init_float ();
init_intervals ();
+ init_vectors ();
init_weak_hash_tables ();
#ifdef REL_ALLOC
syms_of_alloc (void)
{
DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
- doc: /* *Number of bytes of consing between garbage collections.
+ doc: /* Number of bytes of consing between garbage collections.
Garbage collection can happen automatically once this many bytes have been
allocated since the last garbage collection. All data types count.
See also `gc-cons-percentage'. */);
DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage,
- doc: /* *Portion of the heap used for allocation.
+ doc: /* Portion of the heap used for allocation.
Garbage collection can happen automatically once this portion of the heap
has been allocated since the last garbage collection.
If this portion is smaller than `gc-cons-threshold', this is ignored. */);
Vgc_cons_percentage = make_float (0.1);
DEFVAR_INT ("pure-bytes-used", pure_bytes_used,
- doc: /* Number of bytes of sharable Lisp data allocated so far. */);
+ doc: /* Number of bytes of shareable Lisp data allocated so far. */);
DEFVAR_INT ("cons-cells-consed", cons_cells_consed,
doc: /* Number of cons cells that have been consed so far. */);
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. */);
+ 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. */);