/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985,86,88,93,94,95,97,98,1999,2000,01,02,03,2004
- Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
+ 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <signal.h>
+#ifdef HAVE_GTK_AND_PTHREAD
+#include <pthread.h>
+#endif
+
/* This file is part of the core Lisp implementation, and thus must
deal with the real data structures. If the Lisp implementation is
replaced, this file likely will not be used. */
#endif /* not DOUG_LEA_MALLOC */
+#if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
+
+static pthread_mutex_t alloc_mutex;
+pthread_t main_thread;
+
+#define BLOCK_INPUT_ALLOC \
+ do \
+ { \
+ pthread_mutex_lock (&alloc_mutex); \
+ if (pthread_self () == main_thread) \
+ BLOCK_INPUT; \
+ } \
+ while (0)
+#define UNBLOCK_INPUT_ALLOC \
+ do \
+ { \
+ if (pthread_self () == main_thread) \
+ UNBLOCK_INPUT; \
+ pthread_mutex_unlock (&alloc_mutex); \
+ } \
+ while (0)
+
+#else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
+
+#define BLOCK_INPUT_ALLOC BLOCK_INPUT
+#define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
+
+#endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
+
/* Value of _bytes_used, when spare_memory was freed. */
static __malloc_size_t bytes_used_when_full;
EMACS_INT undo_limit;
EMACS_INT undo_strong_limit;
+EMACS_INT undo_outer_limit;
/* Number of live and free conses etc. */
#ifndef HAVE_SHM
-/* Force it into data space! Initialize it to a nonzero value;
- otherwise some compilers put it into BSS. */
+/* Initialize it to a nonzero value to force it into data space
+ (rather than bss space). That way unexec will remap it into text
+ space (pure), on some systems. We have not implemented the
+ remapping on more recent systems because this is less important
+ nowadays than in the days of small memories and timesharing. */
EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {1,};
#define PUREBEG (char *) pure
static void mark_buffer P_ ((Lisp_Object));
extern void mark_kboards P_ ((void));
+extern void mark_backtrace 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 *));
}
+#ifdef XMALLOC_OVERRUN_CHECK
+
+/* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
+ and a 16 byte trailer around each block.
+
+ The header consists of 12 fixed bytes + a 4 byte integer contaning the
+ original block size, while the trailer consists of 16 fixed bytes.
+
+ The header is used to detect whether this block has been allocated
+ through these functions -- as it seems that some low-level libc
+ functions may bypass the malloc hooks.
+*/
+
+
+#define XMALLOC_OVERRUN_CHECK_SIZE 16
+
+static char xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE-4] =
+ { 0x9a, 0x9b, 0xae, 0xaf,
+ 0xbf, 0xbe, 0xce, 0xcf,
+ 0xea, 0xeb, 0xec, 0xed };
+
+static char xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
+ { 0xaa, 0xab, 0xac, 0xad,
+ 0xba, 0xbb, 0xbc, 0xbd,
+ 0xca, 0xcb, 0xcc, 0xcd,
+ 0xda, 0xdb, 0xdc, 0xdd };
+
+/* Macros to insert and extract the block size in the header. */
+
+#define XMALLOC_PUT_SIZE(ptr, size) \
+ (ptr[-1] = (size & 0xff), \
+ ptr[-2] = ((size >> 8) & 0xff), \
+ ptr[-3] = ((size >> 16) & 0xff), \
+ ptr[-4] = ((size >> 24) & 0xff))
+
+#define XMALLOC_GET_SIZE(ptr) \
+ (size_t)((unsigned)(ptr[-1]) | \
+ ((unsigned)(ptr[-2]) << 8) | \
+ ((unsigned)(ptr[-3]) << 16) | \
+ ((unsigned)(ptr[-4]) << 24))
+
+
+/* Like malloc, but wraps allocated block with header and trailer. */
+
+POINTER_TYPE *
+overrun_check_malloc (size)
+ size_t size;
+{
+ register unsigned char *val;
+
+ val = (unsigned char *) malloc (size + XMALLOC_OVERRUN_CHECK_SIZE*2);
+ if (val)
+ {
+ bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
+ val += XMALLOC_OVERRUN_CHECK_SIZE;
+ XMALLOC_PUT_SIZE(val, size);
+ bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
+ }
+ return (POINTER_TYPE *)val;
+}
+
+
+/* Like realloc, but checks old block for overrun, and wraps new block
+ with header and trailer. */
+
+POINTER_TYPE *
+overrun_check_realloc (block, size)
+ POINTER_TYPE *block;
+ size_t size;
+{
+ register unsigned char *val = (unsigned char *)block;
+
+ if (val
+ && bcmp (xmalloc_overrun_check_header,
+ val - XMALLOC_OVERRUN_CHECK_SIZE,
+ XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
+ {
+ size_t osize = XMALLOC_GET_SIZE (val);
+ if (bcmp (xmalloc_overrun_check_trailer,
+ val + osize,
+ XMALLOC_OVERRUN_CHECK_SIZE))
+ abort ();
+ bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
+ val -= XMALLOC_OVERRUN_CHECK_SIZE;
+ bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
+ }
+
+ val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + XMALLOC_OVERRUN_CHECK_SIZE*2);
+
+ if (val)
+ {
+ bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
+ val += XMALLOC_OVERRUN_CHECK_SIZE;
+ XMALLOC_PUT_SIZE(val, size);
+ bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
+ }
+ return (POINTER_TYPE *)val;
+}
+
+/* Like free, but checks block for overrun. */
+
+void
+overrun_check_free (block)
+ POINTER_TYPE *block;
+{
+ unsigned char *val = (unsigned char *)block;
+
+ if (val
+ && bcmp (xmalloc_overrun_check_header,
+ val - XMALLOC_OVERRUN_CHECK_SIZE,
+ XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
+ {
+ size_t osize = XMALLOC_GET_SIZE (val);
+ if (bcmp (xmalloc_overrun_check_trailer,
+ val + osize,
+ XMALLOC_OVERRUN_CHECK_SIZE))
+ abort ();
+ bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
+ val -= XMALLOC_OVERRUN_CHECK_SIZE;
+ bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
+ }
+
+ free (val);
+}
+
+#undef malloc
+#undef realloc
+#undef free
+#define malloc overrun_check_malloc
+#define realloc overrun_check_realloc
+#define free overrun_check_free
+#endif
+
+
/* Like malloc but check for no memory and block interrupt input.. */
POINTER_TYPE *
}
+/* Unwind for SAFE_ALLOCA */
+
+Lisp_Object
+safe_alloca_unwind (arg)
+ Lisp_Object arg;
+{
+ register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);
+
+ p->dogc = 0;
+ xfree (p->pointer);
+ p->pointer = 0;
+ free_misc (arg);
+ return Qnil;
+}
+
+
/* 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, ...). */
+#ifndef USE_LSB_TAG
static void *lisp_malloc_loser;
+#endif
static POINTER_TYPE *
lisp_malloc (nbytes, type)
val = (void *) malloc (nbytes);
+#ifndef USE_LSB_TAG
/* 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. */
val = 0;
}
}
+#endif
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
if (val && type != MEM_TYPE_NON_LISP)
#ifdef HAVE_POSIX_MEMALIGN
{
int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
- abase = err ? (base = NULL) : base;
+ if (err)
+ base = NULL;
+ abase = base;
}
#else
base = malloc (ABLOCKS_BYTES);
abase = ALIGN (base, BLOCK_ALIGN);
+#endif
+
if (base == 0)
{
UNBLOCK_INPUT;
memory_full ();
}
-#endif
aligned = (base == abase);
if (!aligned)
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
+#ifndef USE_LSB_TAG
/* 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. */
memory_full ();
}
}
+#endif
/* Initialize the blocks and put them on the free list.
Is `base' was not properly aligned, we can't use the last block. */
free_ablock = ablock;
/* Update busy count. */
ABLOCKS_BUSY (abase) = (struct ablocks *) (-2 + (long) ABLOCKS_BUSY (abase));
-
+
if (2 > (long) ABLOCKS_BUSY (abase))
{ /* All the blocks are free. */
int i = 0, aligned = (long) ABLOCKS_BUSY (abase);
emacs_blocked_free (ptr)
void *ptr;
{
- BLOCK_INPUT;
+ BLOCK_INPUT_ALLOC;
#ifdef GC_MALLOC_CHECK
if (ptr)
spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
__free_hook = emacs_blocked_free;
- UNBLOCK_INPUT;
+ UNBLOCK_INPUT_ALLOC;
}
{
void *value;
- BLOCK_INPUT;
+ BLOCK_INPUT_ALLOC;
__malloc_hook = old_malloc_hook;
#ifdef DOUG_LEA_MALLOC
mallopt (M_TOP_PAD, malloc_hysteresis * 4096);
#endif /* GC_MALLOC_CHECK */
__malloc_hook = emacs_blocked_malloc;
- UNBLOCK_INPUT;
+ UNBLOCK_INPUT_ALLOC;
/* fprintf (stderr, "%p malloc\n", value); */
return value;
{
void *value;
- BLOCK_INPUT;
+ BLOCK_INPUT_ALLOC;
__realloc_hook = old_realloc_hook;
#ifdef GC_MALLOC_CHECK
#endif /* GC_MALLOC_CHECK */
__realloc_hook = emacs_blocked_realloc;
- UNBLOCK_INPUT;
+ UNBLOCK_INPUT_ALLOC;
return value;
}
+#ifdef HAVE_GTK_AND_PTHREAD
+/* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
+ normal malloc. Some thread implementations need this as they call
+ malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
+ calls malloc because it is the first call, and we have an endless loop. */
+
+void
+reset_malloc_hooks ()
+{
+ __free_hook = 0;
+ __malloc_hook = 0;
+ __realloc_hook = 0;
+}
+#endif /* HAVE_GTK_AND_PTHREAD */
+
+
/* Called from main to set up malloc to use our hooks. */
void
uninterrupt_malloc ()
{
+#ifdef HAVE_GTK_AND_PTHREAD
+ pthread_mutexattr_t attr;
+
+ /* GLIBC has a faster way to do this, but lets keep it portable.
+ This is according to the Single UNIX Specification. */
+ pthread_mutexattr_init (&attr);
+ pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
+ pthread_mutex_init (&alloc_mutex, &attr);
+
+ main_thread = pthread_self ();
+#endif /* HAVE_GTK_AND_PTHREAD */
+
if (__free_hook != emacs_blocked_free)
old_free_hook = __free_hook;
__free_hook = emacs_blocked_free;
#endif /* not GC_CHECK_STRING_BYTES */
+
+#ifdef GC_CHECK_STRING_OVERRUN
+
+/* We check for overrun in string data blocks by appending a small
+ "cookie" after each allocated string data block, and check for the
+ presense of this cookie during GC. */
+
+#define GC_STRING_OVERRUN_COOKIE_SIZE 4
+static char string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
+ { 0xde, 0xad, 0xbe, 0xef };
+
+#else
+#define GC_STRING_OVERRUN_COOKIE_SIZE 0
+#endif
+
/* Value is the size of an sdata structure large enough to hold NBYTES
bytes of string data. The value returned includes a terminating
NUL byte, the size of the sdata structure, and padding. */
#endif /* not GC_CHECK_STRING_BYTES */
+/* Extra bytes to allocate for each string. */
+
+#define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
+
/* Initialize string allocation. Called from init_alloc_once. */
void
nbytes = SDATA_NBYTES (from);
nbytes = SDATA_SIZE (nbytes);
- from_end = (struct sdata *) ((char *) from + nbytes);
+ from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
}
}
#endif /* GC_CHECK_STRING_BYTES */
+#ifdef GC_CHECK_STRING_FREE_LIST
+
+/* Walk through the string free list looking for bogus next pointers.
+ This may catch buffer overrun from a previous string. */
+
+static void
+check_string_free_list ()
+{
+ struct Lisp_String *s;
+
+ /* Pop a Lisp_String off the free-list. */
+ s = string_free_list;
+ while (s != NULL)
+ {
+ if ((unsigned)s < 1024)
+ abort();
+ s = NEXT_FREE_LISP_STRING (s);
+ }
+}
+#else
+#define check_string_free_list()
+#endif
/* Return a new Lisp_String. */
total_free_strings += STRING_BLOCK_SIZE;
}
+ check_string_free_list ();
+
/* Pop a Lisp_String off the free-list. */
s = string_free_list;
string_free_list = NEXT_FREE_LISP_STRING (s);
mallopt (M_MMAP_MAX, 0);
#endif
- b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP);
+ b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
else if (current_sblock == NULL
|| (((char *) current_sblock + SBLOCK_SIZE
- (char *) current_sblock->next_free)
- < needed))
+ < (needed + GC_STRING_EXTRA)))
{
/* Not enough room in the current sblock. */
b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
s->size = nchars;
s->size_byte = nbytes;
s->data[nbytes] = '\0';
- b->next_free = (struct sdata *) ((char *) data + needed);
+#ifdef GC_CHECK_STRING_OVERRUN
+ bcopy (string_overrun_cookie, (char *) data + needed,
+ GC_STRING_OVERRUN_COOKIE_SIZE);
+#endif
+ b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
/* 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
}
}
+ check_string_free_list ();
+
string_blocks = live_blocks;
free_large_strings ();
compact_small_strings ();
+
+ check_string_free_list ();
}
else
nbytes = SDATA_NBYTES (from);
+ if (nbytes > LARGE_STRING_BYTES)
+ abort ();
+
nbytes = SDATA_SIZE (nbytes);
- from_end = (struct sdata *) ((char *) from + nbytes);
+ from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
+
+#ifdef GC_CHECK_STRING_OVERRUN
+ if (bcmp (string_overrun_cookie,
+ ((char *) from_end) - GC_STRING_OVERRUN_COOKIE_SIZE,
+ GC_STRING_OVERRUN_COOKIE_SIZE))
+ abort ();
+#endif
/* FROM->string non-null means it's alive. Copy its data. */
if (from->string)
{
/* If TB is full, proceed with the next sblock. */
- to_end = (struct sdata *) ((char *) to + nbytes);
+ to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
if (to_end > tb_end)
{
tb->next_free = to;
tb = tb->next;
tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
to = &tb->first_data;
- to_end = (struct sdata *) ((char *) to + nbytes);
+ to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
}
/* Copy, and update the string's `data' pointer. */
if (from != to)
{
xassert (tb != b || to <= from);
- safe_bcopy ((char *) from, (char *) to, nbytes);
+ safe_bcopy ((char *) from, (char *) to, nbytes + GC_STRING_EXTRA);
to->string->data = SDATA_DATA (to);
}
DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
- doc: /* Return a newly created string of length LENGTH, with each element being INIT.
-Both LENGTH and INIT must be numbers. */)
+ doc: /* Return a newly created string of length LENGTH, with INIT in each element.
+LENGTH must be an integer.
+INIT must be an integer that represents a character. */)
(length, init)
Lisp_Object length, init;
{
CHECK_NATNUM (length);
- bits_per_value = sizeof (EMACS_INT) * BITS_PER_CHAR;
+ bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
- length_in_chars = ((XFASTINT (length) + BITS_PER_CHAR - 1) / BITS_PER_CHAR);
+ length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
+ / BOOL_VECTOR_BITS_PER_CHAR);
/* We must allocate one more elements than LENGTH_IN_ELTS for the
slot `size' of the struct Lisp_Bool_Vector. */
p->data[i] = real_init;
/* Clear the extraneous bits in the last byte. */
- if (XINT (length) != length_in_chars * BITS_PER_CHAR)
+ if (XINT (length) != length_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
XBOOL_VECTOR (val)->data[length_in_chars - 1]
- &= (1 << (XINT (length) % BITS_PER_CHAR)) - 1;
+ &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
return val;
}
cons_free_list = ptr;
}
-
DEFUN ("cons", Fcons, Scons, 2, 2, 0,
doc: /* Create a new cons, give it CAR and CDR as components, and return it. */)
(car, cdr)
return val;
}
+/* Get an error now if there's any junk in the cons free list. */
+void
+check_cons_list ()
+{
+#ifdef GC_CHECK_CONS_LIST
+ struct Lisp_Cons *tail = cons_free_list;
+
+ while (tail)
+ tail = *(struct Lisp_Cons **)&tail->cdr;
+#endif
+}
/* Make a list of 2, 3, 4 or 5 specified objects. */
marker_block = new;
marker_block_index = 0;
n_marker_blocks++;
+ total_free_markers += MARKER_BLOCK_SIZE;
}
XSETMISC (val, &marker_block->markers[marker_block_index]);
marker_block_index++;
}
+ --total_free_markers;
consing_since_gc += sizeof (union Lisp_Misc);
misc_objects_consed++;
XMARKER (val)->gcmarkbit = 0;
return val;
}
+/* Free a Lisp_Misc object */
+
+void
+free_misc (misc)
+ Lisp_Object misc;
+{
+ XMISC (misc)->u_marker.type = Lisp_Misc_Free;
+ XMISC (misc)->u_free.chain = marker_free_list;
+ marker_free_list = XMISC (misc);
+
+ total_free_markers++;
+}
+
/* 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. */
p = XSAVE_VALUE (val);
p->pointer = pointer;
p->integer = integer;
+ p->dogc = 0;
return val;
}
Lisp_Object marker;
{
unchain_marker (XMARKER (marker));
-
- XMISC (marker)->u_marker.type = Lisp_Misc_Free;
- XMISC (marker)->u_free.chain = marker_free_list;
- marker_free_list = XMISC (marker);
-
- total_free_markers++;
+ free_misc (marker);
}
\f
#endif
for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
mark_memory ((char *) stack_base + i, end);
+ /* Allow for marking a secondary stack, like the register stack on the
+ ia64. */
+#ifdef GC_MARK_SECONDARY_STACK
+ GC_MARK_SECONDARY_STACK ();
+#endif
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
check_gcpros ();
int type;
{
POINTER_TYPE *result;
+#ifdef USE_LSB_TAG
+ size_t alignment = (1 << GCTYPEBITS);
+#else
size_t alignment = sizeof (EMACS_INT);
/* Give Lisp_Floats an extra alignment. */
alignment = sizeof (struct Lisp_Float);
#endif
}
+#endif
again:
result = ALIGN (purebeg + pure_bytes_used, alignment);
else if (COMPILEDP (obj) || VECTORP (obj))
{
register struct Lisp_Vector *vec;
- register int i, size;
+ register int i;
+ EMACS_INT size;
size = XVECTOR (obj)->size;
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
- vec = XVECTOR (make_pure_vector ((EMACS_INT) size));
+ vec = XVECTOR (make_pure_vector (size));
for (i = 0; i < size; i++)
vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
if (COMPILEDP (obj))
struct catchtag *next;
};
-struct backtrace
-{
- struct backtrace *next;
- Lisp_Object *function;
- Lisp_Object *args; /* Points to vector of args. */
- int nargs; /* Length of vector. */
- /* If nargs is UNEVALLED, args points to slot holding list of
- unevalled args. */
- char evalargs;
-};
-
-
\f
/***********************************************************************
Protection from GC
register struct specbinding *bind;
struct catchtag *catch;
struct handler *handler;
- register struct backtrace *backlist;
char stack_top_variable;
register int i;
int message_p;
if (! EQ (nextb->undo_list, Qt))
nextb->undo_list
= truncate_undo_list (nextb->undo_list, undo_limit,
- undo_strong_limit);
+ undo_strong_limit, undo_outer_limit);
/* Shrink buffer gaps, but skip indirect and dead buffers. */
if (nextb->base_buffer == 0 && !NILP (nextb->name))
for (i = 0; i < staticidx; i++)
mark_object (*staticvec[i]);
+ for (bind = specpdl; bind != specpdl_ptr; bind++)
+ {
+ mark_object (bind->symbol);
+ mark_object (bind->old_value);
+ }
+ mark_kboards ();
+
+#ifdef USE_GTK
+ {
+ extern void xg_mark_data ();
+ xg_mark_data ();
+ }
+#endif
+
#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
|| GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
mark_stack ();
#endif
mark_byte_stack ();
- for (bind = specpdl; bind != specpdl_ptr; bind++)
- {
- mark_object (bind->symbol);
- mark_object (bind->old_value);
- }
for (catch = catchlist; catch; catch = catch->next)
{
mark_object (catch->tag);
mark_object (handler->handler);
mark_object (handler->var);
}
- for (backlist = backtrace_list; backlist; backlist = backlist->next)
- {
- mark_object (*backlist->function);
+ mark_backtrace ();
- if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
- i = 0;
- else
- i = backlist->nargs - 1;
- for (; i >= 0; i--)
- mark_object (backlist->args[i]);
- }
- mark_kboards ();
+#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
+ mark_stack ();
+#endif
- /* Look thru every buffer's undo list
+ /* Everything is now marked, except for the things that require special
+ finalization, i.e. the undo_list.
+ Look thru every buffer's undo list
for elements that update markers that were not marked,
and delete them. */
{
}
}
}
+ /* Now that we have stripped the elements that need not be in the
+ undo_list any more, we can finally mark the list. */
+ mark_object (nextb->undo_list);
nextb = nextb->next;
}
}
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- 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 (XMARKER (obj)->gcmarkbit)
break;
XMARKER (obj)->gcmarkbit = 1;
+
switch (XMISCTYPE (obj))
{
case Lisp_Misc_Buffer_Local_Value:
/* 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_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. */
+ break;
+
case Lisp_Misc_Save_Value:
+#if GC_MARK_STACK
+ {
+ register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
+ /* If DOGC is set, POINTER is the address of a memory
+ area containing INTEGER potential Lisp_Objects. */
+ if (ptr->dogc)
+ {
+ Lisp_Object *p = (Lisp_Object *) ptr->pointer;
+ int nelt;
+ for (nelt = ptr->integer; nelt > 0; nelt--, p++)
+ mark_maybe_object (*p);
+ }
+ }
+#endif
break;
case Lisp_Misc_Overlay:
MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
- if (CONSP (buffer->undo_list))
- {
- 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 (CONS_MARKED_P (ptr))
- break;
- CONS_MARK (ptr);
- if (GC_CONSP (ptr->car)
- && !CONS_MARKED_P (XCONS (ptr->car))
- && GC_MARKERP (XCAR (ptr->car)))
- {
- CONS_MARK (XCONS (ptr->car));
- mark_object (XCDR (ptr->car));
- }
- else
- mark_object (ptr->car);
-
- if (CONSP (ptr->cdr))
- tail = ptr->cdr;
- else
- break;
- }
-
- mark_object (XCDR (tail));
- }
- else
- mark_object (buffer->undo_list);
+ /* For now, we just don't mark the undo_list. It's done later in
+ a special way just before the sweep phase, and after stripping
+ some of its elements that are not needed any more. */
if (buffer->overlays_before)
{
DEFVAR_INT ("undo-strong-limit", &undo_strong_limit,
doc: /* Don't keep more than this much size of undo information.
-A command which pushes past this size is itself forgotten.
-This limit is applied when garbage collection happens.
+A previous command which pushes the undo list past this size
+is entirely forgotten when GC happens.
The size is counted as the number of bytes occupied,
which includes both saved text and other data. */);
undo_strong_limit = 30000;
+ DEFVAR_INT ("undo-outer-limit", &undo_outer_limit,
+ doc: /* Don't keep more than this much size of undo information.
+If the current command has produced more than this much undo information,
+GC discards it. This is a last-ditch limit to prevent memory overflow.
+The size is counted as the number of bytes occupied,
+which includes both saved text and other data. */);
+ undo_outer_limit = 300000;
+
DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
doc: /* Non-nil means display messages at start and end of garbage collection. */);
garbage_collection_messages = 0;
HCoop / bpt / emacs.git / blobdiff