/* 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)
+
+/* When GTK uses the file chooser dialog, different backends can be loaded
+ dynamically. One such a backend is the Gnome VFS backend that gets loaded
+ if you run Gnome. That backend creates several threads and also allocates
+ memory with malloc.
+
+ If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
+ functions below are called from malloc, there is a chance that one
+ of these threads preempts the Emacs main thread and the hook variables
+ end up in an inconsistent state. So we have a mutex to prevent that (note
+ that the backend handles concurrent access to malloc within its own threads
+ but Emacs code running in the main thread is not included in that control).
+
+ When UNBLOCK_INPUT is called, revoke_input_signal may be called. If this
+ happens in one of the backend threads we will have two threads that tries
+ to run Emacs code at once, and the code is not prepared for that.
+ To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
+
+static pthread_mutex_t alloc_mutex;
+
+#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;
#endif /* VIRT_ADDR_VARIES */
int malloc_sbrk_unused;
-/* Two limits controlling how much undo information to keep. */
-
-EMACS_INT undo_limit;
-EMACS_INT undo_strong_limit;
-
/* Number of live and free conses etc. */
static int total_conses, total_markers, total_symbols, total_vector_size;
#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))
+
+
+/* The call depth in overrun_check functions. Realloc may call both malloc
+ and free. If realloc calls malloc, this may happen:
+ overrun_check_realloc()
+ -> malloc -> (via hook)_-> emacs_blocked_malloc
+ -> overrun_check_malloc
+ call malloc (hooks are NULL, so real malloc is called).
+ malloc returns 10000.
+ add overhead, return 10016.
+ <- (back in overrun_check_realloc)
+ add overhead again, return 10032
+
+ (time passes).
+
+ overrun_check_free(10032)
+ decrease overhed
+ free(10016) <- crash, because 10000 is the original pointer. */
+
+static int check_depth;
+
+/* Like malloc, but wraps allocated block with header and trailer. */
+
+POINTER_TYPE *
+overrun_check_malloc (size)
+ size_t size;
+{
+ register unsigned char *val;
+ size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
+
+ val = (unsigned char *) malloc (size + overhead);
+ if (val && check_depth == 1)
+ {
+ 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);
+ }
+ --check_depth;
+ 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;
+ size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
+
+ if (val
+ && check_depth == 1
+ && 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 + overhead);
+
+ if (val && check_depth == 1)
+ {
+ 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);
+ }
+ --check_depth;
+ 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;
+
+ ++check_depth;
+ if (val
+ && check_depth == 1
+ && 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);
+ --check_depth;
+}
+
+#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)
#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)
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);
+#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);
}
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. */
union Lisp_Misc *marker_free_list;
-/* Marker blocks which should be freed at end of GC. */
-
-struct marker_block *marker_blocks_pending_free;
-
/* Total number of marker blocks now in use. */
int n_marker_blocks;
marker_block = NULL;
marker_block_index = MARKER_BLOCK_SIZE;
marker_free_list = 0;
- marker_blocks_pending_free = 0;
n_marker_blocks = 0;
}
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 ();
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;
- /* Nonzero means call value of debugger when done with this operation. */
- char debug_on_exit;
-};
-
-
\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 (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. */
if (pure_bytes_used_before_overflow)
return Qnil;
+ /* Don't keep undo information around forever.
+ Do this early on, so it is no problem if the user quits. */
+ {
+ register struct buffer *nextb = all_buffers;
+
+ while (nextb)
+ {
+ /* If a buffer's undo list is Qt, that means that undo is
+ turned off in that buffer. Calling truncate_undo_list on
+ 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))
+ truncate_undo_list (nextb);
+
+ /* Shrink buffer gaps, but skip indirect and dead buffers. */
+ if (nextb->base_buffer == 0 && !NILP (nextb->name))
+ {
+ /* If a buffer's gap size is more than 10% of the buffer
+ size, or larger than 2000 bytes, then shrink it
+ accordingly. Keep a minimum size of 20 bytes. */
+ int size = min (2000, max (20, (nextb->text->z_byte / 10)));
+
+ if (nextb->text->gap_size > size)
+ {
+ struct buffer *save_current = current_buffer;
+ current_buffer = nextb;
+ make_gap (-(nextb->text->gap_size - size));
+ current_buffer = save_current;
+ }
+ }
+
+ nextb = nextb->next;
+ }
+ }
+
+ EMACS_GET_TIME (t1);
+
/* In case user calls debug_print during GC,
don't let that cause a recursive GC. */
consing_since_gc = 0;
shrink_regexp_cache ();
- /* Don't keep undo information around forever. */
- {
- register struct buffer *nextb = all_buffers;
-
- while (nextb)
- {
- /* If a buffer's undo list is Qt, that means that undo is
- turned off in that buffer. Calling truncate_undo_list on
- 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
- = truncate_undo_list (nextb->undo_list, undo_limit,
- undo_strong_limit);
-
- /* Shrink buffer gaps, but skip indirect and dead buffers. */
- if (nextb->base_buffer == 0 && !NILP (nextb->name))
- {
- /* If a buffer's gap size is more than 10% of the buffer
- size, or larger than 2000 bytes, then shrink it
- accordingly. Keep a minimum size of 20 bytes. */
- int size = min (2000, max (20, (nextb->text->z_byte / 10)));
-
- if (nextb->text->gap_size > size)
- {
- struct buffer *save_current = current_buffer;
- current_buffer = nextb;
- make_gap (-(nextb->text->gap_size - size));
- current_buffer = save_current;
- }
- }
-
- nextb = nextb->next;
- }
- }
-
gc_in_progress = 1;
/* clear_marks (); */
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);
-
- 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 ();
+ mark_backtrace ();
#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 ();
-
- /* Look thru every buffer's undo list for elements that used to
- contain update markers that were changed to Lisp_Misc_Free
- objects and delete them. This may leave a few cons cells
- unchained, but we will get those on the next sweep. */
+ /* 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. */
{
register struct buffer *nextb = all_buffers;
while (nextb)
{
/* If a buffer's undo list is Qt, that means that undo is
- turned off in that buffer. */
+ turned off in that buffer. Calling truncate_undo_list on
+ 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))
{
- Lisp_Object tail, prev, elt, car;
+ Lisp_Object tail, prev;
tail = nextb->undo_list;
prev = Qnil;
while (CONSP (tail))
{
- if ((elt = XCAR (tail), GC_CONSP (elt))
- && (car = XCAR (elt), GC_MISCP (car))
- && XMISCTYPE (car) == Lisp_Misc_Free)
+ if (GC_CONSP (XCAR (tail))
+ && GC_MARKERP (XCAR (XCAR (tail)))
+ && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
{
- Lisp_Object cdr = XCDR (tail);
- /* Do not use free_cons here, as we don't know if
- anybody else has a pointer to these conses. */
- XSETCAR (elt, Qnil);
- XSETCDR (elt, Qnil);
- XSETCAR (tail, Qnil);
- XSETCDR (tail, Qnil);
if (NILP (prev))
- nextb->undo_list = tail = cdr;
+ nextb->undo_list = tail = XCDR (tail);
else
{
- tail = cdr;
+ tail = XCDR (tail);
XSETCDR (prev, tail);
}
}
}
}
}
+ /* 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;
}
}
- /* Undo lists have been cleaned up, so we can free marker blocks now. */
-
- {
- struct marker_block *mblk;
-
- while ((mblk = marker_blocks_pending_free) != 0)
- {
- marker_blocks_pending_free = mblk->next;
- lisp_free (mblk);
- }
- }
+ 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)
{
static void
gc_sweep ()
{
+ /* Remove or mark entries in weak hash tables.
+ This must be done before any object is unmarked. */
+ sweep_weak_hash_tables ();
+
+ sweep_strings ();
+#ifdef GC_CHECK_STRING_BYTES
+ if (!noninteractive)
+ check_string_bytes (1);
+#endif
+
/* Put all unmarked conses on free list */
{
register struct cons_block *cblk;
total_free_conses = num_free;
}
- /* Remove or mark entries in weak hash tables.
- This must be done before any object is unmarked. */
- sweep_weak_hash_tables ();
-
- sweep_strings ();
-#ifdef GC_CHECK_STRING_BYTES
- if (!noninteractive)
- check_string_bytes (1);
-#endif
-
/* Put all unmarked floats on free list */
{
register struct float_block *fblk;
register int num_free = 0, num_used = 0;
marker_free_list = 0;
- marker_blocks_pending_free = 0;
for (mblk = marker_block; mblk; mblk = *mprev)
{
*mprev = mblk->next;
/* Unhook from the free list. */
marker_free_list = mblk->markers[0].u_free.chain;
+ lisp_free (mblk);
n_marker_blocks--;
-
- /* It is not safe to free the marker block at this stage,
- since there may still be pointers to these markers from
- a buffer's undo list. KFS 2004-05-25. */
- mblk->next = marker_blocks_pending_free;
- marker_blocks_pending_free = mblk;
}
else
{
doc: /* Non-nil means loading Lisp code in order to dump an executable.
This means that certain objects should be allocated in shared (pure) space. */);
- DEFVAR_INT ("undo-limit", &undo_limit,
- doc: /* Keep no more undo information once it exceeds this size.
-This limit is applied when garbage collection happens.
-The size is counted as the number of bytes occupied,
-which includes both saved text and other data. */);
- undo_limit = 20000;
-
- 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.
-The size is counted as the number of bytes occupied,
-which includes both saved text and other data. */);
- undo_strong_limit = 30000;
-
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