/* 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
#define O_WRONLY 1
#endif
+#ifdef WINDOWSNT
+#include <fcntl.h>
+#include "w32.h"
+#endif
+
#ifdef DOUG_LEA_MALLOC
#include <malloc.h>
#define BLOCK_INPUT_ALLOC \
do \
{ \
- pthread_mutex_lock (&alloc_mutex); \
- if (pthread_self () == main_thread) \
- BLOCK_INPUT; \
+ if (pthread_self () == main_thread) \
+ BLOCK_INPUT; \
+ pthread_mutex_lock (&alloc_mutex); \
} \
while (0)
#define UNBLOCK_INPUT_ALLOC \
do \
{ \
- if (pthread_self () == main_thread) \
- UNBLOCK_INPUT; \
- pthread_mutex_unlock (&alloc_mutex); \
+ pthread_mutex_unlock (&alloc_mutex); \
+ if (pthread_self () == main_thread) \
+ UNBLOCK_INPUT; \
} \
while (0)
&& ((PNTR_COMPARISON_TYPE) (P) \
>= (PNTR_COMPARISON_TYPE) purebeg))
-/* Index in pure at which next pure object will be allocated.. */
+/* Total number of bytes allocated in pure storage. */
EMACS_INT pure_bytes_used;
+/* Index in pure at which next pure Lisp object will be allocated.. */
+
+static EMACS_INT pure_bytes_used_lisp;
+
+/* Number of bytes allocated for non-Lisp objects in pure storage. */
+
+static EMACS_INT pure_bytes_used_non_lisp;
+
/* If nonzero, this is a warning delivered by malloc and not yet
displayed. */
EMACS_INT gcs_done; /* accumulated GCs */
static void mark_buffer P_ ((Lisp_Object));
+extern void mark_terminals P_ ((void));
extern void mark_kboards P_ ((void));
+extern void mark_ttys P_ ((void));
extern void mark_backtrace P_ ((void));
static void gc_sweep P_ ((void));
static void mark_glyph_matrix P_ ((struct glyph_matrix *));
static int live_float_p P_ ((struct mem_node *, void *));
static int live_misc_p P_ ((struct mem_node *, void *));
static void mark_maybe_object P_ ((Lisp_Object));
-static void mark_memory P_ ((void *, void *));
+static void mark_memory P_ ((void *, void *, int));
static void mem_init P_ ((void));
static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
static void mem_insert_fixup P_ ((struct mem_node *));
/* This used to call error, but if we've run out of memory, we could
get infinite recursion trying to build the string. */
- while (1)
- Fsignal (Qnil, Vmemory_signal_data);
+ xsignal (Qnil, Vmemory_signal_data);
}
/* 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;
BLOCK_INPUT_ALLOC;
__malloc_hook = old_malloc_hook;
#ifdef DOUG_LEA_MALLOC
- mallopt (M_TOP_PAD, malloc_hysteresis * 4096);
+ /* Segfaults on my system. --lorentey */
+ /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
#else
__malloc_extra_blocks = malloc_hysteresis;
#endif
{
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;
{
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
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);
{
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
cons_block_index++;
}
+#ifndef SYNC_INPUT
+ UNBLOCK_INPUT;
+#endif
+
XSETCAR (val, car);
XSETCDR (val, cdr);
eassert (!CONS_MARKED_P (XCONS (val)));
#endif
}
-/* Make a list of 2, 3, 4 or 5 specified objects. */
+/* Make a list of 1, 2, 3, 4 or 5 specified objects. */
+
+Lisp_Object
+list1 (arg1)
+ Lisp_Object arg1;
+{
+ return Fcons (arg1, Qnil);
+}
Lisp_Object
list2 (arg1, arg2)
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_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++;
/* This used to call error, but if we've run out of memory, we could
get infinite recursion trying to build the string. */
- while (1)
- Fsignal (Qnil, Vmemory_signal_data);
+ xsignal (Qnil, Vmemory_signal_data);
}
/* If we released our reserve (due to running out of memory),
}
-/* Mark Lisp objects referenced from the address range START..END. */
+/* Mark Lisp objects referenced from the address range START+OFFSET..END
+ or END+OFFSET..START. */
static void
-mark_memory (start, end)
+mark_memory (start, end, offset)
void *start, *end;
+ int offset;
{
Lisp_Object *p;
void **pp;
}
/* Mark Lisp_Objects. */
- for (p = (Lisp_Object *) start; (void *) p < end; ++p)
+ for (p = (Lisp_Object *) ((char *) start + offset); (void *) p < end; ++p)
mark_maybe_object (*p);
/* Mark Lisp data pointed to. This is necessary because, in some
away. The only reference to the life string is through the
pointer `s'. */
- for (pp = (void **) start; (void *) pp < end; ++pp)
+ for (pp = (void **) ((char *) start + offset); (void *) pp < end; ++pp)
mark_maybe_pointer (*pp);
}
mark_stack ()
{
int i;
- jmp_buf j;
+ /* jmp_buf may not be aligned enough on darwin-ppc64 */
+ union aligned_jmpbuf {
+ Lisp_Object o;
+ jmp_buf j;
+ } j;
volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
void *end;
}
#endif /* GC_SETJMP_WORKS */
- setjmp (j);
+ setjmp (j.j);
end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
#endif /* not GC_SAVE_REGISTERS_ON_STACK */
#endif
#endif
for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
- mark_memory ((char *) stack_base + i, end);
+ mark_memory (stack_base, end, i);
/* Allow for marking a secondary stack, like the register stack on the
ia64. */
#ifdef GC_MARK_SECONDARY_STACK
#endif /* GC_MARK_STACK != 0 */
+/* Determine whether it is safe to access memory at address P. */
+int
+valid_pointer_p (p)
+ void *p;
+{
+#ifdef WINDOWSNT
+ return w32_valid_pointer_p (p, 16);
+#else
+ int fd;
+
+ /* 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;
+#endif
+}
/* Return 1 if OBJ is a valid lisp object.
Return 0 if OBJ is NOT a valid lisp object.
Lisp_Object obj;
{
void *p;
-#if !GC_MARK_STACK
- int fd;
-#else
+#if GC_MARK_STACK
struct mem_node *m;
#endif
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;
+ return valid_pointer_p (p);
#else
m = mem_find (p);
if (m == MEM_NIL)
- return 0;
+ {
+ int valid = valid_pointer_p (p);
+ if (valid <= 0)
+ return valid;
+
+ if (SUBRP (obj))
+ return 1;
+
+ return 0;
+ }
switch (m->type)
{
/* Allocate room for SIZE bytes from pure Lisp storage and return a
pointer to it. TYPE is the Lisp type for which the memory is
- allocated. TYPE < 0 means it's not used for a Lisp object.
-
- If store_pure_type_info is set and TYPE is >= 0, the type of
- the allocated object is recorded in pure_types. */
+ allocated. TYPE < 0 means it's not used for a Lisp object. */
static POINTER_TYPE *
pure_alloc (size, type)
#endif
again:
- result = ALIGN (purebeg + pure_bytes_used, alignment);
- pure_bytes_used = ((char *)result - (char *)purebeg) + size;
+ if (type >= 0)
+ {
+ /* Allocate space for a Lisp object from the beginning of the free
+ space with taking account of alignment. */
+ result = ALIGN (purebeg + pure_bytes_used_lisp, alignment);
+ pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
+ }
+ else
+ {
+ /* Allocate space for a non-Lisp object from the end of the free
+ space. */
+ pure_bytes_used_non_lisp += size;
+ result = purebeg + pure_size - pure_bytes_used_non_lisp;
+ }
+ pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
if (pure_bytes_used <= pure_size)
return result;
pure_size = 10000;
pure_bytes_used_before_overflow += pure_bytes_used - size;
pure_bytes_used = 0;
+ pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
goto again;
}
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));
}
+/* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
+ the non-Lisp data pool of the pure storage, and return its start
+ address. Return NULL if not found. */
+
+static char *
+find_string_data_in_pure (data, nbytes)
+ char *data;
+ int nbytes;
+{
+ int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
+ unsigned char *p;
+ char *non_lisp_beg;
+
+ if (pure_bytes_used_non_lisp < nbytes + 1)
+ return NULL;
+
+ /* Set up the Boyer-Moore table. */
+ skip = nbytes + 1;
+ for (i = 0; i < 256; i++)
+ bm_skip[i] = skip;
+
+ p = (unsigned char *) data;
+ while (--skip > 0)
+ bm_skip[*p++] = skip;
+
+ last_char_skip = bm_skip['\0'];
+
+ non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
+ start_max = pure_bytes_used_non_lisp - (nbytes + 1);
+
+ /* See the comments in the function `boyer_moore' (search.c) for the
+ use of `infinity'. */
+ infinity = pure_bytes_used_non_lisp + 1;
+ bm_skip['\0'] = infinity;
+
+ p = (unsigned char *) non_lisp_beg + nbytes;
+ start = 0;
+ do
+ {
+ /* Check the last character (== '\0'). */
+ do
+ {
+ start += bm_skip[*(p + start)];
+ }
+ while (start <= start_max);
+
+ if (start < infinity)
+ /* Couldn't find the last character. */
+ return NULL;
+
+ /* No less than `infinity' means we could find the last
+ character at `p[start - infinity]'. */
+ start -= infinity;
+
+ /* Check the remaining characters. */
+ if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
+ /* Found. */
+ return non_lisp_beg + start;
+
+ start += last_char_skip;
+ }
+ while (start <= start_max);
+
+ return NULL;
+}
+
+
/* Return a string allocated in pure space. DATA is a buffer holding
NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
non-zero means make the result string multibyte.
struct Lisp_String *s;
s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
- s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
+ s->data = find_string_data_in_pure (data, nbytes);
+ if (s->data == NULL)
+ {
+ s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
+ bcopy (data, s->data, nbytes);
+ s->data[nbytes] = '\0';
+ }
s->size = nchars;
s->size_byte = multibyte ? nbytes : -1;
- bcopy (data, s->data, nbytes);
- s->data[nbytes] = '\0';
s->intervals = NULL_INTERVAL;
XSETSTRING (string, s);
return string;
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)
mark_object (bind->symbol);
mark_object (bind->old_value);
}
+ mark_terminals ();
mark_kboards ();
+ mark_ttys ();
#ifdef USE_GTK
{
mark_object (ptr->menu_bar_vector);
mark_object (ptr->buffer_predicate);
mark_object (ptr->buffer_list);
+ mark_object (ptr->buried_buffer_list);
mark_object (ptr->menu_bar_window);
mark_object (ptr->tool_bar_window);
mark_face_cache (ptr->face_cache);
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]);
}
purebeg = PUREBEG;
pure_size = PURESIZE;
pure_bytes_used = 0;
+ pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
pure_bytes_used_before_overflow = 0;
/* Initialize the list of free aligned blocks. */
HCoop / bpt / emacs.git / blobdiff