/* Storage allocation and gc for GNU Emacs Lisp interpreter.
Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
- 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <stdio.h>
#include <limits.h> /* For CHAR_BIT. */
+#ifdef STDC_HEADERS
+#include <stddef.h> /* For offsetof, used by PSEUDOVECSIZE. */
+#endif
+
#ifdef ALLOC_DEBUG
#undef INLINE
#endif
extern POINTER_TYPE *sbrk ();
#endif
+#ifdef HAVE_FCNTL_H
+#define INCLUDED_FCNTL
+#include <fcntl.h>
+#endif
+#ifndef O_WRONLY
+#define O_WRONLY 1
+#endif
+
#ifdef DOUG_LEA_MALLOC
#include <malloc.h>
static POINTER_TYPE *lisp_align_malloc P_ ((size_t, enum mem_type));
static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
+void refill_memory_reserve ();
+
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
static void mem_delete P_ ((struct mem_node *));
static void mem_delete_fixup P_ ((struct mem_node *));
static INLINE struct mem_node *mem_find P_ ((void *));
-void refill_memory_reserve ();
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
/* The entry point is lisp_align_malloc which returns blocks of at most */
/* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
+/* Use posix_memalloc if the system has it and we're using the system's
+ malloc (because our gmalloc.c routines don't have posix_memalign although
+ its memalloc could be used). */
+#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
+#define USE_POSIX_MEMALIGN 1
+#endif
/* BLOCK_ALIGN has to be a power of 2. */
#define BLOCK_ALIGN (1 << 10)
#define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
/* Pointer to the (not necessarily aligned) malloc block. */
-#ifdef HAVE_POSIX_MEMALIGN
+#ifdef USE_POSIX_MEMALIGN
#define ABLOCKS_BASE(abase) (abase)
#else
#define ABLOCKS_BASE(abase) \
mallopt (M_MMAP_MAX, 0);
#endif
-#ifdef HAVE_POSIX_MEMALIGN
+#ifdef USE_POSIX_MEMALIGN
{
int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
if (err)
}
eassert ((aligned & 1) == aligned);
eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
+#ifdef USE_POSIX_MEMALIGN
+ eassert ((unsigned long)ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
+#endif
free (ABLOCKS_BASE (abase));
}
UNBLOCK_INPUT;
{
INTERVAL val;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (interval_free_list)
{
val = interval_free_list;
}
val = &interval_block->intervals[interval_block_index++];
}
+
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
consing_since_gc += sizeof (struct interval);
intervals_consed++;
RESET_INTERVAL (val);
{
struct Lisp_String *s;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
/* If the free-list is empty, allocate a new string_block, and
add all the Lisp_Strings in it to the free-list. */
if (string_free_list == NULL)
s = string_free_list;
string_free_list = NEXT_FREE_LISP_STRING (s);
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
/* Probably not strictly necessary, but play it safe. */
bzero (s, sizeof *s);
/* Determine the number of bytes needed to store NBYTES bytes
of string data. */
needed = SDATA_SIZE (nbytes);
+ old_data = s->data ? SDATA_OF_STRING (s) : NULL;
+ old_nbytes = GC_STRING_BYTES (s);
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
if (nbytes > LARGE_STRING_BYTES)
{
else
b = current_sblock;
- old_data = s->data ? SDATA_OF_STRING (s) : NULL;
- old_nbytes = GC_STRING_BYTES (s);
-
data = b->next_free;
+ b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
+
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
data->string = s;
s->data = SDATA_DATA (data);
#ifdef GC_CHECK_STRING_BYTES
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
DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
- doc: /* Return a new bool-vector of length LENGTH, using INIT for as each element.
+ doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
LENGTH must be a number. INIT matters only in whether it is t or nil. */)
(length, init)
Lisp_Object length, init;
free_float (ptr)
struct Lisp_Float *ptr;
{
- *(struct Lisp_Float **)&ptr->data = float_free_list;
+ ptr->u.chain = float_free_list;
float_free_list = ptr;
}
{
register Lisp_Object val;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (float_free_list)
{
/* We use the data field for chaining the free list
so that we won't use the same field that has the mark bit. */
XSETFLOAT (val, float_free_list);
- float_free_list = *(struct Lisp_Float **)&float_free_list->data;
+ float_free_list = float_free_list->u.chain;
}
else
{
float_block_index++;
}
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
XFLOAT_DATA (val) = float_value;
eassert (!FLOAT_MARKED_P (XFLOAT (val)));
consing_since_gc += sizeof (struct Lisp_Float);
free_cons (ptr)
struct Lisp_Cons *ptr;
{
- *(struct Lisp_Cons **)&ptr->cdr = cons_free_list;
+ ptr->u.chain = cons_free_list;
#if GC_MARK_STACK
ptr->car = Vdead;
#endif
{
register Lisp_Object val;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (cons_free_list)
{
/* We use the cdr for chaining the free list
so that we won't use the same field that has the mark bit. */
XSETCONS (val, cons_free_list);
- cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr;
+ cons_free_list = cons_free_list->u.chain;
}
else
{
cons_block_index++;
}
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
XSETCAR (val, car);
XSETCDR (val, cdr);
eassert (!CONS_MARKED_P (XCONS (val)));
struct Lisp_Cons *tail = cons_free_list;
while (tail)
- tail = *(struct Lisp_Cons **)&tail->cdr;
+ tail = tail->u.chain;
#endif
}
UNBLOCK_INPUT;
#endif
+ /* This gets triggered by code which I haven't bothered to fix. --Stef */
+ /* eassert (!handling_signal); */
+
nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);
consing_since_gc += nbytes;
vector_cells_consed += len;
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
p->next = all_vectors;
all_vectors = p;
+
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
++n_vectors;
return p;
}
struct Lisp_Process *
allocate_process ()
{
- EMACS_INT len = VECSIZE (struct Lisp_Process);
- struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS);
+ /* Memory-footprint of the object in nb of Lisp_Object fields. */
+ EMACS_INT memlen = VECSIZE (struct Lisp_Process);
+ /* Size if we only count the actual Lisp_Object fields (which need to be
+ traced by the GC). */
+ EMACS_INT lisplen = PSEUDOVECSIZE (struct Lisp_Process, pid);
+ struct Lisp_Vector *v = allocate_vectorlike (memlen, MEM_TYPE_PROCESS);
EMACS_INT i;
- for (i = 0; i < len; ++i)
+ for (i = 0; i < lisplen; ++i)
v->contents[i] = Qnil;
- v->size = len;
+ v->size = lisplen;
return (struct Lisp_Process *) v;
}
CHECK_STRING (name);
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (symbol_free_list)
{
XSETSYMBOL (val, symbol_free_list);
- symbol_free_list = *(struct Lisp_Symbol **)&symbol_free_list->value;
+ symbol_free_list = symbol_free_list->next;
}
else
{
symbol_block_index++;
}
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
p = XSYMBOL (val);
p->xname = name;
p->plist = Qnil;
{
Lisp_Object val;
+ /* eassert (!handling_signal); */
+
+#ifndef SYNC_INPUT
+ BLOCK_INPUT;
+#endif
+
if (marker_free_list)
{
XSETMISC (val, marker_free_list);
marker_block_index++;
}
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
--total_free_markers;
consing_since_gc += sizeof (union Lisp_Misc);
misc_objects_consed++;
#endif
}
-
#endif /* GC_MARK_STACK != 0 */
+
+/* Return 1 if OBJ is a valid lisp object.
+ Return 0 if OBJ is NOT a valid lisp object.
+ Return -1 if we cannot validate OBJ.
+ This function can be quite slow,
+ so it should only be used in code for manual debugging. */
+
+int
+valid_lisp_object_p (obj)
+ Lisp_Object obj;
+{
+ void *p;
+#if !GC_MARK_STACK
+ int fd;
+#else
+ struct mem_node *m;
+#endif
+
+ if (INTEGERP (obj))
+ return 1;
+
+ p = (void *) XPNTR (obj);
+ if (PURE_POINTER_P (p))
+ return 1;
+
+#if !GC_MARK_STACK
+ /* We need to determine whether it is safe to access memory at
+ address P. Obviously, we cannot just access it (we would SEGV
+ trying), so we trick the o/s to tell us whether p is a valid
+ pointer. Unfortunately, we cannot use NULL_DEVICE here, as
+ emacs_write may not validate p in that case. */
+ if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0)
+ {
+ int valid = (emacs_write (fd, (char *)p, 16) == 16);
+ emacs_close (fd);
+ unlink ("__Valid__Lisp__Object__");
+ return valid;
+ }
+
+ return -1;
+#else
+
+ m = mem_find (p);
+
+ if (m == MEM_NIL)
+ return 0;
+
+ switch (m->type)
+ {
+ case MEM_TYPE_NON_LISP:
+ return 0;
+
+ case MEM_TYPE_BUFFER:
+ return live_buffer_p (m, p);
+
+ case MEM_TYPE_CONS:
+ return live_cons_p (m, p);
+
+ case MEM_TYPE_STRING:
+ return live_string_p (m, p);
+
+ case MEM_TYPE_MISC:
+ return live_misc_p (m, p);
+
+ case MEM_TYPE_SYMBOL:
+ return live_symbol_p (m, p);
+
+ case MEM_TYPE_FLOAT:
+ return live_float_p (m, p);
+
+ case MEM_TYPE_VECTOR:
+ case MEM_TYPE_PROCESS:
+ case MEM_TYPE_HASH_TABLE:
+ case MEM_TYPE_FRAME:
+ case MEM_TYPE_WINDOW:
+ return live_vector_p (m, p);
+
+ default:
+ break;
+ }
+
+ return 0;
+#endif
+}
+
+
+
\f
/***********************************************************************
Pure Storage Management
check_pure_size ()
{
if (pure_bytes_used_before_overflow)
- message ("Pure Lisp storage overflow (approx. %d bytes needed)",
+ message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
(int) (pure_bytes_used + pure_bytes_used_before_overflow));
}
DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
- doc: /* Make a copy of OBJECT in pure storage.
+ doc: /* Make a copy of object OBJ in pure storage.
Recursively copies contents of vectors and cons cells.
Does not copy symbols. Copies strings without text properties. */)
(obj)
total += total_floats * sizeof (struct Lisp_Float);
total += total_intervals * sizeof (struct interval);
total += total_strings * sizeof (struct Lisp_String);
-
+
gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
}
else
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
+ /* Note that this size is not the memory-footprint size, but only
+ the number of Lisp_Object fields that we should trace.
+ The distinction is used e.g. by Lisp_Process which places extra
+ non-Lisp_Object fields at the end of the structure. */
for (i = 0; i < size; i++) /* and then mark its elements */
mark_object (ptr->contents[i]);
}
CHECK_ALLOCATED_AND_LIVE (live_cons_p);
CONS_MARK (ptr);
/* If the cdr is nil, avoid recursion for the car. */
- if (EQ (ptr->cdr, Qnil))
+ if (EQ (ptr->u.cdr, Qnil))
{
obj = ptr->car;
cdr_count = 0;
goto loop;
}
mark_object (ptr->car);
- obj = ptr->cdr;
+ obj = ptr->u.cdr;
cdr_count++;
if (cdr_count == mark_object_loop_halt)
abort ();
if (!CONS_MARKED_P (&cblk->conses[i]))
{
this_free++;
- *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
+ cblk->conses[i].u.chain = cons_free_list;
cons_free_list = &cblk->conses[i];
#if GC_MARK_STACK
cons_free_list->car = Vdead;
{
*cprev = cblk->next;
/* Unhook from the free list. */
- cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr;
+ cons_free_list = cblk->conses[0].u.chain;
lisp_align_free (cblk);
n_cons_blocks--;
}
if (!FLOAT_MARKED_P (&fblk->floats[i]))
{
this_free++;
- *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list;
+ fblk->floats[i].u.chain = float_free_list;
float_free_list = &fblk->floats[i];
}
else
{
*fprev = fblk->next;
/* Unhook from the free list. */
- float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data;
+ float_free_list = fblk->floats[0].u.chain;
lisp_align_free (fblk);
n_float_blocks--;
}
if (!sym->gcmarkbit && !pure_p)
{
- *(struct Lisp_Symbol **) &sym->value = symbol_free_list;
+ sym->next = symbol_free_list;
symbol_free_list = sym;
#if GC_MARK_STACK
symbol_free_list->function = Vdead;
{
*sprev = sblk->next;
/* Unhook from the free list. */
- symbol_free_list = *(struct Lisp_Symbol **)&sblk->symbols[0].value;
+ symbol_free_list = sblk->symbols[0].next;
lisp_free (sblk);
n_symbol_blocks--;
}