/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001, 2002, 2003
+ Copyright (C) 1985,86,88,93,94,95,97,98,1999,2000,01,02,03,2004
Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <signal.h>
-/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
- memory. Can do this only if using gmalloc.c. */
-
-#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
-#undef GC_MALLOC_CHECK
-#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. */
#include "syssignal.h"
#include <setjmp.h>
+/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
+ memory. Can do this only if using gmalloc.c. */
+
+#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
+#undef GC_MALLOC_CHECK
+#endif
+
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
}
-/* Like free but block interrupt input.. */
+/* Like free but block interrupt input. */
void
xfree (block)
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)
#define ABLOCKS_BASE(abase) (abase)
#else
#define ABLOCKS_BASE(abase) \
- (1 & (int) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
+ (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
#endif
/* The list of free ablock. */
if (!free_ablock)
{
- int i, aligned;
+ int i;
+ EMACS_INT aligned; /* int gets warning casting to 64-bit pointer. */
#ifdef DOUG_LEA_MALLOC
/* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
#else
base = malloc (ABLOCKS_BYTES);
abase = ALIGN (base, BLOCK_ALIGN);
+ if (base == 0)
+ {
+ UNBLOCK_INPUT;
+ memory_full ();
+ }
#endif
aligned = (base == abase);
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. */
+ 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 ();
+ }
+ }
+#endif
+
/* 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].x.next_free = free_ablock;
free_ablock = &abase->blocks[i];
}
- ABLOCKS_BUSY (abase) = (struct ablocks *) aligned;
+ ABLOCKS_BUSY (abase) = (struct ablocks *) (long) 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));
+ eassert (aligned == (long) ABLOCKS_BUSY (abase));
}
abase = ABLOCK_ABASE (free_ablock);
- ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (int) ABLOCKS_BUSY (abase));
+ ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (long) ABLOCKS_BUSY (abase));
val = free_ablock;
free_ablock = free_ablock->x.next_free;
- /* 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);
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))
+ 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 = (int) ABLOCKS_BUSY (abase);
+ int i = 0, aligned = (long) ABLOCKS_BUSY (abase);
struct ablock **tem = &free_ablock;
struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
struct interval_block
{
- struct interval_block *next;
+ /* Place `intervals' first, to preserve alignment. */
struct interval intervals[INTERVAL_BLOCK_SIZE];
+ struct interval_block *next;
};
/* Current interval block. Its `next' pointer points to older
static void
init_intervals ()
{
- interval_block
- = (struct interval_block *) lisp_malloc (sizeof *interval_block,
- MEM_TYPE_NON_LISP);
- interval_block->next = 0;
- bzero ((char *) interval_block->intervals, sizeof interval_block->intervals);
- interval_block_index = 0;
+ interval_block = NULL;
+ interval_block_index = INTERVAL_BLOCK_SIZE;
interval_free_list = 0;
- n_interval_blocks = 1;
+ n_interval_blocks = 0;
}
struct string_block
{
- struct string_block *next;
+ /* Place `strings' first, to preserve alignment. */
struct Lisp_String strings[STRING_BLOCK_SIZE];
+ struct string_block *next;
};
/* Head and tail of the list of sblock structures holding Lisp string
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;
}
by GC are put on a free list to be reallocated before allocating
any new float cells from the latest float_block. */
-#define FLOAT_BLOCK_SIZE \
- (((BLOCK_BYTES - sizeof (struct float_block *)) * CHAR_BIT) \
+#define FLOAT_BLOCK_SIZE \
+ (((BLOCK_BYTES - sizeof (struct float_block *) \
+ /* The compiler might add padding at the end. */ \
+ - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
/ (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
#define GETMARKBIT(block,n) \
new = (struct float_block *) lisp_align_malloc (sizeof *new,
MEM_TYPE_FLOAT);
new->next = float_block;
+ bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
float_block = new;
float_block_index = 0;
n_float_blocks++;
}
- XSETFLOAT (val, &float_block->floats[float_block_index++]);
+ XSETFLOAT (val, &float_block->floats[float_block_index]);
+ float_block_index++;
}
XFLOAT_DATA (val) = float_value;
- FLOAT_UNMARK (XFLOAT (val));
+ eassert (!FLOAT_MARKED_P (XFLOAT (val)));
consing_since_gc += sizeof (struct Lisp_Float);
floats_consed++;
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)
register struct cons_block *new;
new = (struct cons_block *) lisp_align_malloc (sizeof *new,
MEM_TYPE_CONS);
+ bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
n_cons_blocks++;
}
- XSETCONS (val, &cons_block->conses[cons_block_index++]);
+ XSETCONS (val, &cons_block->conses[cons_block_index]);
+ cons_block_index++;
}
XSETCAR (val, car);
XSETCDR (val, cdr);
- CONS_UNMARK (XCONS (val));
+ eassert (!CONS_MARKED_P (XCONS (val)));
consing_since_gc += sizeof (struct Lisp_Cons);
cons_cells_consed++;
return val;
/* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
because mapped region contents are not preserved in
a dumped Emacs. */
+ BLOCK_INPUT;
mallopt (M_MMAP_MAX, 0);
+ UNBLOCK_INPUT;
#endif
nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
+ BLOCK_INPUT;
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+ UNBLOCK_INPUT;
#endif
consing_since_gc += nbytes;
struct symbol_block
{
- struct symbol_block *next;
+ /* Place `symbols' first, to preserve alignment. */
struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
+ struct symbol_block *next;
};
/* Current symbol block and index of first unused Lisp_Symbol
void
init_symbol ()
{
- symbol_block = (struct symbol_block *) lisp_malloc (sizeof *symbol_block,
- MEM_TYPE_SYMBOL);
- symbol_block->next = 0;
- bzero ((char *) symbol_block->symbols, sizeof symbol_block->symbols);
- symbol_block_index = 0;
+ symbol_block = NULL;
+ symbol_block_index = SYMBOL_BLOCK_SIZE;
symbol_free_list = 0;
- n_symbol_blocks = 1;
+ n_symbol_blocks = 0;
}
symbol_block_index = 0;
n_symbol_blocks++;
}
- XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
+ XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
+ symbol_block_index++;
}
p = XSYMBOL (val);
struct marker_block
{
- struct marker_block *next;
+ /* Place `markers' first, to preserve alignment. */
union Lisp_Misc markers[MARKER_BLOCK_SIZE];
+ struct marker_block *next;
};
struct marker_block *marker_block;
void
init_marker ()
{
- marker_block = (struct marker_block *) lisp_malloc (sizeof *marker_block,
- MEM_TYPE_MISC);
- marker_block->next = 0;
- bzero ((char *) marker_block->markers, sizeof marker_block->markers);
- marker_block_index = 0;
+ marker_block = NULL;
+ marker_block_index = MARKER_BLOCK_SIZE;
marker_free_list = 0;
- n_marker_blocks = 1;
+ n_marker_blocks = 0;
}
/* Return a newly allocated Lisp_Misc object, with no substructure. */
marker_block_index = 0;
n_marker_blocks++;
}
- XSETMISC (val, &marker_block->markers[marker_block_index++]);
+ XSETMISC (val, &marker_block->markers[marker_block_index]);
+ marker_block_index++;
}
consing_since_gc += sizeof (union Lisp_Misc);
must not be on the free-list. */
return (offset >= 0
&& offset % sizeof b->strings[0] == 0
+ && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
&& ((struct Lisp_String *) p)->data != NULL);
}
else
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
+ && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index)
&& !EQ (((struct Lisp_Cons *) p)->car, Vdead));
and not be on the free-list. */
return (offset >= 0
&& offset % sizeof b->symbols[0] == 0
+ && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
&& (b != symbol_block
|| offset / sizeof b->symbols[0] < symbol_block_index)
&& !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
/* 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
+ && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
&& (b != float_block
|| offset / sizeof b->floats[0] < float_block_index));
}
and not be on the free-list. */
return (offset >= 0
&& offset % sizeof b->markers[0] == 0
+ && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
&& (b != marker_block
|| offset / sizeof b->markers[0] < marker_block_index)
&& ((union Lisp_Misc *) p)->u_marker.type != Lisp_Misc_Free);
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))
/* 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;
};
/* clear_marks (); */
- /* Mark all the special slots that serve as the roots of accessibility.
-
- Usually the special slots to mark are contained in particular structures.
- Then we know no slot is marked twice because the structures don't overlap.
- In some cases, the structures point to the slots to be marked.
- For these, we use MARKBIT to avoid double marking of the slot. */
+ /* Mark all the special slots that serve as the roots of accessibility. */
for (i = 0; i < staticidx; i++)
mark_object (*staticvec[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]);
- }
+ mark_object (tail->var[i]);
}
#endif
}
for (backlist = backtrace_list; backlist; backlist = backlist->next)
{
- if (!XMARKBIT (*backlist->function))
- {
- mark_object (*backlist->function);
- XMARK (*backlist->function);
- }
+ mark_object (*backlist->function);
+
if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
i = 0;
else
i = backlist->nargs - 1;
for (; i >= 0; i--)
- if (!XMARKBIT (backlist->args[i]))
- {
- mark_object (backlist->args[i]);
- XMARK (backlist->args[i]);
- }
+ mark_object (backlist->args[i]);
}
mark_kboards ();
- /* Look thru every buffer's undo list
- for elements that update markers that were not marked,
- and delete them. */
+#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. */
{
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. */
+ turned off in that buffer. */
if (! EQ (nextb->undo_list, Qt))
{
- Lisp_Object tail, prev;
+ Lisp_Object tail, prev, elt, car;
tail = nextb->undo_list;
prev = Qnil;
while (CONSP (tail))
{
- if (GC_CONSP (XCAR (tail))
- && GC_MARKERP (XCAR (XCAR (tail)))
- && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
+ if ((elt = XCAR (tail), GC_CONSP (elt))
+ && (car = XCAR (elt), GC_MISCP (car))
+ && XMISCTYPE (car) == Lisp_Misc_Free)
{
+ 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 = XCDR (tail);
+ nextb->undo_list = tail = cdr;
else
{
- tail = XCDR (tail);
+ tail = cdr;
XSETCDR (prev, tail);
}
}
}
}
-#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 (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
- || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
- {
- 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)
- {
- XUNMARK (*backlist->function);
- if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
- i = 0;
- else
- i = backlist->nargs - 1;
- for (; i >= 0; i--)
- XUNMARK (backlist->args[i]);
- }
VECTOR_UNMARK (&buffer_defaults);
VECTOR_UNMARK (&buffer_local_symbols);
int cdr_count = 0;
loop:
- XUNMARK (obj);
if (PURE_POINTER_P (XPNTR (obj)))
return;
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;
/* If this block contains only free markers and we have already
seen more than two blocks worth of free markers then deallocate
this block. */
+#if 0
+ /* There may still be pointers to these markers from a buffer's
+ undo list, so don't free them. KFS 2004-05-21 /
if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
{
*mprev = mblk->next;
n_marker_blocks--;
}
else
+#endif
{
num_free += this_free;
mprev = &mblk->next;
defsubr (&Sgc_status);
#endif
}
+
+/* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
+ (do not change this comment) */
HCoop / bpt / emacs.git / blobdiff