/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001, 2002
+ Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001, 2002, 2003
Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <config.h>
#include <stdio.h>
+#include <limits.h> /* For CHAR_BIT. */
+
+#ifdef ALLOC_DEBUG
+#undef INLINE
+#endif
/* Note that this declares bzero on OSF/1. How dumb. */
#endif /* not DOUG_LEA_MALLOC */
-/* Macro to verify that storage intended for Lisp objects is not
- out of range to fit in the space for a pointer.
- ADDRESS is the start of the block, and SIZE
- is the amount of space within which objects can start. */
-
-#define VALIDATE_LISP_STORAGE(address, size) \
-do \
- { \
- Lisp_Object val; \
- XSETCONS (val, (char *) address + size); \
- if ((char *) XCONS (val) != (char *) address + size) \
- { \
- xfree (address); \
- memory_full (); \
- } \
- } while (0)
-
/* Value of _bytes_used, when spare_memory was freed. */
static __malloc_size_t bytes_used_when_full;
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
-#define MARK_STRING(S) ((S)->size |= MARKBIT)
-#define UNMARK_STRING(S) ((S)->size &= ~MARKBIT)
-#define STRING_MARKED_P(S) ((S)->size & MARKBIT)
+#define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
+#define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
+#define STRING_MARKED_P(S) ((S)->size & ARRAY_MARK_FLAG)
+
+#define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
+#define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
+#define VECTOR_MARKED_P(V) ((V)->size & ARRAY_MARK_FLAG)
/* Value is the number of bytes/chars of S, a pointer to a struct
Lisp_String. This must be used instead of STRING_BYTES (S) or
S->size during GC, because S->size contains the mark bit for
strings. */
-#define GC_STRING_BYTES(S) (STRING_BYTES (S) & ~MARKBIT)
-#define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
+#define GC_STRING_BYTES(S) (STRING_BYTES (S))
+#define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
/* Number of bytes of consing done since the last gc. */
/* Count the amount of consing of various sorts of space. */
-int cons_cells_consed;
-int floats_consed;
-int vector_cells_consed;
-int symbols_consed;
-int string_chars_consed;
-int misc_objects_consed;
-int intervals_consed;
-int strings_consed;
+EMACS_INT cons_cells_consed;
+EMACS_INT floats_consed;
+EMACS_INT vector_cells_consed;
+EMACS_INT symbols_consed;
+EMACS_INT string_chars_consed;
+EMACS_INT misc_objects_consed;
+EMACS_INT intervals_consed;
+EMACS_INT strings_consed;
/* Number of bytes of consing since GC before another GC should be done. */
-int gc_cons_threshold;
+EMACS_INT gc_cons_threshold;
/* Nonzero during GC. */
int gc_in_progress;
+/* Nonzero means abort if try to GC.
+ This is for code which is written on the assumption that
+ no GC will happen, so as to verify that assumption. */
+
+int abort_on_gc;
+
/* Nonzero means display messages at beginning and end of GC. */
int garbage_collection_messages;
/* Two limits controlling how much undo information to keep. */
-int undo_limit;
-int undo_strong_limit;
+EMACS_INT undo_limit;
+EMACS_INT undo_strong_limit;
/* Number of live and free conses etc. */
Lisp_Object Vpurify_flag;
+/* Non-nil means we are handling a memory-full error. */
+
+Lisp_Object Vmemory_full;
+
#ifndef HAVE_SHM
-/* Force it into data space! */
+/* Force it into data space! Initialize it to a nonzero value;
+ otherwise some compilers put it into BSS. */
-EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {0,};
+EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {1,};
#define PUREBEG (char *) pure
#else /* HAVE_SHM */
/* Index in pure at which next pure object will be allocated.. */
-int pure_bytes_used;
+EMACS_INT pure_bytes_used;
/* If nonzero, this is a warning delivered by malloc and not yet
displayed. */
/* Pre-computed signal argument for use when memory is exhausted. */
-Lisp_Object memory_signal_data;
+Lisp_Object Vmemory_signal_data;
/* Maximum amount of C stack to save when a GC happens. */
Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
+Lisp_Object Vgc_elapsed; /* accumulated elapsed time in GC */
+EMACS_INT gcs_done; /* accumulated GCs */
+
static void mark_buffer P_ ((Lisp_Object));
-static void mark_kboards P_ ((void));
+extern void mark_kboards P_ ((void));
static void gc_sweep P_ ((void));
static void mark_glyph_matrix P_ ((struct glyph_matrix *));
static void mark_face_cache P_ ((struct face_cache *));
struct mem_node
{
- struct mem_node *left, *right, *parent;
+ /* Children of this node. These pointers are never NULL. When there
+ is no child, the value is MEM_NIL, which points to a dummy node. */
+ struct mem_node *left, *right;
+
+ /* The parent of this node. In the root node, this is NULL. */
+ struct mem_node *parent;
/* Start and end of allocated region. */
void *start, *end;
/* Node color. */
enum {MEM_BLACK, MEM_RED} color;
-
+
/* Memory type. */
enum mem_type type;
};
struct gcpro *gcprolist;
-/* Addresses of staticpro'd variables. */
+/* Addresses of staticpro'd variables. Initialize it to a nonzero
+ value; otherwise some compilers put it into BSS. */
#define NSTATICS 1280
-Lisp_Object *staticvec[NSTATICS] = {0};
+Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
/* Index of next unused slot in staticvec. */
/* Value is SZ rounded up to the next multiple of ALIGNMENT.
ALIGNMENT must be a power of 2. */
-#define ALIGN(SZ, ALIGNMENT) \
- (((SZ) + (ALIGNMENT) - 1) & ~((ALIGNMENT) - 1))
+#define ALIGN(ptr, ALIGNMENT) \
+ ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
+ & ~((ALIGNMENT) - 1)))
\f
Malloc
************************************************************************/
-/* Write STR to Vstandard_output plus some advice on how to free some
- memory. Called when memory gets low. */
-
-Lisp_Object
-malloc_warning_1 (str)
- Lisp_Object str;
-{
- Fprinc (str, Vstandard_output);
- write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
- write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
- write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
- return Qnil;
-}
-
-
-/* Function malloc calls this if it finds we are near exhausting
- storage. */
+/* Function malloc calls this if it finds we are near exhausting storage. */
void
malloc_warning (str)
}
-/* Display a malloc warning in buffer *Danger*. */
+/* Display an already-pending malloc warning. */
void
display_malloc_warning ()
{
- register Lisp_Object val;
-
- val = build_string (pending_malloc_warning);
+ call3 (intern ("display-warning"),
+ intern ("alloc"),
+ build_string (pending_malloc_warning),
+ intern ("emergency"));
pending_malloc_warning = 0;
- internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val);
}
void
memory_full ()
{
+ Vmemory_full = Qt;
+
#ifndef SYSTEM_MALLOC
bytes_used_when_full = BYTES_USED;
#endif
/* This used to call error, but if we've run out of memory, we could
get infinite recursion trying to build the string. */
while (1)
- Fsignal (Qnil, memory_signal_data);
+ Fsignal (Qnil, Vmemory_signal_data);
}
memory_full ();
#endif
+ Vmemory_full = Qt;
+
/* This used to call error, but if we've run out of memory, we could
get infinite recursion trying to build the string. */
while (1)
- Fsignal (Qerror, memory_signal_data);
+ Fsignal (Qnil, Vmemory_signal_data);
}
char *
xstrdup (s)
- char *s;
+ const char *s;
{
size_t len = strlen (s) + 1;
char *p = (char *) xmalloc (len);
number of bytes to allocate, TYPE describes the intended use of the
allcated memory block (for strings, for conses, ...). */
+static void *lisp_malloc_loser;
+
static POINTER_TYPE *
lisp_malloc (nbytes, type)
size_t nbytes;
#ifdef GC_MALLOC_CHECK
allocated_mem_type = type;
#endif
-
+
val = (void *) malloc (nbytes);
+ /* If the memory just allocated cannot be addressed thru a Lisp
+ object's pointer, and it needs to be,
+ that's equivalent to running out of memory. */
+ if (val && type != MEM_TYPE_NON_LISP)
+ {
+ Lisp_Object tem;
+ XSETCONS (tem, (char *) val + nbytes - 1);
+ if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
+ {
+ lisp_malloc_loser = val;
+ free (val);
+ val = 0;
+ }
+ }
+
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
if (val && type != MEM_TYPE_NON_LISP)
mem_insert (val, (char *) val + nbytes, type);
#endif
-
+
UNBLOCK_INPUT;
if (!val && nbytes)
memory_full ();
return val;
}
+/* Free BLOCK. This must be called to free memory allocated with a
+ call to lisp_malloc. */
-/* Return a new buffer structure allocated from the heap with
- a call to lisp_malloc. */
-
-struct buffer *
-allocate_buffer ()
+static void
+lisp_free (block)
+ POINTER_TYPE *block;
{
- struct buffer *b
- = (struct buffer *) lisp_malloc (sizeof (struct buffer),
- MEM_TYPE_BUFFER);
- VALIDATE_LISP_STORAGE (b, sizeof *b);
- return b;
+ BLOCK_INPUT;
+ free (block);
+#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+ mem_delete (mem_find (block));
+#endif
+ 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. */
-/* Free BLOCK. This must be called to free memory allocated with a
- call to lisp_malloc. */
+
+/* BLOCK_ALIGN has to be a power of 2. */
+#define BLOCK_ALIGN (1 << 10)
+
+/* Padding to leave at the end of a malloc'd block. This is to give
+ 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
+ because otherwise, there's 1020 bytes wasted between each ablocks.
+ But testing shows that those 1020 will most of the time be efficiently
+ used by malloc to place other objects, so a value of 0 is still preferable
+ unless you have a lot of cons&floats and virtually nothing else. */
+#define BLOCK_PADDING 0
+#define BLOCK_BYTES \
+ (BLOCK_ALIGN - sizeof (struct aligned_block *) - BLOCK_PADDING)
+
+/* Internal data structures and constants. */
+
+#define ABLOCKS_SIZE 16
+
+/* An aligned block of memory. */
+struct ablock
+{
+ union
+ {
+ char payload[BLOCK_BYTES];
+ struct ablock *next_free;
+ } x;
+ /* `abase' is the aligned base of the ablocks. */
+ /* It is overloaded to hold the virtual `busy' field that counts
+ the number of used ablock in the parent ablocks.
+ The first ablock has the `busy' field, the others have the `abase'
+ field. To tell the difference, we assume that pointers will have
+ integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
+ is used to tell whether the real base of the parent ablocks is `abase'
+ (if not, the word before the first ablock holds a pointer to the
+ real base). */
+ struct ablocks *abase;
+ /* The padding of all but the last ablock is unused. The padding of
+ the last ablock in an ablocks is not allocated. */
+#if BLOCK_PADDING
+ char padding[BLOCK_PADDING];
+#endif
+};
+
+/* A bunch of consecutive aligned blocks. */
+struct ablocks
+{
+ struct ablock blocks[ABLOCKS_SIZE];
+};
+
+/* Size of the block requested from malloc or memalign. */
+#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
+
+#define ABLOCK_ABASE(block) \
+ (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
+ ? (struct ablocks *)(block) \
+ : (block)->abase)
+
+/* Virtual `busy' field. */
+#define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
+
+/* Pointer to the (not necessarily aligned) malloc block. */
+#ifdef HAVE_POSIX_MEMALIGN
+#define ABLOCKS_BASE(abase) (abase)
+#else
+#define ABLOCKS_BASE(abase) \
+ (1 & (int) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
+#endif
+
+/* The list of free ablock. */
+static struct ablock *free_ablock;
+
+/* 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 *
+lisp_align_malloc (nbytes, type)
+ size_t nbytes;
+ enum mem_type type;
+{
+ void *base, *val;
+ struct ablocks *abase;
+
+ eassert (nbytes <= BLOCK_BYTES);
+
+ BLOCK_INPUT;
+
+#ifdef GC_MALLOC_CHECK
+ allocated_mem_type = type;
+#endif
+
+ if (!free_ablock)
+ {
+ int i, aligned;
+
+#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);
+#endif
+
+#ifdef HAVE_POSIX_MEMALIGN
+ {
+ int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
+ abase = err ? (base = NULL) : base;
+ }
+#else
+ base = malloc (ABLOCKS_BYTES);
+ abase = ALIGN (base, BLOCK_ALIGN);
+#endif
+
+ aligned = (base == abase);
+ if (!aligned)
+ ((void**)abase)[-1] = base;
+
+#ifdef DOUG_LEA_MALLOC
+ /* Back to a reasonable maximum of mmap'ed areas. */
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+#endif
+
+ /* If the memory just allocated cannot be addressed thru a Lisp
+ object's pointer, and it needs to be, that's equivalent to
+ running out of memory. */
+ if (type != MEM_TYPE_NON_LISP)
+ {
+ Lisp_Object tem;
+ char *end = (char *) base + ABLOCKS_BYTES - 1;
+ XSETCONS (tem, end);
+ if ((char *) XCONS (tem) != end)
+ {
+ lisp_malloc_loser = base;
+ free (base);
+ UNBLOCK_INPUT;
+ memory_full ();
+ }
+ }
+
+ /* Initialize the blocks and put them on the free list.
+ Is `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;
+ abase->blocks[i].x.next_free = free_ablock;
+ free_ablock = &abase->blocks[i];
+ }
+ ABLOCKS_BUSY (abase) = (struct ablocks *) aligned;
+
+ eassert (0 == ((EMACS_UINT)abase) % BLOCK_ALIGN);
+ eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
+ eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
+ eassert (ABLOCKS_BASE (abase) == base);
+ eassert (aligned == (int)ABLOCKS_BUSY (abase));
+ }
+
+ abase = ABLOCK_ABASE (free_ablock);
+ ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (int) ABLOCKS_BUSY (abase));
+ val = free_ablock;
+ free_ablock = free_ablock->x.next_free;
+
+#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+ if (val && type != MEM_TYPE_NON_LISP)
+ mem_insert (val, (char *) val + nbytes, type);
+#endif
+
+ UNBLOCK_INPUT;
+ if (!val && nbytes)
+ memory_full ();
+
+ eassert (0 == ((EMACS_UINT)val) % BLOCK_ALIGN);
+ return val;
+}
static void
-lisp_free (block)
+lisp_align_free (block)
POINTER_TYPE *block;
{
+ struct ablock *ablock = block;
+ struct ablocks *abase = ABLOCK_ABASE (ablock);
+
BLOCK_INPUT;
- free (block);
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
mem_delete (mem_find (block));
#endif
+ /* Put on free list. */
+ ablock->x.next_free = free_ablock;
+ free_ablock = ablock;
+ /* Update busy count. */
+ ABLOCKS_BUSY (abase) = (struct ablocks *) (-2 + (int) ABLOCKS_BUSY (abase));
+
+ if (2 > (int) ABLOCKS_BUSY (abase))
+ { /* All the blocks are free. */
+ int i = 0, aligned = (int) ABLOCKS_BUSY (abase);
+ struct ablock **tem = &free_ablock;
+ struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
+
+ while (*tem)
+ {
+ if (*tem >= (struct ablock *) abase && *tem < atop)
+ {
+ i++;
+ *tem = (*tem)->x.next_free;
+ }
+ else
+ tem = &(*tem)->x.next_free;
+ }
+ eassert ((aligned & 1) == aligned);
+ eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
+ free (ABLOCKS_BASE (abase));
+ }
UNBLOCK_INPUT;
}
+/* Return a new buffer structure allocated from the heap with
+ a call to lisp_malloc. */
+
+struct buffer *
+allocate_buffer ()
+{
+ struct buffer *b
+ = (struct buffer *) lisp_malloc (sizeof (struct buffer),
+ MEM_TYPE_BUFFER);
+ return b;
+}
+
\f
/* Arranging to disable input signals while we're in malloc.
elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
pairs; unfortunately, we have no idea what C library functions
might call malloc, so we can't really protect them unless you're
- using GNU malloc. Fortunately, most of the major operating can use
- GNU malloc. */
+ using GNU malloc. Fortunately, most of the major operating systems
+ can use GNU malloc. */
#ifndef SYSTEM_MALLOC
#ifndef DOUG_LEA_MALLOC
if (ptr)
{
struct mem_node *m;
-
+
m = mem_find (ptr);
if (m == MEM_NIL || m->start != ptr)
{
}
}
#endif /* GC_MALLOC_CHECK */
-
+
__free_hook = old_free_hook;
free (ptr);
-
+
/* If we released our reserve (due to running out of memory),
and we have a fair amount free once again,
try to set aside another reserve in case we run out once more. */
}
}
#endif /* GC_MALLOC_CHECK */
-
+
__malloc_hook = emacs_blocked_malloc;
UNBLOCK_INPUT;
mem_delete (m);
}
-
+
/* fprintf (stderr, "%p -> realloc\n", ptr); */
-
+
/* Prevent malloc from registering blocks. */
dont_register_blocks = 1;
#endif /* GC_MALLOC_CHECK */
/* Can't handle zero size regions in the red-black tree. */
mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
}
-
+
/* fprintf (stderr, "%p <- realloc\n", value); */
#endif /* GC_MALLOC_CHECK */
-
+
__realloc_hook = emacs_blocked_realloc;
UNBLOCK_INPUT;
newi = (struct interval_block *) lisp_malloc (sizeof *newi,
MEM_TYPE_NON_LISP);
- VALIDATE_LISP_STORAGE (newi, sizeof *newi);
newi->next = interval_block;
interval_block = newi;
interval_block_index = 0;
consing_since_gc += sizeof (struct interval);
intervals_consed++;
RESET_INTERVAL (val);
+ val->gcmarkbit = 0;
return val;
}
register INTERVAL i;
Lisp_Object dummy;
{
- if (XMARKBIT (i->plist))
- abort ();
- mark_object (&i->plist);
- XMARK (i->plist);
+ eassert (!i->gcmarkbit); /* Intervals are never shared. */
+ i->gcmarkbit = 1;
+ mark_object (i->plist);
}
function is always called through the MARK_INTERVAL_TREE macro,
which takes care of that. */
- /* XMARK expands to an assignment; the LHS of an assignment can't be
- a cast. */
- XMARK (tree->up.obj);
-
traverse_intervals_noorder (tree, mark_interval, Qnil);
}
#define MARK_INTERVAL_TREE(i) \
do { \
- if (!NULL_INTERVAL_P (i) \
- && ! XMARKBIT (i->up.obj)) \
+ if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
mark_interval_tree (i); \
} while (0)
-/* The oddity in the call to XUNMARK is necessary because XUNMARK
- expands to an assignment to its argument, and most C compilers
- don't support casts on the left operand of `='. */
-
#define UNMARK_BALANCE_INTERVALS(i) \
do { \
if (! NULL_INTERVAL_P (i)) \
- { \
- XUNMARK ((i)->up.obj); \
- (i) = balance_intervals (i); \
- } \
+ (i) = balance_intervals (i); \
} while (0)
\f
struct Lisp_String *string;
#ifdef GC_CHECK_STRING_BYTES
-
+
EMACS_INT nbytes;
unsigned char data[1];
-
+
#define SDATA_NBYTES(S) (S)->nbytes
#define SDATA_DATA(S) (S)->data
-
+
#else /* not GC_CHECK_STRING_BYTES */
union
/* When STRING is null. */
EMACS_INT nbytes;
} u;
-
+
#define SDATA_NBYTES(S) (S)->u.nbytes
#define SDATA_DATA(S) (S)->u.data
/* Number of Lisp strings in a string_block structure. The 1020 is
1024 minus malloc overhead. */
-#define STRINGS_IN_STRING_BLOCK \
+#define STRING_BLOCK_SIZE \
((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
/* Structure describing a block from which Lisp_String structures
struct string_block
{
struct string_block *next;
- struct Lisp_String strings[STRINGS_IN_STRING_BLOCK];
+ struct Lisp_String strings[STRING_BLOCK_SIZE];
};
/* Head and tail of the list of sblock structures holding Lisp string
S must be live, i.e. S->data must not be null. S->data is actually
a pointer to the `u.data' member of its sdata structure; the
structure starts at a constant offset in front of that. */
-
+
#ifdef GC_CHECK_STRING_BYTES
#define SDATA_OF_STRING(S) \
string_bytes (s)
struct Lisp_String *s;
{
- int nbytes = (s->size_byte < 0 ? s->size : s->size_byte) & ~MARKBIT;
+ int nbytes = (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
if (!PURE_POINTER_P (s)
&& s->data
&& nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
abort ();
return nbytes;
}
-
-/* Check validity Lisp strings' string_bytes member in B. */
+
+/* Check validity of Lisp strings' string_bytes member in B. */
void
check_sblock (b)
struct sblock *b;
{
struct sdata *from, *end, *from_end;
-
+
end = b->next_free;
-
+
for (from = &b->first_data; from < end; from = from_end)
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
int nbytes;
-
+
/* Check that the string size recorded in the string is the
same as the one recorded in the sdata structure. */
if (from->string)
CHECK_STRING_BYTES (from->string);
-
+
if (from->string)
nbytes = GC_STRING_BYTES (from->string);
else
nbytes = SDATA_NBYTES (from);
-
+
nbytes = SDATA_SIZE (nbytes);
from_end = (struct sdata *) ((char *) from + nbytes);
}
if (s)
CHECK_STRING_BYTES (s);
}
-
+
for (b = oldest_sblock; b; b = b->next)
check_sblock (b);
}
int i;
b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
- VALIDATE_LISP_STORAGE (b, sizeof *b);
bzero (b, sizeof *b);
b->next = string_blocks;
string_blocks = b;
++n_string_blocks;
- for (i = STRINGS_IN_STRING_BLOCK - 1; i >= 0; --i)
+ for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
{
s = b->strings + i;
NEXT_FREE_LISP_STRING (s) = string_free_list;
string_free_list = s;
}
- total_free_strings += STRINGS_IN_STRING_BLOCK;
+ total_free_strings += STRING_BLOCK_SIZE;
}
/* Pop a Lisp_String off the free-list. */
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive
-#ifdef macintosh
+#ifdef MAC_OS8
&& current_sblock
#endif
)
#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. */
+ 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);
#endif
b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP);
-
+
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
-
+
b->next_free = &b->first_data;
b->first_data.string = NULL;
b->next = large_sblocks;
old_data = s->data ? SDATA_OF_STRING (s) : NULL;
old_nbytes = GC_STRING_BYTES (s);
-
+
data = b->next_free;
data->string = s;
s->data = SDATA_DATA (data);
s->size_byte = nbytes;
s->data[nbytes] = '\0';
b->next_free = (struct sdata *) ((char *) data + needed);
-
+
/* If S had already data assigned, mark that as free by setting its
string back-pointer to null, and recording the size of the data
in it. */
{
struct string_block *b, *next;
struct string_block *live_blocks = NULL;
-
+
string_free_list = NULL;
total_strings = total_free_strings = 0;
total_string_size = 0;
next = b->next;
- for (i = 0; i < STRINGS_IN_STRING_BLOCK; ++i)
+ for (i = 0; i < STRING_BLOCK_SIZE; ++i)
{
struct Lisp_String *s = b->strings + i;
{
/* String is live; unmark it and its intervals. */
UNMARK_STRING (s);
-
+
if (!NULL_INTERVAL_P (s->intervals))
UNMARK_BALANCE_INTERVALS (s->intervals);
/* Free blocks that contain free Lisp_Strings only, except
the first two of them. */
- if (nfree == STRINGS_IN_STRING_BLOCK
- && total_free_strings > STRINGS_IN_STRING_BLOCK)
+ if (nfree == STRING_BLOCK_SIZE
+ && total_free_strings > STRING_BLOCK_SIZE)
{
lisp_free (b);
--n_string_blocks;
{
struct sblock *b, *next;
struct sblock *live_blocks = NULL;
-
+
for (b = large_sblocks; b; b = next)
{
next = b->next;
{
end = b->next_free;
xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
-
+
for (from = &b->first_data; from < end; from = from_end)
{
/* Compute the next FROM here because copying below may
&& GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
abort ();
#endif /* GC_CHECK_STRING_BYTES */
-
+
if (from->string)
nbytes = GC_STRING_BYTES (from->string);
else
nbytes = SDATA_NBYTES (from);
-
+
nbytes = SDATA_SIZE (nbytes);
from_end = (struct sdata *) ((char *) from + nbytes);
-
+
/* FROM->string non-null means it's alive. Copy its data. */
if (from->string)
{
to = &tb->first_data;
to_end = (struct sdata *) ((char *) to + nbytes);
}
-
+
/* Copy, and update the string's `data' pointer. */
if (from != to)
{
{
nbytes = XINT (length);
val = make_uninit_string (nbytes);
- p = XSTRING (val)->data;
- end = p + XSTRING (val)->size;
+ p = SDATA (val);
+ end = p + SCHARS (val);
while (p != end)
*p++ = c;
}
nbytes = len * XINT (length);
val = make_uninit_multibyte_string (XINT (length), nbytes);
- p = XSTRING (val)->data;
+ p = SDATA (val);
end = p + nbytes;
while (p != end)
{
p += len;
}
}
-
+
*p = 0;
return val;
}
slot `size' of the struct Lisp_Bool_Vector. */
val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
p = XBOOL_VECTOR (val);
-
+
/* Get rid of any bits that would cause confusion. */
p->vector_size = 0;
XSETBOOL_VECTOR (val, p);
p->size = XFASTINT (length);
-
+
real_init = (NILP (init) ? 0 : -1);
for (i = 0; i < length_in_chars ; i++)
p->data[i] = real_init;
-
+
/* Clear the extraneous bits in the last byte. */
if (XINT (length) != length_in_chars * BITS_PER_CHAR)
XBOOL_VECTOR (val)->data[length_in_chars - 1]
Lisp_Object
make_string (contents, nbytes)
- char *contents;
+ const char *contents;
int nbytes;
{
register Lisp_Object val;
Lisp_Object
make_unibyte_string (contents, length)
- char *contents;
+ const char *contents;
int length;
{
register Lisp_Object val;
val = make_uninit_string (length);
- bcopy (contents, XSTRING (val)->data, length);
- SET_STRING_BYTES (XSTRING (val), -1);
+ bcopy (contents, SDATA (val), length);
+ STRING_SET_UNIBYTE (val);
return val;
}
Lisp_Object
make_multibyte_string (contents, nchars, nbytes)
- char *contents;
+ const char *contents;
int nchars, nbytes;
{
register Lisp_Object val;
val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, XSTRING (val)->data, nbytes);
+ bcopy (contents, SDATA (val), nbytes);
return val;
}
Lisp_Object
make_string_from_bytes (contents, nchars, nbytes)
- char *contents;
+ const char *contents;
int nchars, nbytes;
{
register Lisp_Object val;
val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, XSTRING (val)->data, nbytes);
- if (STRING_BYTES (XSTRING (val)) == XSTRING (val)->size)
- SET_STRING_BYTES (XSTRING (val), -1);
+ bcopy (contents, SDATA (val), nbytes);
+ if (SBYTES (val) == SCHARS (val))
+ STRING_SET_UNIBYTE (val);
return val;
}
/* Make a string from NCHARS characters occupying NBYTES bytes at
CONTENTS. The argument MULTIBYTE controls whether to label the
- string as multibyte. */
+ string as multibyte. If NCHARS is negative, it counts the number of
+ characters by itself. */
Lisp_Object
make_specified_string (contents, nchars, nbytes, multibyte)
- char *contents;
+ const char *contents;
int nchars, nbytes;
int multibyte;
{
register Lisp_Object val;
+
+ if (nchars < 0)
+ {
+ if (multibyte)
+ nchars = multibyte_chars_in_text (contents, nbytes);
+ else
+ nchars = nbytes;
+ }
val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, XSTRING (val)->data, nbytes);
+ bcopy (contents, SDATA (val), nbytes);
if (!multibyte)
- SET_STRING_BYTES (XSTRING (val), -1);
+ STRING_SET_UNIBYTE (val);
return val;
}
Lisp_Object
build_string (str)
- char *str;
+ const char *str;
{
return make_string (str, strlen (str));
}
{
Lisp_Object val;
val = make_uninit_multibyte_string (length, length);
- SET_STRING_BYTES (XSTRING (val), -1);
+ STRING_SET_UNIBYTE (val);
return val;
}
/* We store float cells inside of float_blocks, allocating a new
float_block with malloc whenever necessary. Float cells reclaimed
by GC are put on a free list to be reallocated before allocating
- any new float cells from the latest float_block.
-
- Each float_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. */
+ any new float cells from the latest float_block. */
#define FLOAT_BLOCK_SIZE \
- ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
+ (((BLOCK_BYTES - sizeof (struct float_block *)) * 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))) \
+ & 1)
+
+#define SETMARKBIT(block,n) \
+ (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
+ |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
+
+#define UNSETMARKBIT(block,n) \
+ (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
+ &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
+
+#define FLOAT_BLOCK(fptr) \
+ ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
+
+#define FLOAT_INDEX(fptr) \
+ ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
struct float_block
{
- struct float_block *next;
+ /* 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)];
+ struct float_block *next;
};
+#define FLOAT_MARKED_P(fptr) \
+ GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
+
+#define FLOAT_MARK(fptr) \
+ SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
+
+#define FLOAT_UNMARK(fptr) \
+ UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
+
/* Current float_block. */
struct float_block *float_block;
void
init_float ()
{
- float_block = (struct float_block *) lisp_malloc (sizeof *float_block,
- MEM_TYPE_FLOAT);
- float_block->next = 0;
- bzero ((char *) float_block->floats, sizeof float_block->floats);
- float_block_index = 0;
+ float_block = NULL;
+ float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
float_free_list = 0;
- n_float_blocks = 1;
+ n_float_blocks = 0;
}
struct Lisp_Float *ptr;
{
*(struct Lisp_Float **)&ptr->data = float_free_list;
-#if GC_MARK_STACK
- ptr->type = Vdead;
-#endif
float_free_list = ptr;
}
{
register struct float_block *new;
- new = (struct float_block *) lisp_malloc (sizeof *new,
- MEM_TYPE_FLOAT);
- VALIDATE_LISP_STORAGE (new, sizeof *new);
+ new = (struct float_block *) lisp_align_malloc (sizeof *new,
+ MEM_TYPE_FLOAT);
new->next = float_block;
float_block = new;
float_block_index = 0;
}
XSETFLOAT (val, &float_block->floats[float_block_index++]);
}
-
+
XFLOAT_DATA (val) = float_value;
- XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */
+ FLOAT_UNMARK (XFLOAT (val));
consing_since_gc += sizeof (struct Lisp_Float);
floats_consed++;
return val;
/* We store cons cells inside of cons_blocks, allocating a new
cons_block with malloc whenever necessary. Cons cells reclaimed by
GC are put on a free list to be reallocated before allocating
- any new cons cells from the latest cons_block.
-
- Each cons_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. */
+ any new cons cells from the latest cons_block. */
#define CONS_BLOCK_SIZE \
- ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
+ (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
+ / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
+
+#define CONS_BLOCK(fptr) \
+ ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
+
+#define CONS_INDEX(fptr) \
+ ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
struct cons_block
{
- struct cons_block *next;
+ /* 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)];
+ struct cons_block *next;
};
+#define CONS_MARKED_P(fptr) \
+ GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+
+#define CONS_MARK(fptr) \
+ SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+
+#define CONS_UNMARK(fptr) \
+ UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
+
/* Current cons_block. */
struct cons_block *cons_block;
void
init_cons ()
{
- cons_block = (struct cons_block *) lisp_malloc (sizeof *cons_block,
- MEM_TYPE_CONS);
- cons_block->next = 0;
- bzero ((char *) cons_block->conses, sizeof cons_block->conses);
- cons_block_index = 0;
+ cons_block = NULL;
+ cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block. */
cons_free_list = 0;
- n_cons_blocks = 1;
+ n_cons_blocks = 0;
}
if (cons_block_index == CONS_BLOCK_SIZE)
{
register struct cons_block *new;
- new = (struct cons_block *) lisp_malloc (sizeof *new,
- MEM_TYPE_CONS);
- VALIDATE_LISP_STORAGE (new, sizeof *new);
+ new = (struct cons_block *) lisp_align_malloc (sizeof *new,
+ MEM_TYPE_CONS);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
}
XSETCONS (val, &cons_block->conses[cons_block_index++]);
}
-
+
XSETCAR (val, car);
XSETCDR (val, cdr);
+ CONS_UNMARK (XCONS (val));
consing_since_gc += sizeof (struct Lisp_Cons);
cons_cells_consed++;
return val;
{
val = Fcons (init, val);
--size;
-
+
if (size > 0)
{
val = Fcons (init, val);
--size;
-
+
if (size > 0)
{
val = Fcons (init, val);
--size;
-
+
if (size > 0)
{
val = Fcons (init, val);
QUIT;
}
-
+
return val;
}
a dumped Emacs. */
mallopt (M_MMAP_MAX, 0);
#endif
-
+
nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);
-
+
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
-
- VALIDATE_LISP_STORAGE (p, 0);
+
consing_since_gc += nbytes;
vector_cells_consed += len;
EMACS_INT len = VECSIZE (struct Lisp_Hash_Table);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE);
EMACS_INT i;
-
+
v->size = len;
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
-
+
return (struct Lisp_Hash_Table *) v;
}
EMACS_INT len = VECSIZE (struct window);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW);
EMACS_INT i;
-
+
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
v->size = len;
-
+
return (struct window *) v;
}
EMACS_INT len = VECSIZE (struct frame);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME);
EMACS_INT i;
-
+
for (i = 0; i < len; ++i)
v->contents[i] = make_number (0);
v->size = len;
EMACS_INT len = VECSIZE (struct Lisp_Process);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS);
EMACS_INT i;
-
+
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
v->size = len;
-
+
return (struct Lisp_Process *) v;
}
{
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR);
EMACS_INT i;
-
+
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
v->size = len;
-
+
return v;
}
stack size, (optional) doc string, and (optional) interactive spec.
The first four arguments are required; at most six have any
significance.
-usage: (make-byte-code &rest ELEMENTS) */)
+usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
(nargs, args)
register int nargs;
Lisp_Object *args;
struct symbol_block *new;
new = (struct symbol_block *) lisp_malloc (sizeof *new,
MEM_TYPE_SYMBOL);
- VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = symbol_block;
symbol_block = new;
symbol_block_index = 0;
}
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
}
-
+
p = XSYMBOL (val);
- p->name = XSTRING (name);
+ p->xname = name;
p->plist = Qnil;
p->value = Qunbound;
p->function = Qunbound;
p->next = NULL;
+ p->gcmarkbit = 0;
p->interned = SYMBOL_UNINTERNED;
p->constant = 0;
p->indirect_variable = 0;
struct marker_block *new;
new = (struct marker_block *) lisp_malloc (sizeof *new,
MEM_TYPE_MISC);
- VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = marker_block;
marker_block = new;
marker_block_index = 0;
}
XSETMISC (val, &marker_block->markers[marker_block_index++]);
}
-
+
consing_since_gc += sizeof (union Lisp_Misc);
misc_objects_consed++;
+ XMARKER (val)->gcmarkbit = 0;
+ return val;
+}
+
+/* Return a Lisp_Misc_Save_Value object containing POINTER and
+ INTEGER. This is used to package C values to call record_unwind_protect.
+ The unwind function can get the C values back using XSAVE_VALUE. */
+
+Lisp_Object
+make_save_value (pointer, integer)
+ void *pointer;
+ int integer;
+{
+ register Lisp_Object val;
+ register struct Lisp_Save_Value *p;
+
+ val = allocate_misc ();
+ XMISCTYPE (val) = Lisp_Misc_Save_Value;
+ p = XSAVE_VALUE (val);
+ p->pointer = pointer;
+ p->integer = integer;
return val;
}
p->buffer = 0;
p->bytepos = 0;
p->charpos = 0;
- p->chain = Qnil;
+ p->next = NULL;
p->insertion_type = 0;
return val;
}
free_marker (marker)
Lisp_Object marker;
{
- unchain_marker (marker);
+ unchain_marker (XMARKER (marker));
XMISC (marker)->u_marker.type = Lisp_Misc_Free;
XMISC (marker)->u_free.chain = marker_free_list;
characters, so we can make a string. */
{
Lisp_Object result;
-
+
result = Fmake_string (make_number (nargs), make_number (0));
for (i = 0; i < nargs; i++)
{
- XSTRING (result)->data[i] = XINT (args[i]);
+ SSET (result, i, XINT (args[i]));
/* Move the meta bit to the right place for a string char. */
if (XINT (args[i]) & CHAR_META)
- XSTRING (result)->data[i] |= 0x80;
+ SSET (result, i, SREF (result, i) | 0x80);
}
-
+
return result;
}
}
parent = NULL;
#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
-
+
while (c != MEM_NIL)
{
if (start >= c->start && start < c->end)
parent = c;
c = start < c->start ? c->left : c->right;
}
-
+
#else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
-
+
while (c != MEM_NIL)
{
parent = c;
c = start < c->start ? c->left : c->right;
}
-
+
#endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
/* Create a new node. */
else
parent->right = x;
}
- else
+ else
mem_root = x;
/* Re-establish red-black tree properties. */
{
/* X is red and its parent is red. This is a violation of
red-black tree property #3. */
-
+
if (x->parent == x->parent->parent->left)
{
/* We're on the left side of our grandparent, and Y is our
"uncle". */
struct mem_node *y = x->parent->parent->right;
-
+
if (y->color == MEM_RED)
{
/* Uncle and parent are red but should be black because
{
/* This is the symmetrical case of above. */
struct mem_node *y = x->parent->parent->left;
-
+
if (y->color == MEM_RED)
{
x->parent->color = MEM_BLACK;
x = x->parent;
mem_rotate_right (x);
}
-
+
x->parent->color = MEM_BLACK;
x->parent->parent->color = MEM_RED;
mem_rotate_left (x->parent->parent);
}
-/* (x) (y)
- / \ / \
+/* (x) (y)
+ / \ / \
a (y) ===> (x) c
/ \ / \
b c a b */
}
-/* (x) (Y)
- / \ / \
- (y) c ===> a (x)
- / \ / \
+/* (x) (Y)
+ / \ / \
+ (y) c ===> a (x)
+ / \ / \
a b b c */
static void
x->left = y->right;
if (y->right != MEM_NIL)
y->right->parent = x;
-
+
if (y != MEM_NIL)
y->parent = x->parent;
if (x->parent)
}
else
mem_root = y;
-
+
y->right = x;
if (x != MEM_NIL)
x->parent = y;
z->end = y->end;
z->type = y->type;
}
-
+
if (y->color == MEM_BLACK)
mem_delete_fixup (x);
if (x == x->parent->left)
{
struct mem_node *w = x->parent->right;
-
+
if (w->color == MEM_RED)
{
w->color = MEM_BLACK;
mem_rotate_left (x->parent);
w = x->parent->right;
}
-
+
if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
{
w->color = MEM_RED;
else
{
struct mem_node *w = x->parent->left;
-
+
if (w->color == MEM_RED)
{
w->color = MEM_BLACK;
mem_rotate_right (x->parent);
w = x->parent->left;
}
-
+
if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
{
w->color = MEM_RED;
mem_rotate_left (w);
w = x->parent->left;
}
-
+
w->color = x->parent->color;
x->parent->color = MEM_BLACK;
w->left->color = MEM_BLACK;
}
}
}
-
+
x->color = MEM_BLACK;
}
one of the unused cells in the current cons block,
and not be on the free-list. */
return (offset >= 0
+ && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
&& offset % sizeof b->conses[0] == 0
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index)
{
struct symbol_block *b = (struct symbol_block *) m->start;
int offset = (char *) p - (char *) &b->symbols[0];
-
+
/* P must point to the start of a Lisp_Symbol, not be
one of the unused cells in the current symbol block,
and not be on the free-list. */
{
struct float_block *b = (struct float_block *) m->start;
int offset = (char *) p - (char *) &b->floats[0];
-
- /* P must point to the start of a Lisp_Float, not be
- one of the unused cells in the current float block,
- and not be on the free-list. */
+
+ /* P must point to the start of a Lisp_Float and not be
+ one of the unused cells in the current float block. */
return (offset >= 0
+ && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
&& offset % sizeof b->floats[0] == 0
&& (b != float_block
- || offset / sizeof b->floats[0] < float_block_index)
- && !EQ (((struct Lisp_Float *) p)->type, Vdead));
+ || offset / sizeof b->floats[0] < float_block_index));
}
else
return 0;
{
struct marker_block *b = (struct marker_block *) m->start;
int offset = (char *) p - (char *) &b->markers[0];
-
+
/* P must point to the start of a Lisp_Misc, not be
one of the unused cells in the current misc block,
and not be on the free-list. */
}
-/* Value is non-zero of P is a pointer to a live buffer. M is a
+/* Value is non-zero if P is a pointer to a live buffer. M is a
pointer to the mem_block for P. */
static INLINE int
doc: /* Show information about live and zombie objects. */)
()
{
- Lisp_Object args[7];
- args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
+ Lisp_Object args[8], zombie_list = Qnil;
+ int i;
+ for (i = 0; i < 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);
args[2] = make_float (avg_live);
args[3] = make_float (avg_zombies);
args[4] = make_float (avg_zombies / avg_live / 100);
args[5] = make_number (max_live);
args[6] = make_number (max_zombies);
- return Fmessage (7, args);
+ args[7] = zombie_list;
+ return Fmessage (8, args);
}
#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
{
void *po = (void *) XPNTR (obj);
struct mem_node *m = mem_find (po);
-
+
if (m != MEM_NIL)
{
int mark_p = 0;
break;
case Lisp_Cons:
- mark_p = (live_cons_p (m, po)
- && !XMARKBIT (XCONS (obj)->car));
+ mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
break;
case Lisp_Symbol:
- mark_p = (live_symbol_p (m, po)
- && !XMARKBIT (XSYMBOL (obj)->plist));
+ mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
break;
case Lisp_Float:
- mark_p = (live_float_p (m, po)
- && !XMARKBIT (XFLOAT (obj)->type));
+ mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
break;
case Lisp_Vectorlike:
buffer because checking that dereferences the pointer
PO which might point anywhere. */
if (live_vector_p (m, po))
- mark_p = (!GC_SUBRP (obj)
- && !(XVECTOR (obj)->size & ARRAY_MARK_FLAG));
+ mark_p = !GC_SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
else if (live_buffer_p (m, po))
- mark_p = GC_BUFFERP (obj) && !XMARKBIT (XBUFFER (obj)->name);
+ mark_p = GC_BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
break;
case Lisp_Misc:
- if (live_misc_p (m, po))
- {
- switch (XMISCTYPE (obj))
- {
- case Lisp_Misc_Marker:
- mark_p = !XMARKBIT (XMARKER (obj)->chain);
- break;
-
- case Lisp_Misc_Buffer_Local_Value:
- case Lisp_Misc_Some_Buffer_Local_Value:
- mark_p = !XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
- break;
-
- case Lisp_Misc_Overlay:
- mark_p = !XMARKBIT (XOVERLAY (obj)->plist);
- break;
- }
- }
+ mark_p = (live_misc_p (m, po) && !XMARKER (obj)->gcmarkbit);
break;
case Lisp_Int:
{
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
if (nzombies < MAX_ZOMBIES)
- zombies[nzombies] = *p;
+ zombies[nzombies] = obj;
++nzombies;
#endif
- mark_object (&obj);
+ mark_object (obj);
}
}
}
assume that Lisp data is aligned on even addresses. */
if ((EMACS_INT) p & 1)
return;
-
+
m = mem_find (p);
if (m != MEM_NIL)
{
Lisp_Object obj = Qnil;
-
+
switch (m->type)
{
case MEM_TYPE_NON_LISP:
/* Nothing to do; not a pointer to Lisp memory. */
break;
-
+
case MEM_TYPE_BUFFER:
- if (live_buffer_p (m, p)
- && !XMARKBIT (((struct buffer *) p)->name))
+ if (live_buffer_p (m, p) && !VECTOR_MARKED_P((struct buffer *)p))
XSETVECTOR (obj, p);
break;
-
+
case MEM_TYPE_CONS:
- if (live_cons_p (m, p)
- && !XMARKBIT (((struct Lisp_Cons *) p)->car))
+ if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
XSETCONS (obj, p);
break;
-
+
case MEM_TYPE_STRING:
if (live_string_p (m, p)
&& !STRING_MARKED_P ((struct Lisp_String *) p))
break;
case MEM_TYPE_MISC:
- if (live_misc_p (m, p))
- {
- Lisp_Object tem;
- XSETMISC (tem, p);
-
- switch (XMISCTYPE (tem))
- {
- case Lisp_Misc_Marker:
- if (!XMARKBIT (XMARKER (tem)->chain))
- obj = tem;
- break;
-
- case Lisp_Misc_Buffer_Local_Value:
- case Lisp_Misc_Some_Buffer_Local_Value:
- if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem)->realvalue))
- obj = tem;
- break;
-
- case Lisp_Misc_Overlay:
- if (!XMARKBIT (XOVERLAY (tem)->plist))
- obj = tem;
- break;
- }
- }
+ if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
+ XSETMISC (obj, p);
break;
-
+
case MEM_TYPE_SYMBOL:
- if (live_symbol_p (m, p)
- && !XMARKBIT (((struct Lisp_Symbol *) p)->plist))
+ if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
XSETSYMBOL (obj, p);
break;
-
+
case MEM_TYPE_FLOAT:
- if (live_float_p (m, p)
- && !XMARKBIT (((struct Lisp_Float *) p)->type))
+ if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
XSETFLOAT (obj, p);
break;
-
+
case MEM_TYPE_VECTOR:
case MEM_TYPE_PROCESS:
case MEM_TYPE_HASH_TABLE:
{
Lisp_Object tem;
XSETVECTOR (tem, p);
- if (!GC_SUBRP (tem)
- && !(XVECTOR (tem)->size & ARRAY_MARK_FLAG))
+ if (!GC_SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
obj = tem;
}
break;
}
if (!GC_NILP (obj))
- mark_object (&obj);
+ mark_object (obj);
}
}
/* Mark Lisp objects referenced from the address range START..END. */
-static void
+static void
mark_memory (start, end)
void *start, *end;
{
Here, `obj' isn't really used, and the compiler optimizes it
away. The only reference to the life string is through the
pointer `s'. */
-
+
for (pp = (void **) start; (void *) pp < end; ++pp)
mark_maybe_pointer (*pp);
}
+/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
+ the GCC system configuration. In gcc 3.2, the only systems for
+ which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
+ by others?) and ns32k-pc532-min. */
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
\n\
Please take a look at the function mark_stack in alloc.c, and\n\
try to find a way to make it work on your system.\n\
+\n\
+Note that you may get false negatives, depending on the compiler.\n\
+In particular, you need to use -O with GCC for this test.\n\
+\n\
Please mail the result to <emacs-devel@gnu.org>.\n\
"
for (p = gcprolist; p; p = p->next)
for (i = 0; i < p->nvars; ++i)
if (!survives_gc_p (p->var[i]))
+ /* FIXME: It's not necessarily a bug. It might just be that the
+ GCPRO is unnecessary or should release the object sooner. */
abort ();
}
/* 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
asm ("ta 3");
#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
test_setjmp ();
}
#endif /* GC_SETJMP_WORKS */
-
+
setjmp (j);
end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
#endif /* not GC_SAVE_REGISTERS_ON_STACK */
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 ((char *) stack_base + i, end);
size_t size;
int type;
{
- size_t nbytes;
POINTER_TYPE *result;
- char *beg = purebeg;
+ size_t alignment = sizeof (EMACS_INT);
/* Give Lisp_Floats an extra alignment. */
if (type == Lisp_Float)
{
- size_t alignment;
#if defined __GNUC__ && __GNUC__ >= 2
alignment = __alignof (struct Lisp_Float);
#else
alignment = sizeof (struct Lisp_Float);
#endif
- pure_bytes_used = ALIGN (pure_bytes_used, alignment);
- }
-
- nbytes = ALIGN (size, sizeof (EMACS_INT));
-
- if (pure_bytes_used + nbytes > pure_size)
- {
- /* Don't allocate a large amount here,
- because it might get mmap'd and then its address
- might not be usable. */
- beg = purebeg = (char *) xmalloc (10000);
- pure_size = 10000;
- pure_bytes_used_before_overflow += pure_bytes_used;
- pure_bytes_used = 0;
}
- result = (POINTER_TYPE *) (beg + pure_bytes_used);
- pure_bytes_used += nbytes;
- return result;
+ again:
+ result = ALIGN (purebeg + pure_bytes_used, alignment);
+ pure_bytes_used = ((char *)result - (char *)purebeg) + size;
+
+ if (pure_bytes_used <= pure_size)
+ return result;
+
+ /* Don't allocate a large amount here,
+ because it might get mmap'd and then its address
+ might not be usable. */
+ purebeg = (char *) xmalloc (10000);
+ pure_size = 10000;
+ pure_bytes_used_before_overflow += pure_bytes_used - size;
+ pure_bytes_used = 0;
+ goto again;
}
-/* Signal an error if PURESIZE is too small. */
+/* Print a warning if PURESIZE is too small. */
void
check_pure_size ()
{
if (pure_bytes_used_before_overflow)
- error ("Pure Lisp storage overflow (approx. %d bytes needed)",
- (int) (pure_bytes_used + pure_bytes_used_before_overflow));
+ message ("Pure Lisp storage overflow (approx. %d bytes needed)",
+ (int) (pure_bytes_used + pure_bytes_used_before_overflow));
}
else if (FLOATP (obj))
return make_pure_float (XFLOAT_DATA (obj));
else if (STRINGP (obj))
- return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size,
- STRING_BYTES (XSTRING (obj)),
+ return make_pure_string (SDATA (obj), SCHARS (obj),
+ SBYTES (obj),
STRING_MULTIBYTE (obj));
else if (COMPILEDP (obj) || VECTORP (obj))
{
int
inhibit_garbage_collection ()
{
- int count = specpdl_ptr - specpdl;
+ int count = SPECPDL_INDEX ();
int nbits = min (VALBITS, BITS_PER_INT);
specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
doc: /* Reclaim storage for Lisp objects no longer needed.
-Returns info on amount of space in use:
+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:
((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
(USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
(USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
(USED-STRINGS . FREE-STRINGS))
-Garbage collection happens automatically if you cons more than
-`gc-cons-threshold' bytes of Lisp data since previous garbage collection. */)
+However, if there was overflow in pure space, `garbage-collect'
+returns nil, because real GC can't be done. */)
()
{
- register struct gcpro *tail;
register struct specbinding *bind;
struct catchtag *catch;
struct handler *handler;
register int i;
int message_p;
Lisp_Object total[8];
- int count = BINDING_STACK_SIZE ();
+ int count = SPECPDL_INDEX ();
+ EMACS_TIME t1, t2, t3;
+
+ if (abort_on_gc)
+ abort ();
+
+ EMACS_GET_TIME (t1);
/* Can't GC if pure storage overflowed because we can't determine
if something is a pure object or not. */
/* Save what's currently displayed in the echo area. */
message_p = push_message ();
- record_unwind_protect (push_message_unwind, Qnil);
+ record_unwind_protect (pop_message_unwind, Qnil);
/* Save a copy of the contents of the stack, for debugging. */
#if MAX_SAVE_STACK > 0
Qt tends to return NULL, which effectively turns undo back on.
So don't call truncate_undo_list if undo_list is Qt. */
if (! EQ (nextb->undo_list, Qt))
- nextb->undo_list
+ nextb->undo_list
= truncate_undo_list (nextb->undo_list, undo_limit,
undo_strong_limit);
For these, we use MARKBIT to avoid double marking of the slot. */
for (i = 0; i < staticidx; i++)
- mark_object (staticvec[i]);
+ mark_object (*staticvec[i]);
#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
|| GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
mark_stack ();
#else
- for (tail = gcprolist; tail; tail = tail->next)
- for (i = 0; i < tail->nvars; i++)
- if (!XMARKBIT (tail->var[i]))
- {
- /* Explicit casting prevents compiler warning about
- discarding the `volatile' qualifier. */
- mark_object ((Lisp_Object *)&tail->var[i]);
- XMARK (tail->var[i]);
- }
+ {
+ register struct gcpro *tail;
+ for (tail = gcprolist; tail; tail = tail->next)
+ for (i = 0; i < tail->nvars; i++)
+ if (!XMARKBIT (tail->var[i]))
+ {
+ mark_object (tail->var[i]);
+ XMARK (tail->var[i]);
+ }
+ }
#endif
-
+
mark_byte_stack ();
for (bind = specpdl; bind != specpdl_ptr; bind++)
{
- mark_object (&bind->symbol);
- mark_object (&bind->old_value);
+ mark_object (bind->symbol);
+ mark_object (bind->old_value);
}
for (catch = catchlist; catch; catch = catch->next)
{
- mark_object (&catch->tag);
- mark_object (&catch->val);
- }
+ mark_object (catch->tag);
+ mark_object (catch->val);
+ }
for (handler = handlerlist; handler; handler = handler->next)
{
- mark_object (&handler->handler);
- mark_object (&handler->var);
- }
+ mark_object (handler->handler);
+ mark_object (handler->var);
+ }
for (backlist = backtrace_list; backlist; backlist = backlist->next)
{
if (!XMARKBIT (*backlist->function))
{
- mark_object (backlist->function);
+ mark_object (*backlist->function);
XMARK (*backlist->function);
}
if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
for (; i >= 0; i--)
if (!XMARKBIT (backlist->args[i]))
{
- mark_object (&backlist->args[i]);
+ mark_object (backlist->args[i]);
XMARK (backlist->args[i]);
}
- }
+ }
mark_kboards ();
/* Look thru every buffer's undo list
{
if (GC_CONSP (XCAR (tail))
&& GC_MARKERP (XCAR (XCAR (tail)))
- && ! XMARKBIT (XMARKER (XCAR (XCAR (tail)))->chain))
+ && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
{
if (NILP (prev))
nextb->undo_list = tail = XCDR (tail);
mark_stack ();
#endif
+#ifdef USE_GTK
+ {
+ extern void xg_mark_data ();
+ xg_mark_data ();
+ }
+#endif
+
gc_sweep ();
/* Clear the mark bits that we set in certain root slots. */
#if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
|| GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
- for (tail = gcprolist; tail; tail = tail->next)
- for (i = 0; i < tail->nvars; i++)
- XUNMARK (tail->var[i]);
+ {
+ register struct gcpro *tail;
+
+ for (tail = gcprolist; tail; tail = tail->next)
+ for (i = 0; i < tail->nvars; i++)
+ XUNMARK (tail->var[i]);
+ }
#endif
-
+
unmark_byte_stack ();
for (backlist = backtrace_list; backlist; backlist = backlist->next)
{
i = backlist->nargs - 1;
for (; i >= 0; i--)
XUNMARK (backlist->args[i]);
- }
- XUNMARK (buffer_defaults.name);
- XUNMARK (buffer_local_symbols.name);
+ }
+ VECTOR_UNMARK (&buffer_defaults);
+ VECTOR_UNMARK (&buffer_local_symbols);
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
dump_zombies ();
{
/* Compute average percentage of zombies. */
double nlive = 0;
-
+
for (i = 0; i < 7; ++i)
- nlive += XFASTINT (XCAR (total[i]));
+ if (CONSP (total[i]))
+ nlive += XFASTINT (XCAR (total[i]));
avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
max_live = max (nlive, max_live);
safe_run_hooks (Qpost_gc_hook);
unbind_to (count, Qnil);
}
-
+
+ /* Accumulate statistics. */
+ EMACS_GET_TIME (t2);
+ EMACS_SUB_TIME (t3, t2, t1);
+ if (FLOATP (Vgc_elapsed))
+ Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) +
+ EMACS_SECS (t3) +
+ EMACS_USECS (t3) * 1.0e-6);
+ gcs_done++;
+
return Flist (sizeof total / sizeof *total, total);
}
{
struct glyph *glyph = row->glyphs[area];
struct glyph *end_glyph = glyph + row->used[area];
-
+
for (; glyph < end_glyph; ++glyph)
if (GC_STRINGP (glyph->object)
&& !STRING_MARKED_P (XSTRING (glyph->object)))
- mark_object (&glyph->object);
+ mark_object (glyph->object);
}
}
}
if (face)
{
for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
- mark_object (&face->lface[j]);
+ mark_object (face->lface[j]);
}
}
}
mark_image (img)
struct image *img;
{
- mark_object (&img->spec);
-
+ mark_object (img->spec);
+
if (!NILP (img->data.lisp_val))
- mark_object (&img->data.lisp_val);
+ mark_object (img->data.lisp_val);
}
all the references contained in it. */
#define LAST_MARKED_SIZE 500
-Lisp_Object *last_marked[LAST_MARKED_SIZE];
+Lisp_Object last_marked[LAST_MARKED_SIZE];
int last_marked_index;
+/* For debugging--call abort when we cdr down this many
+ links of a list, in mark_object. In debugging,
+ the call to abort will hit a breakpoint.
+ Normally this is zero and the check never goes off. */
+int mark_object_loop_halt;
+
void
-mark_object (argptr)
- Lisp_Object *argptr;
+mark_object (arg)
+ Lisp_Object arg;
{
- Lisp_Object *objptr = argptr;
- register Lisp_Object obj;
+ register Lisp_Object obj = arg;
#ifdef GC_CHECK_MARKED_OBJECTS
void *po;
struct mem_node *m;
#endif
+ int cdr_count = 0;
loop:
- obj = *objptr;
- loop2:
XUNMARK (obj);
if (PURE_POINTER_P (XPNTR (obj)))
return;
- last_marked[last_marked_index++] = objptr;
+ last_marked[last_marked_index++] = obj;
if (last_marked_index == LAST_MARKED_SIZE)
last_marked_index = 0;
CHECK_ALLOCATED (); \
CHECK_LIVE (LIVEP); \
} while (0) \
-
+
#else /* not GC_CHECK_MARKED_OBJECTS */
-
+
#define CHECK_ALLOCATED() (void) 0
#define CHECK_LIVE(LIVEP) (void) 0
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
-
+
#endif /* not GC_CHECK_MARKED_OBJECTS */
switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
&& po != &buffer_local_symbols)
abort ();
#endif /* GC_CHECK_MARKED_OBJECTS */
-
+
if (GC_BUFFERP (obj))
{
- if (!XMARKBIT (XBUFFER (obj)->name))
+ if (!VECTOR_MARKED_P (XBUFFER (obj)))
{
#ifdef GC_CHECK_MARKED_OBJECTS
if (po != &buffer_defaults && po != &buffer_local_symbols)
register EMACS_INT size = ptr->size;
register int i;
- if (size & ARRAY_MARK_FLAG)
+ if (VECTOR_MARKED_P (ptr))
break; /* Already marked */
-
+
CHECK_LIVE (live_vector_p);
- ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+ VECTOR_MARK (ptr); /* Else mark it */
size &= PSEUDOVECTOR_SIZE_MASK;
for (i = 0; i < size; i++) /* and then mark its elements */
{
if (i != COMPILED_CONSTANTS)
- mark_object (&ptr->contents[i]);
+ mark_object (ptr->contents[i]);
}
- /* This cast should be unnecessary, but some Mips compiler complains
- (MIPS-ABI + SysVR4, DC/OSx, etc). */
- objptr = (Lisp_Object *) &ptr->contents[COMPILED_CONSTANTS];
+ obj = ptr->contents[COMPILED_CONSTANTS];
goto loop;
}
else if (GC_FRAMEP (obj))
{
register struct frame *ptr = XFRAME (obj);
- register EMACS_INT size = ptr->size;
- if (size & ARRAY_MARK_FLAG) break; /* Already marked */
- ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+ if (VECTOR_MARKED_P (ptr)) break; /* Already marked */
+ VECTOR_MARK (ptr); /* Else mark it */
CHECK_LIVE (live_vector_p);
- mark_object (&ptr->name);
- mark_object (&ptr->icon_name);
- mark_object (&ptr->title);
- mark_object (&ptr->focus_frame);
- mark_object (&ptr->selected_window);
- mark_object (&ptr->minibuffer_window);
- mark_object (&ptr->param_alist);
- mark_object (&ptr->scroll_bars);
- mark_object (&ptr->condemned_scroll_bars);
- mark_object (&ptr->menu_bar_items);
- mark_object (&ptr->face_alist);
- mark_object (&ptr->menu_bar_vector);
- mark_object (&ptr->buffer_predicate);
- mark_object (&ptr->buffer_list);
- mark_object (&ptr->menu_bar_window);
- mark_object (&ptr->tool_bar_window);
+ mark_object (ptr->name);
+ mark_object (ptr->icon_name);
+ mark_object (ptr->title);
+ mark_object (ptr->focus_frame);
+ mark_object (ptr->selected_window);
+ mark_object (ptr->minibuffer_window);
+ mark_object (ptr->param_alist);
+ mark_object (ptr->scroll_bars);
+ mark_object (ptr->condemned_scroll_bars);
+ mark_object (ptr->menu_bar_items);
+ mark_object (ptr->face_alist);
+ mark_object (ptr->menu_bar_vector);
+ mark_object (ptr->buffer_predicate);
+ mark_object (ptr->buffer_list);
+ mark_object (ptr->menu_bar_window);
+ mark_object (ptr->tool_bar_window);
mark_face_cache (ptr->face_cache);
#ifdef HAVE_WINDOW_SYSTEM
mark_image_cache (ptr);
- mark_object (&ptr->tool_bar_items);
- mark_object (&ptr->desired_tool_bar_string);
- mark_object (&ptr->current_tool_bar_string);
+ mark_object (ptr->tool_bar_items);
+ mark_object (ptr->desired_tool_bar_string);
+ mark_object (ptr->current_tool_bar_string);
#endif /* HAVE_WINDOW_SYSTEM */
}
else if (GC_BOOL_VECTOR_P (obj))
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
- if (ptr->size & ARRAY_MARK_FLAG)
+ if (VECTOR_MARKED_P (ptr))
break; /* Already marked */
CHECK_LIVE (live_vector_p);
- ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+ VECTOR_MARK (ptr); /* Else mark it */
}
else if (GC_WINDOWP (obj))
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
struct window *w = XWINDOW (obj);
- register EMACS_INT size = ptr->size;
register int i;
/* Stop if already marked. */
- if (size & ARRAY_MARK_FLAG)
+ if (VECTOR_MARKED_P (ptr))
break;
/* Mark it. */
CHECK_LIVE (live_vector_p);
- ptr->size |= ARRAY_MARK_FLAG;
+ VECTOR_MARK (ptr);
/* There is no Lisp data above The member CURRENT_MATRIX in
struct WINDOW. Stop marking when that slot is reached. */
for (i = 0;
(char *) &ptr->contents[i] < (char *) &w->current_matrix;
i++)
- mark_object (&ptr->contents[i]);
+ mark_object (ptr->contents[i]);
/* Mark glyphs for leaf windows. Marking window matrices is
sufficient because frame matrices use the same glyph
else if (GC_HASH_TABLE_P (obj))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
- EMACS_INT size = h->size;
-
+
/* Stop if already marked. */
- if (size & ARRAY_MARK_FLAG)
+ if (VECTOR_MARKED_P (h))
break;
-
+
/* Mark it. */
CHECK_LIVE (live_vector_p);
- h->size |= ARRAY_MARK_FLAG;
+ VECTOR_MARK (h);
/* Mark contents. */
/* Do not mark next_free or next_weak.
- Being in the next_weak chain
+ Being in the next_weak chain
should not keep the hash table alive.
No need to mark `count' since it is an integer. */
- mark_object (&h->test);
- mark_object (&h->weak);
- mark_object (&h->rehash_size);
- mark_object (&h->rehash_threshold);
- mark_object (&h->hash);
- mark_object (&h->next);
- mark_object (&h->index);
- mark_object (&h->user_hash_function);
- mark_object (&h->user_cmp_function);
+ mark_object (h->test);
+ mark_object (h->weak);
+ mark_object (h->rehash_size);
+ mark_object (h->rehash_threshold);
+ mark_object (h->hash);
+ mark_object (h->next);
+ mark_object (h->index);
+ mark_object (h->user_hash_function);
+ mark_object (h->user_cmp_function);
/* If hash table is not weak, mark all keys and values.
For weak tables, mark only the vector. */
if (GC_NILP (h->weak))
- mark_object (&h->key_and_value);
+ mark_object (h->key_and_value);
else
- XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG;
-
+ VECTOR_MARK (XVECTOR (h->key_and_value));
}
else
{
register EMACS_INT size = ptr->size;
register int i;
- if (size & ARRAY_MARK_FLAG) break; /* Already marked */
+ if (VECTOR_MARKED_P (ptr)) break; /* Already marked */
CHECK_LIVE (live_vector_p);
- ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+ VECTOR_MARK (ptr); /* Else mark it */
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
for (i = 0; i < size; i++) /* and then mark its elements */
- mark_object (&ptr->contents[i]);
+ mark_object (ptr->contents[i]);
}
break;
register struct Lisp_Symbol *ptr = XSYMBOL (obj);
struct Lisp_Symbol *ptrx;
- if (XMARKBIT (ptr->plist)) break;
+ if (ptr->gcmarkbit) break;
CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
- XMARK (ptr->plist);
- mark_object ((Lisp_Object *) &ptr->value);
- mark_object (&ptr->function);
- mark_object (&ptr->plist);
-
- if (!PURE_POINTER_P (ptr->name))
- MARK_STRING (ptr->name);
- MARK_INTERVAL_TREE (ptr->name->intervals);
-
+ ptr->gcmarkbit = 1;
+ mark_object (ptr->value);
+ mark_object (ptr->function);
+ mark_object (ptr->plist);
+
+ if (!PURE_POINTER_P (XSTRING (ptr->xname)))
+ MARK_STRING (XSTRING (ptr->xname));
+ MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
+
/* Note that we do not mark the obarray of the symbol.
It is safe not to do so because nothing accesses that
slot except to check whether it is nil. */
ptr = ptr->next;
if (ptr)
{
- /* For the benefit of the last_marked log. */
- objptr = (Lisp_Object *)&XSYMBOL (obj)->next;
ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */
XSETSYMBOL (obj, ptrx);
- /* We can't goto loop here because *objptr doesn't contain an
- actual Lisp_Object with valid datatype field. */
- goto loop2;
+ goto loop;
}
}
break;
case Lisp_Misc:
CHECK_ALLOCATED_AND_LIVE (live_misc_p);
+ if (XMARKER (obj)->gcmarkbit)
+ break;
+ XMARKER (obj)->gcmarkbit = 1;
switch (XMISCTYPE (obj))
{
- case Lisp_Misc_Marker:
- XMARK (XMARKER (obj)->chain);
- /* DO NOT mark thru the marker's chain.
- The buffer's markers chain does not preserve markers from gc;
- instead, markers are removed from the chain when freed by gc. */
- break;
-
case Lisp_Misc_Buffer_Local_Value:
case Lisp_Misc_Some_Buffer_Local_Value:
{
register struct Lisp_Buffer_Local_Value *ptr
= XBUFFER_LOCAL_VALUE (obj);
- if (XMARKBIT (ptr->realvalue)) break;
- XMARK (ptr->realvalue);
/* If the cdr is nil, avoid recursion for the car. */
if (EQ (ptr->cdr, Qnil))
{
- objptr = &ptr->realvalue;
+ obj = ptr->realvalue;
goto loop;
}
- mark_object (&ptr->realvalue);
- mark_object (&ptr->buffer);
- mark_object (&ptr->frame);
- objptr = &ptr->cdr;
+ mark_object (ptr->realvalue);
+ mark_object (ptr->buffer);
+ mark_object (ptr->frame);
+ obj = ptr->cdr;
goto loop;
}
+ case Lisp_Misc_Marker:
+ /* DO NOT mark thru the marker's chain.
+ The buffer's markers chain does not preserve markers from gc;
+ instead, markers are removed from the chain when freed by gc. */
case Lisp_Misc_Intfwd:
case Lisp_Misc_Boolfwd:
case Lisp_Misc_Objfwd:
since all markable slots in current buffer marked anyway. */
/* Don't need to do Lisp_Objfwd, since the places they point
are protected with staticpro. */
+ case Lisp_Misc_Save_Value:
break;
case Lisp_Misc_Overlay:
{
struct Lisp_Overlay *ptr = XOVERLAY (obj);
- if (!XMARKBIT (ptr->plist))
+ mark_object (ptr->start);
+ mark_object (ptr->end);
+ mark_object (ptr->plist);
+ if (ptr->next)
{
- XMARK (ptr->plist);
- mark_object (&ptr->start);
- mark_object (&ptr->end);
- objptr = &ptr->plist;
+ XSETMISC (obj, ptr->next);
goto loop;
}
}
case Lisp_Cons:
{
register struct Lisp_Cons *ptr = XCONS (obj);
- if (XMARKBIT (ptr->car)) break;
+ if (CONS_MARKED_P (ptr)) break;
CHECK_ALLOCATED_AND_LIVE (live_cons_p);
- XMARK (ptr->car);
+ CONS_MARK (ptr);
/* If the cdr is nil, avoid recursion for the car. */
if (EQ (ptr->cdr, Qnil))
{
- objptr = &ptr->car;
+ obj = ptr->car;
+ cdr_count = 0;
goto loop;
}
- mark_object (&ptr->car);
- objptr = &ptr->cdr;
+ mark_object (ptr->car);
+ obj = ptr->cdr;
+ cdr_count++;
+ if (cdr_count == mark_object_loop_halt)
+ abort ();
goto loop;
}
case Lisp_Float:
CHECK_ALLOCATED_AND_LIVE (live_float_p);
- XMARK (XFLOAT (obj)->type);
+ FLOAT_MARK (XFLOAT (obj));
break;
case Lisp_Int:
Lisp_Object buf;
{
register struct buffer *buffer = XBUFFER (buf);
- register Lisp_Object *ptr;
+ register Lisp_Object *ptr, tmp;
Lisp_Object base_buffer;
- /* This is the buffer's markbit */
- mark_object (&buffer->name);
- XMARK (buffer->name);
+ VECTOR_MARK (buffer);
MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
Lisp_Object tail;
tail = buffer->undo_list;
+ /* We mark the undo list specially because
+ its pointers to markers should be weak. */
+
while (CONSP (tail))
{
register struct Lisp_Cons *ptr = XCONS (tail);
- if (XMARKBIT (ptr->car))
+ if (CONS_MARKED_P (ptr))
break;
- XMARK (ptr->car);
+ CONS_MARK (ptr);
if (GC_CONSP (ptr->car)
- && ! XMARKBIT (XCAR (ptr->car))
+ && !CONS_MARKED_P (XCONS (ptr->car))
&& GC_MARKERP (XCAR (ptr->car)))
{
- XMARK (XCAR_AS_LVALUE (ptr->car));
- mark_object (&XCDR_AS_LVALUE (ptr->car));
+ CONS_MARK (XCONS (ptr->car));
+ mark_object (XCDR (ptr->car));
}
else
- mark_object (&ptr->car);
+ mark_object (ptr->car);
if (CONSP (ptr->cdr))
tail = ptr->cdr;
break;
}
- mark_object (&XCDR_AS_LVALUE (tail));
+ mark_object (XCDR (tail));
}
else
- mark_object (&buffer->undo_list);
+ mark_object (buffer->undo_list);
- for (ptr = &buffer->name + 1;
+ if (buffer->overlays_before)
+ {
+ XSETMISC (tmp, buffer->overlays_before);
+ mark_object (tmp);
+ }
+ if (buffer->overlays_after)
+ {
+ XSETMISC (tmp, buffer->overlays_after);
+ mark_object (tmp);
+ }
+
+ for (ptr = &buffer->name;
(char *)ptr < (char *)buffer + sizeof (struct buffer);
ptr++)
- mark_object (ptr);
+ mark_object (*ptr);
/* If this is an indirect buffer, mark its base buffer. */
- if (buffer->base_buffer && !XMARKBIT (buffer->base_buffer->name))
+ if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
{
- XSETBUFFER (base_buffer, buffer->base_buffer);
+ XSETBUFFER (base_buffer, buffer->base_buffer);
mark_buffer (base_buffer);
}
}
-/* Mark the pointers in the kboard objects. */
-
-static void
-mark_kboards ()
-{
- KBOARD *kb;
- Lisp_Object *p;
- for (kb = all_kboards; kb; kb = kb->next_kboard)
- {
- if (kb->kbd_macro_buffer)
- for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++)
- mark_object (p);
- mark_object (&kb->Voverriding_terminal_local_map);
- mark_object (&kb->Vlast_command);
- mark_object (&kb->Vreal_last_command);
- mark_object (&kb->Vprefix_arg);
- mark_object (&kb->Vlast_prefix_arg);
- mark_object (&kb->kbd_queue);
- mark_object (&kb->defining_kbd_macro);
- mark_object (&kb->Vlast_kbd_macro);
- mark_object (&kb->Vsystem_key_alist);
- mark_object (&kb->system_key_syms);
- mark_object (&kb->Vdefault_minibuffer_frame);
- }
-}
-
-
/* Value is non-zero if OBJ will survive the current GC because it's
either marked or does not need to be marked to survive. */
Lisp_Object obj;
{
int survives_p;
-
+
switch (XGCTYPE (obj))
{
case Lisp_Int:
break;
case Lisp_Symbol:
- survives_p = XMARKBIT (XSYMBOL (obj)->plist);
+ survives_p = XSYMBOL (obj)->gcmarkbit;
break;
case Lisp_Misc:
- switch (XMISCTYPE (obj))
- {
- case Lisp_Misc_Marker:
- survives_p = XMARKBIT (obj);
- break;
-
- case Lisp_Misc_Buffer_Local_Value:
- case Lisp_Misc_Some_Buffer_Local_Value:
- survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
- break;
-
- case Lisp_Misc_Intfwd:
- case Lisp_Misc_Boolfwd:
- case Lisp_Misc_Objfwd:
- case Lisp_Misc_Buffer_Objfwd:
- case Lisp_Misc_Kboard_Objfwd:
- survives_p = 1;
- break;
-
- case Lisp_Misc_Overlay:
- survives_p = XMARKBIT (XOVERLAY (obj)->plist);
- break;
-
- default:
- abort ();
- }
+ survives_p = XMARKER (obj)->gcmarkbit;
break;
case Lisp_String:
- {
- struct Lisp_String *s = XSTRING (obj);
- survives_p = STRING_MARKED_P (s);
- }
+ survives_p = STRING_MARKED_P (XSTRING (obj));
break;
case Lisp_Vectorlike:
- if (GC_BUFFERP (obj))
- survives_p = XMARKBIT (XBUFFER (obj)->name);
- else if (GC_SUBRP (obj))
- survives_p = 1;
- else
- survives_p = XVECTOR (obj)->size & ARRAY_MARK_FLAG;
+ survives_p = GC_SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
break;
case Lisp_Cons:
- survives_p = XMARKBIT (XCAR (obj));
+ survives_p = CONS_MARKED_P (XCONS (obj));
break;
case Lisp_Float:
- survives_p = XMARKBIT (XFLOAT (obj)->type);
+ survives_p = FLOAT_MARKED_P (XFLOAT (obj));
break;
default:
register int num_free = 0, num_used = 0;
cons_free_list = 0;
-
+
for (cblk = cons_block; cblk; cblk = *cprev)
{
register int i;
int this_free = 0;
for (i = 0; i < lim; i++)
- if (!XMARKBIT (cblk->conses[i].car))
+ if (!CONS_MARKED_P (&cblk->conses[i]))
{
this_free++;
*(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
else
{
num_used++;
- XUNMARK (cblk->conses[i].car);
+ CONS_UNMARK (&cblk->conses[i]);
}
lim = CONS_BLOCK_SIZE;
/* If this block contains only free conses and we have already
*cprev = cblk->next;
/* Unhook from the free list. */
cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr;
- lisp_free (cblk);
+ lisp_align_free (cblk);
n_cons_blocks--;
}
else
register int num_free = 0, num_used = 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 (!XMARKBIT (fblk->floats[i].type))
+ if (!FLOAT_MARKED_P (&fblk->floats[i]))
{
this_free++;
*(struct Lisp_Float **)&fblk->floats[i].data = float_free_list;
float_free_list = &fblk->floats[i];
-#if GC_MARK_STACK
- float_free_list->type = Vdead;
-#endif
}
else
{
num_used++;
- XUNMARK (fblk->floats[i].type);
+ FLOAT_UNMARK (&fblk->floats[i]);
}
lim = FLOAT_BLOCK_SIZE;
/* If this block contains only free floats and we have already
*fprev = fblk->next;
/* Unhook from the free list. */
float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data;
- lisp_free (fblk);
+ lisp_align_free (fblk);
n_float_blocks--;
}
else
for (i = 0; i < lim; i++)
{
- if (! XMARKBIT (iblk->intervals[i].plist))
+ if (!iblk->intervals[i].gcmarkbit)
{
SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
interval_free_list = &iblk->intervals[i];
else
{
num_used++;
- XUNMARK (iblk->intervals[i].plist);
+ iblk->intervals[i].gcmarkbit = 0;
}
}
lim = INTERVAL_BLOCK_SIZE;
register int num_free = 0, num_used = 0;
symbol_free_list = NULL;
-
+
for (sblk = symbol_block; sblk; sblk = *sprev)
{
int this_free = 0;
/* 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 (sym->name);
-
- if (!XMARKBIT (sym->plist) && !pure_p)
+ int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
+
+ if (!sym->gcmarkbit && !pure_p)
{
*(struct Lisp_Symbol **) &sym->value = symbol_free_list;
symbol_free_list = sym;
{
++num_used;
if (!pure_p)
- UNMARK_STRING (sym->name);
- XUNMARK (sym->plist);
+ UNMARK_STRING (XSTRING (sym->xname));
+ sym->gcmarkbit = 0;
}
}
-
+
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
register int num_free = 0, num_used = 0;
marker_free_list = 0;
-
+
for (mblk = marker_block; mblk; mblk = *mprev)
{
register int i;
int this_free = 0;
- EMACS_INT already_free = -1;
for (i = 0; i < lim; i++)
{
- Lisp_Object *markword;
- switch (mblk->markers[i].u_marker.type)
- {
- case Lisp_Misc_Marker:
- markword = &mblk->markers[i].u_marker.chain;
- break;
- case Lisp_Misc_Buffer_Local_Value:
- case Lisp_Misc_Some_Buffer_Local_Value:
- markword = &mblk->markers[i].u_buffer_local_value.realvalue;
- break;
- case Lisp_Misc_Overlay:
- markword = &mblk->markers[i].u_overlay.plist;
- break;
- case Lisp_Misc_Free:
- /* If the object was already free, keep it
- on the free list. */
- markword = (Lisp_Object *) &already_free;
- break;
- default:
- markword = 0;
- break;
- }
- if (markword && !XMARKBIT (*markword))
+ if (!mblk->markers[i].u_marker.gcmarkbit)
{
- Lisp_Object tem;
if (mblk->markers[i].u_marker.type == Lisp_Misc_Marker)
- {
- /* tem1 avoids Sun compiler bug */
- struct Lisp_Marker *tem1 = &mblk->markers[i].u_marker;
- XSETMARKER (tem, tem1);
- unchain_marker (tem);
- }
+ unchain_marker (&mblk->markers[i].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. */
else
{
num_used++;
- if (markword)
- XUNMARK (*markword);
+ mblk->markers[i].u_marker.gcmarkbit = 0;
}
}
lim = MARKER_BLOCK_SIZE;
register struct buffer *buffer = all_buffers, *prev = 0, *next;
while (buffer)
- if (!XMARKBIT (buffer->name))
+ if (!VECTOR_MARKED_P (buffer))
{
if (prev)
prev->next = buffer->next;
}
else
{
- XUNMARK (buffer->name);
+ VECTOR_UNMARK (buffer);
UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
prev = buffer, buffer = buffer->next;
}
total_vector_size = 0;
while (vector)
- if (!(vector->size & ARRAY_MARK_FLAG))
+ if (!VECTOR_MARKED_P (vector))
{
if (prev)
prev->next = vector->next;
}
else
{
- vector->size &= ~ARRAY_MARK_FLAG;
+ VECTOR_UNMARK (vector);
if (vector->size & PSEUDOVECTOR_FLAG)
total_vector_size += (PSEUDOVECTOR_SIZE_MASK & vector->size);
else
prev = vector, vector = vector->next;
}
}
-
+
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive)
check_string_bytes (1);
pure_bytes_used = 0;
pure_bytes_used_before_overflow = 0;
+ /* Initialize the list of free aligned blocks. */
+ free_ablock = NULL;
+
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
mem_init ();
Vdead = make_pure_string ("DEAD", 4, 4, 0);
setjmp_tested_p = longjmps_done = 0;
#endif
#endif
+ Vgc_elapsed = make_float (0.0);
+ gcs_done = 0;
}
void
Qpost_gc_hook = intern ("post-gc-hook");
staticpro (&Qpost_gc_hook);
+ DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
+ doc: /* Precomputed `signal' argument for memory-full error. */);
/* We build this in advance because if we wait until we need it, we might
not be able to allocate the memory to hold it. */
- memory_signal_data
- = Fcons (Qerror, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil));
- staticpro (&memory_signal_data);
+ Vmemory_signal_data
+ = list2 (Qerror,
+ build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
+
+ DEFVAR_LISP ("memory-full", &Vmemory_full,
+ doc: /* Non-nil means we are handling a memory-full error. */);
+ Vmemory_full = Qnil;
staticpro (&Qgc_cons_threshold);
Qgc_cons_threshold = intern ("gc-cons-threshold");
staticpro (&Qchar_table_extra_slots);
Qchar_table_extra_slots = intern ("char-table-extra-slots");
+ DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
+ doc: /* Accumulated time elapsed in garbage collections.
+The time is in seconds as a floating point value. */);
+ DEFVAR_INT ("gcs-done", &gcs_done,
+ doc: /* Accumulated number of garbage collections done. */);
+
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);