/* 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 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)
static __malloc_size_t bytes_used_when_full;
+static __malloc_size_t bytes_used_when_reconsidered;
+
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
EMACS_INT intervals_consed;
EMACS_INT strings_consed;
-/* Number of bytes of consing since GC before another GC should be done. */
+/* Minimum number of bytes of consing since GC before next GC. */
+
+EMACS_INT gc_cons_threshold;
+
+/* Similar minimum, computed from Vgc_cons_percentage. */
+
+EMACS_INT gc_relative_threshold;
-static EMACS_INT gc_cons_threshold;
-EMACS_INT gc_cons_combined_threshold;
static Lisp_Object Vgc_cons_percentage;
+/* Minimum number of bytes of consing since GC before next GC,
+ when memory is full. */
+
+EMACS_INT memory_full_cons_threshold;
+
/* Nonzero during GC. */
int gc_in_progress;
static int total_free_floats, total_floats;
/* Points to memory space allocated as "spare", to be freed if we run
- out of memory. */
+ out of memory. We keep one large block, four cons-blocks, and
+ two string blocks. */
-static char *spare_memory;
+char *spare_memory[7];
-/* Amount of spare memory to keep in reserve. */
+/* Amount of spare memory to keep in large reserve block. */
#define SPARE_MEMORY (1 << 14)
&& ((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. */
MEM_TYPE_WINDOW
};
+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
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
static void mem_delete_fixup P_ ((struct mem_node *));
static INLINE struct mem_node *mem_find P_ ((void *));
+
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
static void check_gcpros P_ ((void));
#endif
#ifdef DOUG_LEA_MALLOC
-# define BYTES_USED (mallinfo ().arena)
+# define BYTES_USED (mallinfo ().uordblks)
#else
# define BYTES_USED _bytes_used
#endif
-
-
-/* Called if malloc returns zero. */
-
-void
-memory_full ()
-{
- Vmemory_full = Qt;
-
-#ifndef SYSTEM_MALLOC
- bytes_used_when_full = BYTES_USED;
-#endif
-
- /* The first time we get here, free the spare memory. */
- if (spare_memory)
- {
- free (spare_memory);
- spare_memory = 0;
- }
-
- /* 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);
-}
-
-DEFUN ("memory-full-p", Fmemory_full_p, Smemory_full_p, 0, 0, 0,
- doc: /* t if memory is nearly full, nil otherwise. */)
- ()
-{
- return (spare_memory ? Qnil : Qt);
-}
-
+\f
/* Called if we can't allocate relocatable space for a buffer. */
void
memory_full ();
#endif
- Vmemory_full = Qt;
-
/* 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);
}
BLOCK_INPUT;
free (block);
UNBLOCK_INPUT;
+ /* We don't call refill_memory_reserve here
+ because that duplicates doing so in emacs_blocked_free
+ and the criterion should go there. */
}
/* 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;
\f
#ifndef SYSTEM_MALLOC
-/* If we released our reserve (due to running out of memory),
- and we have a fair amount free once again,
- try to set aside another reserve in case we run out once more.
-
- This is called when a relocatable block is freed in ralloc.c. */
-
-void
-refill_memory_reserve ()
-{
- if (spare_memory == 0)
- spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
-}
-
-\f
/* Arranging to disable input signals while we're in malloc.
This only works with GNU malloc. To help out systems which can't
#ifndef SYNC_INPUT
#ifndef DOUG_LEA_MALLOC
-extern void * (*__malloc_hook) P_ ((size_t));
-extern void * (*__realloc_hook) P_ ((void *, size_t));
-extern void (*__free_hook) P_ ((void *));
+extern void * (*__malloc_hook) P_ ((size_t, const void *));
+extern void * (*__realloc_hook) P_ ((void *, size_t, const void *));
+extern void (*__free_hook) P_ ((void *, const void *));
/* Else declared in malloc.h, perhaps with an extra arg. */
#endif /* DOUG_LEA_MALLOC */
-static void * (*old_malloc_hook) ();
-static void * (*old_realloc_hook) ();
-static void (*old_free_hook) ();
+static void * (*old_malloc_hook) P_ ((size_t, const void *));
+static void * (*old_realloc_hook) P_ ((void *, size_t, const void*));
+static void (*old_free_hook) P_ ((void*, const void*));
/* This function is used as the hook for free to call. */
static void
-emacs_blocked_free (ptr)
+emacs_blocked_free (ptr, ptr2)
void *ptr;
+ const void *ptr2;
{
+ EMACS_INT bytes_used_now;
+
BLOCK_INPUT_ALLOC;
#ifdef GC_MALLOC_CHECK
/* If we released our reserve (due to running out of memory),
and we have a fair amount free once again,
try to set aside another reserve in case we run out once more. */
- if (spare_memory == 0
+ if (! NILP (Vmemory_full)
/* Verify there is enough space that even with the malloc
hysteresis this call won't run out again.
The code here is correct as long as SPARE_MEMORY
is substantially larger than the block size malloc uses. */
&& (bytes_used_when_full
- > BYTES_USED + max (malloc_hysteresis, 4) * SPARE_MEMORY))
- spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
+ > ((bytes_used_when_reconsidered = BYTES_USED)
+ + max (malloc_hysteresis, 4) * SPARE_MEMORY)))
+ refill_memory_reserve ();
__free_hook = emacs_blocked_free;
UNBLOCK_INPUT_ALLOC;
/* This function is the malloc hook that Emacs uses. */
static void *
-emacs_blocked_malloc (size)
+emacs_blocked_malloc (size, ptr)
size_t size;
+ const void *ptr;
{
void *value;
/* This function is the realloc hook that Emacs uses. */
static void *
-emacs_blocked_realloc (ptr, size)
+emacs_blocked_realloc (ptr, size, ptr2)
void *ptr;
size_t size;
+ const void *ptr2;
{
void *value;
{
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
}
-/* 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_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++;
}
+\f
+/************************************************************************
+ Memory Full Handling
+ ************************************************************************/
+
+
+/* Called if malloc returns zero. */
+
+void
+memory_full ()
+{
+ int i;
+
+ Vmemory_full = Qt;
+
+ memory_full_cons_threshold = sizeof (struct cons_block);
+
+ /* The first time we get here, free the spare memory. */
+ for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
+ if (spare_memory[i])
+ {
+ if (i == 0)
+ free (spare_memory[i]);
+ else if (i >= 1 && i <= 4)
+ lisp_align_free (spare_memory[i]);
+ else
+ lisp_free (spare_memory[i]);
+ spare_memory[i] = 0;
+ }
+
+ /* Record the space now used. When it decreases substantially,
+ we can refill the memory reserve. */
+#ifndef SYSTEM_MALLOC
+ bytes_used_when_full = BYTES_USED;
+#endif
+
+ /* This used to call error, but if we've run out of memory, we could
+ get infinite recursion trying to build the string. */
+ xsignal (Qnil, Vmemory_signal_data);
+}
+
+/* If we released our reserve (due to running out of memory),
+ and we have a fair amount free once again,
+ try to set aside another reserve in case we run out once more.
+
+ This is called when a relocatable block is freed in ralloc.c,
+ and also directly from this file, in case we're not using ralloc.c. */
+
+void
+refill_memory_reserve ()
+{
+#ifndef SYSTEM_MALLOC
+ if (spare_memory[0] == 0)
+ spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
+ if (spare_memory[1] == 0)
+ spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block),
+ MEM_TYPE_CONS);
+ if (spare_memory[2] == 0)
+ spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block),
+ MEM_TYPE_CONS);
+ if (spare_memory[3] == 0)
+ spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block),
+ MEM_TYPE_CONS);
+ if (spare_memory[4] == 0)
+ spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block),
+ MEM_TYPE_CONS);
+ if (spare_memory[5] == 0)
+ spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block),
+ MEM_TYPE_STRING);
+ if (spare_memory[6] == 0)
+ spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block),
+ MEM_TYPE_STRING);
+ if (spare_memory[0] && spare_memory[1] && spare_memory[5])
+ Vmemory_full = Qnil;
+#endif
+}
\f
/************************************************************************
C Stack Marking
#endif
}
-
#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.
+ 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
+ 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
+ return valid_pointer_p (p);
+#else
+
+ m = mem_find (p);
+
+ if (m == MEM_NIL)
+ {
+ int valid = valid_pointer_p (p);
+ if (valid <= 0)
+ return valid;
+
+ if (SUBRP (obj))
+ return 1;
+
+ 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
/* 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)
if (gc_cons_threshold < 10000)
gc_cons_threshold = 10000;
- gc_cons_combined_threshold = gc_cons_threshold;
-
if (FLOATP (Vgc_cons_percentage))
{ /* Set gc_cons_combined_threshold. */
EMACS_INT total = 0;
- EMACS_INT threshold;
+
total += total_conses * sizeof (struct Lisp_Cons);
total += total_symbols * sizeof (struct Lisp_Symbol);
total += total_markers * sizeof (union Lisp_Misc);
total += total_floats * sizeof (struct Lisp_Float);
total += total_intervals * sizeof (struct interval);
total += total_strings * sizeof (struct Lisp_String);
-
- threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
- if (threshold > gc_cons_combined_threshold)
- gc_cons_combined_threshold = threshold;
+
+ gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
}
+ else
+ gc_relative_threshold = 0;
if (garbage_collection_messages)
{
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--;
}
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. */
malloc_hysteresis = 0;
#endif
- spare_memory = (char *) malloc (SPARE_MEMORY);
+ refill_memory_reserve ();
ignore_warnings = 0;
gcprolist = 0;
staticidx = 0;
consing_since_gc = 0;
gc_cons_threshold = 100000 * sizeof (Lisp_Object);
- gc_cons_combined_threshold = gc_cons_threshold;
+ gc_relative_threshold = 0;
+
#ifdef VIRT_ADDR_VARIES
malloc_sbrk_unused = 1<<22; /* A large number */
malloc_sbrk_used = 100000; /* as reasonable as any number */
build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
DEFVAR_LISP ("memory-full", &Vmemory_full,
- doc: /* Non-nil means we are handling a memory-full error. */);
+ doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
Vmemory_full = Qnil;
staticpro (&Qgc_cons_threshold);
DEFVAR_INT ("gcs-done", &gcs_done,
doc: /* Accumulated number of garbage collections done. */);
- defsubr (&Smemory_full_p);
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);