/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 1998
+ Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999
Free Software Foundation, Inc.
This file is part of GNU Emacs.
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA. */
+#include <config.h>
+
/* Note that this declares bzero on OSF/1. How dumb. */
#include <signal.h>
-#include <config.h>
+/* 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. */
+#undef HIDE_LISP_IMPLEMENTATION
#include "lisp.h"
#include "intervals.h"
#include "puresize.h"
#ifdef DOUG_LEA_MALLOC
#include <malloc.h>
#define __malloc_size_t int
+
+/* Specify maximum number of areas to mmap.
+ It would be nice to use a value that explicitly
+ means "no limit". */
+#define MMAP_MAX_AREAS 100000000
+
#else
/* The following come from gmalloc.c. */
extern int __malloc_extra_blocks;
#endif /* !defined(DOUG_LEA_MALLOC) */
-extern Lisp_Object Vhistory_length;
-
#define max(A,B) ((A) > (B) ? (A) : (B))
#define min(A,B) ((A) < (B) ? (A) : (B))
Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
-static void mark_object (), mark_buffer (), mark_kboards ();
-static void clear_marks (), gc_sweep ();
+static void mark_buffer (), mark_kboards ();
+static void gc_sweep ();
static void compact_strings ();
+static void mark_glyph_matrix P_ ((struct glyph_matrix *));
+static void mark_face_cache P_ ((struct face_cache *));
+#if 0
+static void clear_marks ();
+#endif
+
+#ifdef HAVE_WINDOW_SYSTEM
+static void mark_image P_ ((struct image *));
+static void mark_image_cache P_ ((struct frame *));
+#endif /* HAVE_WINDOW_SYSTEM */
+
extern int message_enable_multibyte;
\f
Fsignal (Qerror, memory_signal_data);
}
-/* like malloc routines but check for no memory and block interrupt input. */
+/* Like malloc routines but check for no memory and block interrupt input. */
long *
xmalloc (size)
UNBLOCK_INPUT;
}
+/* Like malloc but used for allocating Lisp data. */
+
+long *
+lisp_malloc (size)
+ int size;
+{
+ register long *val;
+
+ BLOCK_INPUT;
+ allocating_for_lisp++;
+ val = (long *) malloc (size);
+ allocating_for_lisp--;
+ UNBLOCK_INPUT;
+
+ if (!val && size) memory_full ();
+ return val;
+}
+
+void
+lisp_free (block)
+ long *block;
+{
+ BLOCK_INPUT;
+ allocating_for_lisp++;
+ free (block);
+ allocating_for_lisp--;
+ UNBLOCK_INPUT;
+}
\f
/* Arranging to disable input signals while we're in malloc.
void
uninterrupt_malloc ()
{
- old_free_hook = __free_hook;
+ if (__free_hook != emacs_blocked_free)
+ old_free_hook = __free_hook;
__free_hook = emacs_blocked_free;
- old_malloc_hook = __malloc_hook;
+ if (__malloc_hook != emacs_blocked_malloc)
+ old_malloc_hook = __malloc_hook;
__malloc_hook = emacs_blocked_malloc;
- old_realloc_hook = __realloc_hook;
+ if (__realloc_hook != emacs_blocked_realloc)
+ old_realloc_hook = __realloc_hook;
__realloc_hook = emacs_blocked_realloc;
}
#endif
INTERVAL interval_free_list;
+/* Total number of interval blocks now in use. */
+int n_interval_blocks;
+
static void
init_intervals ()
{
- allocating_for_lisp = 1;
interval_block
- = (struct interval_block *) malloc (sizeof (struct interval_block));
- allocating_for_lisp = 0;
+ = (struct interval_block *) lisp_malloc (sizeof (struct interval_block));
interval_block->next = 0;
bzero ((char *) interval_block->intervals, sizeof interval_block->intervals);
interval_block_index = 0;
interval_free_list = 0;
+ n_interval_blocks = 1;
}
#define INIT_INTERVALS init_intervals ()
{
register struct interval_block *newi;
- allocating_for_lisp = 1;
- newi = (struct interval_block *) xmalloc (sizeof (struct interval_block));
+ newi = (struct interval_block *) lisp_malloc (sizeof (struct interval_block));
- allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (newi, sizeof *newi);
newi->next = interval_block;
interval_block = newi;
interval_block_index = 0;
+ n_interval_blocks++;
}
val = &interval_block->intervals[interval_block_index++];
}
struct float_block *float_block;
int float_block_index;
+/* Total number of float blocks now in use. */
+int n_float_blocks;
+
struct Lisp_Float *float_free_list;
void
init_float ()
{
- allocating_for_lisp = 1;
- float_block = (struct float_block *) malloc (sizeof (struct float_block));
- allocating_for_lisp = 0;
+ float_block = (struct float_block *) lisp_malloc (sizeof (struct float_block));
float_block->next = 0;
bzero ((char *) float_block->floats, sizeof float_block->floats);
float_block_index = 0;
float_free_list = 0;
+ n_float_blocks = 1;
}
/* Explicitly free a float cell. */
{
register struct float_block *new;
- allocating_for_lisp = 1;
- new = (struct float_block *) xmalloc (sizeof (struct float_block));
- allocating_for_lisp = 0;
+ new = (struct float_block *) lisp_malloc (sizeof (struct float_block));
VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = float_block;
float_block = new;
float_block_index = 0;
+ n_float_blocks++;
}
XSETFLOAT (val, &float_block->floats[float_block_index++]);
}
- XFLOAT (val)->data = float_value;
+ XFLOAT_DATA (val) = float_value;
XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */
consing_since_gc += sizeof (struct Lisp_Float);
floats_consed++;
struct Lisp_Cons *cons_free_list;
+/* Total number of cons blocks now in use. */
+int n_cons_blocks;
+
void
init_cons ()
{
- allocating_for_lisp = 1;
- cons_block = (struct cons_block *) malloc (sizeof (struct cons_block));
- allocating_for_lisp = 0;
+ cons_block = (struct cons_block *) lisp_malloc (sizeof (struct cons_block));
cons_block->next = 0;
bzero ((char *) cons_block->conses, sizeof cons_block->conses);
cons_block_index = 0;
cons_free_list = 0;
+ n_cons_blocks = 1;
}
/* Explicitly free a cons cell. */
if (cons_block_index == CONS_BLOCK_SIZE)
{
register struct cons_block *new;
- allocating_for_lisp = 1;
- new = (struct cons_block *) xmalloc (sizeof (struct cons_block));
- allocating_for_lisp = 0;
+ new = (struct cons_block *) lisp_malloc (sizeof (struct cons_block));
VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
+ n_cons_blocks++;
}
XSETCONS (val, &cons_block->conses[cons_block_index++]);
}
- XCONS (val)->car = car;
- XCONS (val)->cdr = cdr;
+ XCAR (val) = car;
+ XCDR (val) = cdr;
consing_since_gc += sizeof (struct Lisp_Cons);
cons_cells_consed++;
return val;
struct Lisp_Vector *all_vectors;
+/* Total number of vectorlike objects now in use. */
+int n_vectors;
+
struct Lisp_Vector *
allocate_vectorlike (len)
EMACS_INT len;
{
struct Lisp_Vector *p;
- allocating_for_lisp = 1;
#ifdef DOUG_LEA_MALLOC
/* Prevent mmap'ing the chunk (which is potentially very large). */
mallopt (M_MMAP_MAX, 0);
#endif
- p = (struct Lisp_Vector *)xmalloc (sizeof (struct Lisp_Vector)
+ p = (struct Lisp_Vector *)lisp_malloc (sizeof (struct Lisp_Vector)
+ (len - 1) * sizeof (Lisp_Object));
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
- mallopt (M_MMAP_MAX, 64);
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
- allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (p, 0);
consing_since_gc += (sizeof (struct Lisp_Vector)
+ (len - 1) * sizeof (Lisp_Object));
vector_cells_consed += len;
+ n_vectors++;
p->next = all_vectors;
all_vectors = p;
struct Lisp_Symbol *symbol_free_list;
+/* Total number of symbol blocks now in use. */
+int n_symbol_blocks;
+
void
init_symbol ()
{
- allocating_for_lisp = 1;
- symbol_block = (struct symbol_block *) malloc (sizeof (struct symbol_block));
- allocating_for_lisp = 0;
+ symbol_block = (struct symbol_block *) lisp_malloc (sizeof (struct symbol_block));
symbol_block->next = 0;
bzero ((char *) symbol_block->symbols, sizeof symbol_block->symbols);
symbol_block_index = 0;
symbol_free_list = 0;
+ n_symbol_blocks = 1;
}
DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
if (symbol_block_index == SYMBOL_BLOCK_SIZE)
{
struct symbol_block *new;
- allocating_for_lisp = 1;
- new = (struct symbol_block *) xmalloc (sizeof (struct symbol_block));
- allocating_for_lisp = 0;
+ new = (struct symbol_block *) lisp_malloc (sizeof (struct symbol_block));
VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = symbol_block;
symbol_block = new;
symbol_block_index = 0;
+ n_symbol_blocks++;
}
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
}
((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
struct marker_block
- {
+{
struct marker_block *next;
union Lisp_Misc markers[MARKER_BLOCK_SIZE];
};
union Lisp_Misc *marker_free_list;
+/* Total number of marker blocks now in use. */
+int n_marker_blocks;
+
void
init_marker ()
{
- allocating_for_lisp = 1;
- marker_block = (struct marker_block *) malloc (sizeof (struct marker_block));
- allocating_for_lisp = 0;
+ marker_block = (struct marker_block *) lisp_malloc (sizeof (struct marker_block));
marker_block->next = 0;
bzero ((char *) marker_block->markers, sizeof marker_block->markers);
marker_block_index = 0;
marker_free_list = 0;
+ n_marker_blocks = 1;
}
/* Return a newly allocated Lisp_Misc object, with no substructure. */
if (marker_block_index == MARKER_BLOCK_SIZE)
{
struct marker_block *new;
- allocating_for_lisp = 1;
- new = (struct marker_block *) xmalloc (sizeof (struct marker_block));
- allocating_for_lisp = 0;
+ new = (struct marker_block *) lisp_malloc (sizeof (struct marker_block));
VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = marker_block;
marker_block = new;
marker_block_index = 0;
+ n_marker_blocks++;
}
XSETMISC (val, &marker_block->markers[marker_block_index++]);
}
(((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
#endif
+/* Total number of string blocks now in use. */
+int n_string_blocks;
+
void
init_strings ()
{
- allocating_for_lisp = 1;
- current_string_block = (struct string_block *) malloc (sizeof (struct string_block));
- allocating_for_lisp = 0;
+ current_string_block = (struct string_block *) lisp_malloc (sizeof (struct string_block));
first_string_block = current_string_block;
consing_since_gc += sizeof (struct string_block);
current_string_block->next = 0;
current_string_block->prev = 0;
current_string_block->pos = 0;
large_string_blocks = 0;
+ n_string_blocks = 1;
}
\f
DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
bits_per_value = sizeof (EMACS_INT) * BITS_PER_CHAR;
length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
- length_in_chars = length_in_elts * sizeof (EMACS_INT);
+ length_in_chars = ((XFASTINT (length) + BITS_PER_CHAR - 1) / BITS_PER_CHAR);
/* We must allocate one more elements than LENGTH_IN_ELTS for the
slot `size' of the struct Lisp_Bool_Vector. */
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]
+ &= (1 << (XINT (length) % BITS_PER_CHAR)) - 1;
return val;
}
/* This string gets its own string block */
{
register struct string_block *new;
- allocating_for_lisp = 1;
#ifdef DOUG_LEA_MALLOC
/* Prevent mmap'ing the chunk (which is potentially very large). */
mallopt (M_MMAP_MAX, 0);
#endif
- new = (struct string_block *) xmalloc (sizeof (struct string_block_head) + fullsize);
+ new = (struct string_block *) lisp_malloc (sizeof (struct string_block_head) + fullsize);
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
- mallopt (M_MMAP_MAX, 64);
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
- allocating_for_lisp = 0;
+ n_string_blocks++;
VALIDATE_LISP_STORAGE (new, 0);
consing_since_gc += sizeof (struct string_block_head) + fullsize;
new->pos = fullsize;
/* Make a new current string block and start it off with this string */
{
register struct string_block *new;
- allocating_for_lisp = 1;
- new = (struct string_block *) xmalloc (sizeof (struct string_block));
- allocating_for_lisp = 0;
+ new = (struct string_block *) lisp_malloc (sizeof (struct string_block));
+ n_string_blocks++;
VALIDATE_LISP_STORAGE (new, sizeof *new);
consing_since_gc += sizeof (struct string_block);
current_string_block->next = new;
error ("Pure Lisp storage exhausted");
XSETCONS (new, PUREBEG + pureptr);
pureptr += sizeof (struct Lisp_Cons);
- XCONS (new)->car = Fpurecopy (car);
- XCONS (new)->cdr = Fpurecopy (cdr);
+ XCAR (new) = Fpurecopy (car);
+ XCDR (new) = Fpurecopy (cdr);
return new;
}
error ("Pure Lisp storage exhausted");
XSETFLOAT (new, PUREBEG + pureptr);
pureptr += sizeof (struct Lisp_Float);
- XFLOAT (new)->data = num;
+ XFLOAT_DATA (new) = num;
XSETFASTINT (XFLOAT (new)->type, 0); /* bug chasing -wsr */
return new;
}
return obj;
if (CONSP (obj))
- return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr);
+ return pure_cons (XCAR (obj), XCDR (obj));
#ifdef LISP_FLOAT_TYPE
else if (FLOATP (obj))
- return make_pure_float (XFLOAT (obj)->data);
+ return make_pure_float (XFLOAT_DATA (obj));
#endif /* LISP_FLOAT_TYPE */
else if (STRINGP (obj))
return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size,
struct gcpro *gcprolist;
-#define NSTATICS 768
+#define NSTATICS 1024
Lisp_Object *staticvec[NSTATICS] = {0};
struct catchtag *catch;
struct handler *handler;
register struct backtrace *backlist;
- register Lisp_Object tem;
- char *omessage = echo_area_glyphs;
- int omessage_length = echo_area_glyphs_length;
- int oldmultibyte = message_enable_multibyte;
char stack_top_variable;
register int i;
+ int message_p;
/* In case user calls debug_print during GC,
don't let that cause a recursive GC. */
consing_since_gc = 0;
+ /* Save what's currently displayed in the echo area. */
+ message_p = push_message ();
+
/* Save a copy of the contents of the stack, for debugging. */
#if MAX_SAVE_STACK > 0
if (NILP (Vpurify_flag))
if (garbage_collection_messages)
message1_nolog ("Garbage collecting...");
- /* Don't keep command history around forever. */
- if (NUMBERP (Vhistory_length) && XINT (Vhistory_length) > 0)
- {
- tem = Fnthcdr (Vhistory_length, Vcommand_history);
- if (CONSP (tem))
- XCONS (tem)->cdr = Qnil;
- }
+ BLOCK_INPUT;
+
+ shrink_regexp_cache ();
- /* Likewise for undo information. */
+ /* Don't keep undo information around forever. */
{
register struct buffer *nextb = all_buffers;
prev = Qnil;
while (CONSP (tail))
{
- if (GC_CONSP (XCONS (tail)->car)
- && GC_MARKERP (XCONS (XCONS (tail)->car)->car)
- && ! XMARKBIT (XMARKER (XCONS (XCONS (tail)->car)->car)->chain))
+ if (GC_CONSP (XCAR (tail))
+ && GC_MARKERP (XCAR (XCAR (tail)))
+ && ! XMARKBIT (XMARKER (XCAR (XCAR (tail)))->chain))
{
if (NILP (prev))
- nextb->undo_list = tail = XCONS (tail)->cdr;
+ nextb->undo_list = tail = XCDR (tail);
else
- tail = XCONS (prev)->cdr = XCONS (tail)->cdr;
+ tail = XCDR (prev) = XCDR (tail);
}
else
{
prev = tail;
- tail = XCONS (tail)->cdr;
+ tail = XCDR (tail);
}
}
}
XUNMARK (buffer_defaults.name);
XUNMARK (buffer_local_symbols.name);
+ UNBLOCK_INPUT;
+
/* clear_marks (); */
gc_in_progress = 0;
if (garbage_collection_messages)
{
- if (omessage || minibuf_level > 0)
- message2_nolog (omessage, omessage_length, oldmultibyte);
+ if (message_p || minibuf_level > 0)
+ restore_message ();
else
message1_nolog ("Garbage collecting...done");
}
+ pop_message ();
+
return Fcons (Fcons (make_number (total_conses),
make_number (total_free_conses)),
Fcons (Fcons (make_number (total_symbols),
}
}
#endif
+
+/* Mark Lisp objects in glyph matrix MATRIX. Currently the
+ only interesting objects referenced from glyphs are strings. */
+
+static void
+mark_glyph_matrix (matrix)
+ struct glyph_matrix *matrix;
+{
+ struct glyph_row *row = matrix->rows;
+ struct glyph_row *end = row + matrix->nrows;
+
+ while (row < end)
+ {
+ if (row->enabled_p)
+ {
+ int area;
+ for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
+ {
+ struct glyph *glyph = row->glyphs[area];
+ struct glyph *end_glyph = glyph + row->used[area];
+
+ while (glyph < end_glyph)
+ {
+ if (GC_STRINGP (glyph->object))
+ mark_object (&glyph->object);
+ ++glyph;
+ }
+ }
+ }
+
+ ++row;
+ }
+}
+
+/* Mark Lisp faces in the face cache C. */
+
+static void
+mark_face_cache (c)
+ struct face_cache *c;
+{
+ if (c)
+ {
+ int i, j;
+ for (i = 0; i < c->used; ++i)
+ {
+ struct face *face = FACE_FROM_ID (c->f, i);
+
+ if (face)
+ {
+ for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
+ mark_object (&face->lface[j]);
+ mark_object (&face->registry);
+ }
+ }
+ }
+}
+
+
+#ifdef HAVE_WINDOW_SYSTEM
+
+/* Mark Lisp objects in image IMG. */
+
+static void
+mark_image (img)
+ struct image *img;
+{
+ mark_object (&img->spec);
+
+ if (!NILP (img->data.lisp_val))
+ mark_object (&img->data.lisp_val);
+}
+
+
+/* Mark Lisp objects in image cache of frame F. It's done this way so
+ that we don't have to include xterm.h here. */
+
+static void
+mark_image_cache (f)
+ struct frame *f;
+{
+ forall_images_in_image_cache (f, mark_image);
+}
+
+#endif /* HAVE_X_WINDOWS */
+
+
\f
/* Mark reference to a Lisp_Object.
If the object referred to has not been seen yet, recursively mark
Lisp_Object *last_marked[LAST_MARKED_SIZE];
int last_marked_index;
-static void
+void
mark_object (argptr)
Lisp_Object *argptr;
{
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->desired_tool_bar_items);
+ mark_object (&ptr->current_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))
{
break; /* Already marked */
ptr->size |= ARRAY_MARK_FLAG; /* 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;
+ /* The reason we use ptr1 is to avoid an apparent hardware bug
+ that happens occasionally on the FSF's HP 300s.
+ The bug is that a2 gets clobbered by recursive calls to mark_object.
+ The clobberage seems to happen during function entry,
+ perhaps in the moveml instruction.
+ Yes, this is a crock, but we have to do it. */
+ struct Lisp_Vector *volatile ptr1 = ptr;
+ register int i;
+
+ /* Stop if already marked. */
+ if (size & ARRAY_MARK_FLAG)
+ break;
+
+ /* Mark it. */
+ ptr->size |= ARRAY_MARK_FLAG;
+
+ /* There is no Lisp data above The member CURRENT_MATRIX in
+ struct WINDOW. Stop marking when that slot is reached. */
+ for (i = 0;
+ (char *) &ptr1->contents[i] < (char *) &w->current_matrix;
+ i++)
+ mark_object (&ptr1->contents[i]);
+
+ /* Mark glyphs for leaf windows. Marking window matrices is
+ sufficient because frame matrices use the same glyph
+ memory. */
+ if (NILP (w->hchild)
+ && NILP (w->vchild)
+ && w->current_matrix)
+ {
+ mark_glyph_matrix (w->current_matrix);
+ mark_glyph_matrix (w->desired_matrix);
+ }
+ }
+ 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)
+ break;
+
+ /* Mark it. */
+ h->size |= ARRAY_MARK_FLAG;
+
+ /* Mark contents. */
+ 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);
+ else
+ XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG;
+
+ }
else
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
+
for (i = 0; i < size; i++) /* and then mark its elements */
mark_object (&ptr1->contents[i]);
}
mark_object (&ptr->function);
mark_object (&ptr->plist);
XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
- mark_object (&ptr->name);
+ mark_object ((Lisp_Object *) &ptr->name);
/* 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. */
}
mark_object (&ptr->car);
/* See comment above under Lisp_Vector for why not use ptr here. */
- objptr = &XCONS (obj)->cdr;
+ objptr = &XCDR (obj);
goto loop;
}
break;
XMARK (ptr->car);
if (GC_CONSP (ptr->car)
- && ! XMARKBIT (XCONS (ptr->car)->car)
- && GC_MARKERP (XCONS (ptr->car)->car))
+ && ! XMARKBIT (XCAR (ptr->car))
+ && GC_MARKERP (XCAR (ptr->car)))
{
- XMARK (XCONS (ptr->car)->car);
- mark_object (&XCONS (ptr->car)->cdr);
+ XMARK (XCAR (ptr->car));
+ mark_object (&XCDR (ptr->car));
}
else
mark_object (&ptr->car);
break;
}
- mark_object (&XCONS (tail)->cdr);
+ mark_object (&XCDR (tail));
}
else
mark_object (&buffer->undo_list);
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. */
+
+int
+survives_gc_p (obj)
+ Lisp_Object obj;
+{
+ int survives_p;
+
+ switch (XGCTYPE (obj))
+ {
+ case Lisp_Int:
+ survives_p = 1;
+ break;
+
+ case Lisp_Symbol:
+ survives_p = XMARKBIT (XSYMBOL (obj)->plist);
+ 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 ();
+ }
+ break;
+
+ case Lisp_String:
+ {
+ struct Lisp_String *s = XSTRING (obj);
+
+ if (s->size & MARKBIT)
+ survives_p = s->size & ARRAY_MARK_FLAG;
+ else
+ survives_p = (s->size & ~DONT_COPY_FLAG) > STRING_BLOCK_SIZE;
+ }
+ 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;
+ break;
+
+ case Lisp_Cons:
+ survives_p = XMARKBIT (XCAR (obj));
+ break;
+
+#ifdef LISP_FLOAT_TYPE
+ case Lisp_Float:
+ survives_p = XMARKBIT (XFLOAT (obj)->type);
+ break;
+#endif /* LISP_FLOAT_TYPE */
+
+ default:
+ abort ();
}
+
+ return survives_p;
}
+
+
\f
/* Sweep: find all structures not marked, and free them. */
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 ();
+
total_string_size = 0;
compact_strings ();
*cprev = cblk->next;
/* Unhook from the free list. */
cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr;
- xfree (cblk);
+ lisp_free (cblk);
+ n_cons_blocks--;
}
else
{
*fprev = fblk->next;
/* Unhook from the free list. */
float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data;
- xfree (fblk);
+ lisp_free (fblk);
+ n_float_blocks--;
}
else
{
*iprev = iblk->next;
/* Unhook from the free list. */
interval_free_list = iblk->intervals[0].parent;
- xfree (iblk);
+ lisp_free (iblk);
+ n_interval_blocks--;
}
else
{
*sprev = sblk->next;
/* Unhook from the free list. */
symbol_free_list = *(struct Lisp_Symbol **)&sblk->symbols[0].value;
- xfree (sblk);
+ lisp_free (sblk);
+ n_symbol_blocks--;
}
else
{
*mprev = mblk->next;
/* Unhook from the free list. */
marker_free_list = mblk->markers[0].u_free.chain;
- xfree (mblk);
+ lisp_free (mblk);
+ n_marker_blocks--;
}
else
{
while (vector)
if (!(vector->size & ARRAY_MARK_FLAG))
{
+#if 0
+ if ((vector->size & (PSEUDOVECTOR_FLAG | PVEC_HASH_TABLE))
+ == (PSEUDOVECTOR_FLAG | PVEC_HASH_TABLE))
+ fprintf (stderr, "Freeing hash table %p\n", vector);
+#endif
if (prev)
prev->next = vector->next;
else
all_vectors = vector->next;
next = vector->next;
- xfree (vector);
+ lisp_free (vector);
+ n_vectors--;
vector = next;
+
}
else
{
else
large_string_blocks = sb->next;
next = sb->next;
- xfree (sb);
+ lisp_free (sb);
sb = next;
+ n_string_blocks--;
}
}
}
while (from_sb)
{
to_sb = from_sb->next;
- xfree (from_sb);
+ lisp_free (from_sb);
+ n_string_blocks--;
from_sb = to_sb;
}
unlikely that that one will become empty, so why bother checking? */
from_sb = first_string_block;
- while (to_sb = from_sb->next)
+ while ((to_sb = from_sb->next) != 0)
{
if (to_sb->pos == 0)
{
- if (from_sb->next = to_sb->next)
+ if ((from_sb->next = to_sb->next) != 0)
from_sb->next->prev = from_sb;
- xfree (to_sb);
+ lisp_free (to_sb);
+ n_string_blocks--;
}
else
from_sb = to_sb;
#ifdef DOUG_LEA_MALLOC
mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
- mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
#endif
init_strings ();
init_cons ();
HCoop / bpt / emacs.git / blobdiff