/* 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));
+ ABLOCKS_BUSY (abase) = (struct ablocks *) (-2 + (long) ABLOCKS_BUSY (abase));
- if (2 > (int) 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
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;
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))
/* 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 ();
/* 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;
defsubr (&Sgc_status);
#endif
}
+
+/* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
+ (do not change this comment) */