/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001
+ Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001, 2002
Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <config.h>
#include <stdio.h>
+#ifdef ALLOC_DEBUG
+#undef INLINE
+#endif
+
/* Note that this declares bzero on OSF/1. How dumb. */
#include <signal.h>
#endif /* not DOUG_LEA_MALLOC */
-#define max(A,B) ((A) > (B) ? (A) : (B))
-#define min(A,B) ((A) < (B) ? (A) : (B))
-
/* Macro to verify that storage intended for Lisp objects is not
out of range to fit in the space for a pointer.
ADDRESS is the start of the block, and SIZE
/* Count the amount of consing of various sorts of space. */
-int cons_cells_consed;
-int floats_consed;
-int vector_cells_consed;
-int symbols_consed;
-int string_chars_consed;
-int misc_objects_consed;
-int intervals_consed;
-int strings_consed;
+EMACS_INT cons_cells_consed;
+EMACS_INT floats_consed;
+EMACS_INT vector_cells_consed;
+EMACS_INT symbols_consed;
+EMACS_INT string_chars_consed;
+EMACS_INT misc_objects_consed;
+EMACS_INT intervals_consed;
+EMACS_INT strings_consed;
/* Number of bytes of consing since GC before another GC should be done. */
-int gc_cons_threshold;
+EMACS_INT gc_cons_threshold;
/* Nonzero during GC. */
/* Two limits controlling how much undo information to keep. */
-int undo_limit;
-int undo_strong_limit;
+EMACS_INT undo_limit;
+EMACS_INT undo_strong_limit;
/* Number of live and free conses etc. */
Lisp_Object Vpurify_flag;
+/* Non-nil means we are handling a memory-full error. */
+
+Lisp_Object Vmemory_full;
+
#ifndef HAVE_SHM
/* Force it into data space! */
EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {0,};
#define PUREBEG (char *) pure
-#else /* not HAVE_SHM */
+#else /* HAVE_SHM */
#define pure PURE_SEG_BITS /* Use shared memory segment */
#define PUREBEG (char *)PURE_SEG_BITS
-/* This variable is used only by the XPNTR macro when HAVE_SHM is
- defined. If we used the PURESIZE macro directly there, that would
- make most of Emacs dependent on puresize.h, which we don't want -
- you should be able to change that without too much recompilation.
- So map_in_data initializes pure_size, and the dependencies work
- out. */
+#endif /* HAVE_SHM */
+
+/* Pointer to the pure area, and its size. */
-EMACS_INT pure_size;
+static char *purebeg;
+static size_t pure_size;
-#endif /* not HAVE_SHM */
+/* Number of bytes of pure storage used before pure storage overflowed.
+ If this is non-zero, this implies that an overflow occurred. */
+
+static size_t pure_bytes_used_before_overflow;
/* Value is non-zero if P points into pure space. */
#define PURE_POINTER_P(P) \
(((PNTR_COMPARISON_TYPE) (P) \
- < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)) \
+ < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
&& ((PNTR_COMPARISON_TYPE) (P) \
- >= (PNTR_COMPARISON_TYPE) pure))
+ >= (PNTR_COMPARISON_TYPE) purebeg))
/* Index in pure at which next pure object will be allocated.. */
-int pure_bytes_used;
+EMACS_INT pure_bytes_used;
/* If nonzero, this is a warning delivered by malloc and not yet
displayed. */
/* Pre-computed signal argument for use when memory is exhausted. */
-Lisp_Object memory_signal_data;
+Lisp_Object Vmemory_signal_data;
/* Maximum amount of C stack to save when a GC happens. */
Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
+/* Hook run after GC has finished. */
+
+Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
+
static void mark_buffer P_ ((Lisp_Object));
static void mark_kboards P_ ((void));
static void gc_sweep P_ ((void));
static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT, enum mem_type));
static void lisp_free P_ ((POINTER_TYPE *));
static void mark_stack P_ ((void));
-static void init_stack P_ ((Lisp_Object *));
static int live_vector_p P_ ((struct mem_node *, void *));
static int live_buffer_p P_ ((struct mem_node *, void *));
static int live_string_p P_ ((struct mem_node *, void *));
/* Addresses of staticpro'd variables. */
-#define NSTATICS 1024
+#define NSTATICS 1280
Lisp_Object *staticvec[NSTATICS] = {0};
/* Index of next unused slot in staticvec. */
Malloc
************************************************************************/
-/* Write STR to Vstandard_output plus some advice on how to free some
- memory. Called when memory gets low. */
-
-Lisp_Object
-malloc_warning_1 (str)
- Lisp_Object str;
-{
- Fprinc (str, Vstandard_output);
- write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
- write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
- write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
- return Qnil;
-}
-
-
-/* Function malloc calls this if it finds we are near exhausting
- storage. */
+/* Function malloc calls this if it finds we are near exhausting storage. */
void
malloc_warning (str)
}
-/* Display a malloc warning in buffer *Danger*. */
+/* Display an already-pending malloc warning. */
void
display_malloc_warning ()
{
- register Lisp_Object val;
-
- val = build_string (pending_malloc_warning);
+ call3 (intern ("display-warning"),
+ intern ("alloc"),
+ build_string (pending_malloc_warning),
+ intern ("emergency"));
pending_malloc_warning = 0;
- internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val);
}
void
memory_full ()
{
+ Vmemory_full = Qt;
+
#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. */
while (1)
- Fsignal (Qnil, memory_signal_data);
+ Fsignal (Qnil, Vmemory_signal_data);
}
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 (Qerror, memory_signal_data);
+ Fsignal (Qnil, Vmemory_signal_data);
}
char *
xstrdup (s)
- char *s;
+ const char *s;
{
size_t len = strlen (s) + 1;
char *p = (char *) xmalloc (len);
struct buffer *
allocate_buffer ()
{
- return (struct buffer *) lisp_malloc (sizeof (struct buffer),
- MEM_TYPE_BUFFER);
+ struct buffer *b
+ = (struct buffer *) lisp_malloc (sizeof (struct buffer),
+ MEM_TYPE_BUFFER);
+ VALIDATE_LISP_STORAGE (b, sizeof *b);
+ return b;
}
a cast. */
XMARK (tree->up.obj);
- traverse_intervals (tree, 1, 0, mark_interval, Qnil);
+ traverse_intervals_noorder (tree, mark_interval, Qnil);
}
/* Lisp_Strings are allocated in string_block structures. When a new
string_block is allocated, all the Lisp_Strings it contains are
- added to a free-list stiing_free_list. When a new Lisp_String is
+ added to a free-list string_free_list. When a new Lisp_String is
needed, it is taken from that list. During the sweep phase of GC,
string_blocks that are entirely free are freed, except two which
we keep.
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive
-#ifdef macintosh
+#ifdef MAC_OS8
&& current_sblock
#endif
)
DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
- "Return a newly created string of length LENGTH, with each element being INIT.\n\
-Both LENGTH and INIT must be numbers.")
- (length, init)
+ doc: /* Return a newly created string of length LENGTH, with each element being INIT.
+Both LENGTH and INIT must be numbers. */)
+ (length, init)
Lisp_Object length, init;
{
register Lisp_Object val;
register unsigned char *p, *end;
int c, nbytes;
- CHECK_NATNUM (length, 0);
- CHECK_NUMBER (init, 1);
+ CHECK_NATNUM (length);
+ CHECK_NUMBER (init);
c = XINT (init);
if (SINGLE_BYTE_CHAR_P (c))
{
nbytes = XINT (length);
val = make_uninit_string (nbytes);
- p = XSTRING (val)->data;
- end = p + XSTRING (val)->size;
+ p = SDATA (val);
+ end = p + SCHARS (val);
while (p != end)
*p++ = c;
}
nbytes = len * XINT (length);
val = make_uninit_multibyte_string (XINT (length), nbytes);
- p = XSTRING (val)->data;
+ p = SDATA (val);
end = p + nbytes;
while (p != end)
{
DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
- "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
-LENGTH must be a number. INIT matters only in whether it is t or nil.")
- (length, init)
+ doc: /* Return a new bool-vector of length LENGTH, using INIT for as 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;
int real_init, i;
int length_in_chars, length_in_elts, bits_per_value;
- CHECK_NATNUM (length, 0);
+ CHECK_NATNUM (length);
bits_per_value = sizeof (EMACS_INT) * BITS_PER_CHAR;
Lisp_Object
make_string (contents, nbytes)
- char *contents;
+ const char *contents;
int nbytes;
{
register Lisp_Object val;
Lisp_Object
make_unibyte_string (contents, length)
- char *contents;
+ const char *contents;
int length;
{
register Lisp_Object val;
val = make_uninit_string (length);
- bcopy (contents, XSTRING (val)->data, length);
- SET_STRING_BYTES (XSTRING (val), -1);
+ bcopy (contents, SDATA (val), length);
+ STRING_SET_UNIBYTE (val);
return val;
}
Lisp_Object
make_multibyte_string (contents, nchars, nbytes)
- char *contents;
+ const char *contents;
int nchars, nbytes;
{
register Lisp_Object val;
val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, XSTRING (val)->data, nbytes);
+ bcopy (contents, SDATA (val), nbytes);
return val;
}
{
register Lisp_Object val;
val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, XSTRING (val)->data, nbytes);
- if (STRING_BYTES (XSTRING (val)) == XSTRING (val)->size)
- SET_STRING_BYTES (XSTRING (val), -1);
+ bcopy (contents, SDATA (val), nbytes);
+ if (SBYTES (val) == SCHARS (val))
+ STRING_SET_UNIBYTE (val);
return val;
}
{
register Lisp_Object val;
val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, XSTRING (val)->data, nbytes);
+ bcopy (contents, SDATA (val), nbytes);
if (!multibyte)
- SET_STRING_BYTES (XSTRING (val), -1);
+ STRING_SET_UNIBYTE (val);
return val;
}
Lisp_Object
build_string (str)
- char *str;
+ const char *str;
{
return make_string (str, strlen (str));
}
{
Lisp_Object val;
val = make_uninit_multibyte_string (length, length);
- SET_STRING_BYTES (XSTRING (val), -1);
+ STRING_SET_UNIBYTE (val);
return val;
}
struct Lisp_Float *float_free_list;
-/* Initialze float allocation. */
+/* Initialize float allocation. */
void
init_float ()
DEFUN ("cons", Fcons, Scons, 2, 2, 0,
- "Create a new cons, give it CAR and CDR as components, and return it.")
- (car, cdr)
+ doc: /* Create a new cons, give it CAR and CDR as components, and return it. */)
+ (car, cdr)
Lisp_Object car, cdr;
{
register Lisp_Object val;
XSETCONS (val, &cons_block->conses[cons_block_index++]);
}
- XCAR (val) = car;
- XCDR (val) = cdr;
+ XSETCAR (val, car);
+ XSETCDR (val, cdr);
consing_since_gc += sizeof (struct Lisp_Cons);
cons_cells_consed++;
return val;
DEFUN ("list", Flist, Slist, 0, MANY, 0,
- "Return a newly created list with specified arguments as elements.\n\
-Any number of arguments, even zero arguments, are allowed.")
- (nargs, args)
+ doc: /* Return a newly created list with specified arguments as elements.
+Any number of arguments, even zero arguments, are allowed.
+usage: (list &rest OBJECTS) */)
+ (nargs, args)
int nargs;
register Lisp_Object *args;
{
DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
- "Return a newly created list of length LENGTH, with each element being INIT.")
- (length, init)
+ doc: /* Return a newly created list of length LENGTH, with each element being INIT. */)
+ (length, init)
register Lisp_Object length, init;
{
register Lisp_Object val;
register int size;
- CHECK_NATNUM (length, 0);
+ CHECK_NATNUM (length);
size = XFASTINT (length);
val = Qnil;
DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
- "Return a newly created vector of length LENGTH, with each element being INIT.\n\
-See also the function `vector'.")
- (length, init)
+ doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
+See also the function `vector'. */)
+ (length, init)
register Lisp_Object length, init;
{
Lisp_Object vector;
register int index;
register struct Lisp_Vector *p;
- CHECK_NATNUM (length, 0);
+ CHECK_NATNUM (length);
sizei = XFASTINT (length);
p = allocate_vector (sizei);
DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
- "Return a newly created char-table, with purpose PURPOSE.\n\
-Each element is initialized to INIT, which defaults to nil.\n\
-PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
-The property's value should be an integer between 0 and 10.")
- (purpose, init)
+ doc: /* Return a newly created char-table, with purpose PURPOSE.
+Each element is initialized to INIT, which defaults to nil.
+PURPOSE should be a symbol which has a `char-table-extra-slots' property.
+The property's value should be an integer between 0 and 10. */)
+ (purpose, init)
register Lisp_Object purpose, init;
{
Lisp_Object vector;
Lisp_Object n;
- CHECK_SYMBOL (purpose, 1);
+ CHECK_SYMBOL (purpose);
n = Fget (purpose, Qchar_table_extra_slots);
- CHECK_NUMBER (n, 0);
+ CHECK_NUMBER (n);
if (XINT (n) < 0 || XINT (n) > 10)
args_out_of_range (n, Qnil);
/* Add 2 to the size for the defalt and parent slots. */
DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
- "Return a newly created vector with specified arguments as elements.\n\
-Any number of arguments, even zero arguments, are allowed.")
- (nargs, args)
+ doc: /* Return a newly created vector with specified arguments as elements.
+Any number of arguments, even zero arguments, are allowed.
+usage: (vector &rest OBJECTS) */)
+ (nargs, args)
register int nargs;
Lisp_Object *args;
{
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
- "Create a byte-code object with specified arguments as elements.\n\
-The arguments should be the arglist, bytecode-string, constant vector,\n\
-stack size, (optional) doc string, and (optional) interactive spec.\n\
-The first four arguments are required; at most six have any\n\
-significance.")
- (nargs, args)
+ doc: /* Create a byte-code object with specified arguments as elements.
+The arguments should be the arglist, bytecode-string, constant vector,
+stack size, (optional) doc string, and (optional) interactive spec.
+The first four arguments are required; at most six have any
+significance.
+usage: (make-byte-code &rest ELEMENTS) */)
+ (nargs, args)
register int nargs;
Lisp_Object *args;
{
DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
- "Return a newly allocated uninterned symbol whose name is NAME.\n\
-Its value and function definition are void, and its property list is nil.")
- (name)
+ doc: /* Return a newly allocated uninterned symbol whose name is NAME.
+Its value and function definition are void, and its property list is nil. */)
+ (name)
Lisp_Object name;
{
register Lisp_Object val;
register struct Lisp_Symbol *p;
- CHECK_STRING (name, 0);
+ CHECK_STRING (name);
if (symbol_free_list)
{
}
p = XSYMBOL (val);
- p->name = XSTRING (name);
- p->obarray = Qnil;
+ p->xname = name;
p->plist = Qnil;
p->value = Qunbound;
p->function = Qunbound;
- p->next = 0;
+ p->next = NULL;
+ p->interned = SYMBOL_UNINTERNED;
+ p->constant = 0;
+ p->indirect_variable = 0;
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
return val;
}
DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
- "Return a newly allocated marker which does not point at any place.")
- ()
+ doc: /* Return a newly allocated marker which does not point at any place. */)
+ ()
{
register Lisp_Object val;
register struct Lisp_Marker *p;
result = Fmake_string (make_number (nargs), make_number (0));
for (i = 0; i < nargs; i++)
{
- XSTRING (result)->data[i] = XINT (args[i]);
+ SSET (result, i, XINT (args[i]));
/* Move the meta bit to the right place for a string char. */
if (XINT (args[i]) & CHAR_META)
- XSTRING (result)->data[i] |= 0x80;
+ SSET (result, i, SREF (result, i) | 0x80);
}
return result;
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
+/* Conservative C stack marking requires a method to identify possibly
+ live Lisp objects given a pointer value. We do this by keeping
+ track of blocks of Lisp data that are allocated in a red-black tree
+ (see also the comment of mem_node which is the type of nodes in
+ that tree). Function lisp_malloc adds information for an allocated
+ block to the red-black tree with calls to mem_insert, and function
+ lisp_free removes it with mem_delete. Functions live_string_p etc
+ call mem_find to lookup information about a given pointer in the
+ tree, and use that to determine if the pointer points to a Lisp
+ object or not. */
+
/* Initialize this part of alloc.c. */
static void
/* P must point to the start of a Lisp_String structure, and it
must not be on the free-list. */
- return (offset % sizeof b->strings[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->strings[0] == 0
&& ((struct Lisp_String *) p)->data != NULL);
}
else
/* P must point to the start of a Lisp_Cons, not be
one of the unused cells in the current cons block,
and not be on the free-list. */
- return (offset % sizeof b->conses[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->conses[0] == 0
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index)
&& !EQ (((struct Lisp_Cons *) p)->car, Vdead));
/* P must point to the start of a Lisp_Symbol, not be
one of the unused cells in the current symbol block,
and not be on the free-list. */
- return (offset % sizeof b->symbols[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->symbols[0] == 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, not be
one of the unused cells in the current float block,
and not be on the free-list. */
- return (offset % sizeof b->floats[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->floats[0] == 0
&& (b != float_block
|| offset / sizeof b->floats[0] < float_block_index)
&& !EQ (((struct Lisp_Float *) p)->type, Vdead));
/* P must point to the start of a Lisp_Misc, not be
one of the unused cells in the current misc block,
and not be on the free-list. */
- return (offset % sizeof b->markers[0] == 0
+ return (offset >= 0
+ && offset % sizeof b->markers[0] == 0
&& (b != marker_block
|| offset / sizeof b->markers[0] < marker_block_index)
&& ((union Lisp_Misc *) p)->u_marker.type != Lisp_Misc_Free);
static double avg_live;
DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
- "Show information about live and zombie objects.")
+ doc: /* Show information about live and zombie objects. */)
()
{
Lisp_Object args[7];
only a pointer to them remains. Example:
DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
- ()
+ ()
{
Lisp_Object obj = build_string ("test");
struct Lisp_String *s = XSTRING (obj);
who is, please take a look at the function mark_stack in alloc.c, and\n\
verify that the methods used are appropriate for your system.\n\
\n\
-Please mail the result to <gerd@gnu.org>.\n\
+Please mail the result to <emacs-devel@gnu.org>.\n\
"
#define SETJMP_WILL_NOT_WORK "\
\n\
Please take a look at the function mark_stack in alloc.c, and\n\
try to find a way to make it work on your system.\n\
-Please mail the result to <gerd@gnu.org>.\n\
+Please mail the result to <emacs-devel@gnu.org>.\n\
"
static void
mark_stack ()
{
+ int i;
jmp_buf j;
volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
void *end;
/* This assumes that the stack is a contiguous region in memory. If
that's not the case, something has to be done here to iterate
over the stack segments. */
-#if GC_LISP_OBJECT_ALIGNMENT == 1
- mark_memory (stack_base, end);
- mark_memory ((char *) stack_base + 1, end);
- mark_memory ((char *) stack_base + 2, end);
- mark_memory ((char *) stack_base + 3, end);
-#elif GC_LISP_OBJECT_ALIGNMENT == 2
- mark_memory (stack_base, end);
- mark_memory ((char *) stack_base + 2, end);
-#else
- mark_memory (stack_base, end);
+#ifndef GC_LISP_OBJECT_ALIGNMENT
+#define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
#endif
+ for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
+ mark_memory ((char *) stack_base + i, end);
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
check_gcpros ();
{
size_t nbytes;
POINTER_TYPE *result;
- char *beg = PUREBEG;
+ char *beg = purebeg;
/* Give Lisp_Floats an extra alignment. */
if (type == Lisp_Float)
}
nbytes = ALIGN (size, sizeof (EMACS_INT));
- if (pure_bytes_used + nbytes > PURESIZE)
- error ("Pure Lisp storage exhausted");
+
+ if (pure_bytes_used + nbytes > pure_size)
+ {
+ /* Don't allocate a large amount here,
+ because it might get mmap'd and then its address
+ might not be usable. */
+ beg = purebeg = (char *) xmalloc (10000);
+ pure_size = 10000;
+ pure_bytes_used_before_overflow += pure_bytes_used;
+ pure_bytes_used = 0;
+ }
result = (POINTER_TYPE *) (beg + pure_bytes_used);
pure_bytes_used += nbytes;
}
+/* Print a warning if PURESIZE is too small. */
+
+void
+check_pure_size ()
+{
+ if (pure_bytes_used_before_overflow)
+ message ("Pure Lisp storage overflow (approx. %d bytes needed)",
+ (int) (pure_bytes_used + pure_bytes_used_before_overflow));
+}
+
+
/* 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.
p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
XSETCONS (new, p);
- XCAR (new) = Fpurecopy (car);
- XCDR (new) = Fpurecopy (cdr);
+ XSETCAR (new, Fpurecopy (car));
+ XSETCDR (new, Fpurecopy (cdr));
return new;
}
DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
- "Make a copy of OBJECT in pure storage.\n\
-Recursively copies contents of vectors and cons cells.\n\
-Does not copy symbols. Copies strings without text properties.")
- (obj)
+ doc: /* Make a copy of OBJECT in pure storage.
+Recursively copies contents of vectors and cons cells.
+Does not copy symbols. Copies strings without text properties. */)
+ (obj)
register Lisp_Object obj;
{
if (NILP (Vpurify_flag))
else if (FLOATP (obj))
return make_pure_float (XFLOAT_DATA (obj));
else if (STRINGP (obj))
- return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size,
- STRING_BYTES (XSTRING (obj)),
+ return make_pure_string (SDATA (obj), SCHARS (obj),
+ SBYTES (obj),
STRING_MULTIBYTE (obj));
else if (COMPILEDP (obj) || VECTORP (obj))
{
int
inhibit_garbage_collection ()
{
- int count = specpdl_ptr - specpdl;
- Lisp_Object number;
+ int count = SPECPDL_INDEX ();
int nbits = min (VALBITS, BITS_PER_INT);
- XSETINT (number, ((EMACS_INT) 1 << (nbits - 1)) - 1);
-
- specbind (Qgc_cons_threshold, number);
-
+ specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));
return count;
}
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
- "Reclaim storage for Lisp objects no longer needed.\n\
-Returns info on amount of space in use:\n\
- ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
- (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
- (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)\n\
- (USED-STRINGS . FREE-STRINGS))\n\
-Garbage collection happens automatically if you cons more than\n\
-`gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
- ()
+ doc: /* Reclaim storage for Lisp objects no longer needed.
+Returns info on amount of space in use:
+ ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
+ (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
+ (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
+ (USED-STRINGS . FREE-STRINGS))
+Garbage collection happens automatically if you cons more than
+`gc-cons-threshold' bytes of Lisp data since previous garbage collection. */)
+ ()
{
register struct gcpro *tail;
register struct specbinding *bind;
register int i;
int message_p;
Lisp_Object total[8];
- int count = BINDING_STACK_SIZE ();
+ int count = SPECPDL_INDEX ();
+
+ /* Can't GC if pure storage overflowed because we can't determine
+ if something is a pure object or not. */
+ if (pure_bytes_used_before_overflow)
+ return Qnil;
/* In case user calls debug_print during GC,
don't let that cause a recursive GC. */
/* Save what's currently displayed in the echo area. */
message_p = push_message ();
- record_unwind_protect (push_message_unwind, Qnil);
+ record_unwind_protect (pop_message_unwind, Qnil);
/* Save a copy of the contents of the stack, for debugging. */
#if MAX_SAVE_STACK > 0
nextb->undo_list
= truncate_undo_list (nextb->undo_list, undo_limit,
undo_strong_limit);
+
+ /* Shrink buffer gaps, but skip indirect and dead buffers. */
+ if (nextb->base_buffer == 0 && !NILP (nextb->name))
+ {
+ /* If a buffer's gap size is more than 10% of the buffer
+ size, or larger than 2000 bytes, then shrink it
+ accordingly. Keep a minimum size of 20 bytes. */
+ int size = min (2000, max (20, (nextb->text->z_byte / 10)));
+
+ if (nextb->text->gap_size > size)
+ {
+ struct buffer *save_current = current_buffer;
+ current_buffer = nextb;
+ make_gap (-(nextb->text->gap_size - size));
+ current_buffer = save_current;
+ }
+ }
+
nextb = nextb->next;
}
}
if (NILP (prev))
nextb->undo_list = tail = XCDR (tail);
else
- tail = XCDR (prev) = XCDR (tail);
+ {
+ tail = XCDR (tail);
+ XSETCDR (prev, tail);
+ }
}
else
{
}
#endif
+ if (!NILP (Vpost_gc_hook))
+ {
+ int count = inhibit_garbage_collection ();
+ safe_run_hooks (Qpost_gc_hook);
+ unbind_to (count, Qnil);
+ }
+
return Flist (sizeof total / sizeof *total, total);
}
Lisp_Object *last_marked[LAST_MARKED_SIZE];
int last_marked_index;
+/* For debugging--call abort when we cdr down this many
+ links of a list, in mark_object. In debugging,
+ the call to abort will hit a breakpoint.
+ Normally this is zero and the check never goes off. */
+int mark_object_loop_halt;
+
void
mark_object (argptr)
Lisp_Object *argptr;
void *po;
struct mem_node *m;
#endif
+ int cdr_count = 0;
loop:
obj = *objptr;
h->size |= ARRAY_MARK_FLAG;
/* Mark contents. */
+ /* Do not mark next_free or next_weak.
+ Being in the next_weak chain
+ should not keep the hash table alive.
+ No need to mark `count' since it is an integer. */
mark_object (&h->test);
mark_object (&h->weak);
mark_object (&h->rehash_size);
mark_object (&ptr->function);
mark_object (&ptr->plist);
- if (!PURE_POINTER_P (ptr->name))
- MARK_STRING (ptr->name);
- MARK_INTERVAL_TREE (ptr->name->intervals);
+ if (!PURE_POINTER_P (XSTRING (ptr->xname)))
+ MARK_STRING (XSTRING (ptr->xname));
+ MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
/* Note that we do not mark the obarray of the symbol.
It is safe not to do so because nothing accesses that
if (EQ (ptr->cdr, Qnil))
{
objptr = &ptr->car;
+ cdr_count = 0;
goto loop;
}
mark_object (&ptr->car);
objptr = &ptr->cdr;
+ cdr_count++;
+ if (cdr_count == mark_object_loop_halt)
+ abort ();
goto loop;
}
&& ! XMARKBIT (XCAR (ptr->car))
&& GC_MARKERP (XCAR (ptr->car)))
{
- XMARK (XCAR (ptr->car));
- mark_object (&XCDR (ptr->car));
+ XMARK (XCAR_AS_LVALUE (ptr->car));
+ mark_object (&XCDR_AS_LVALUE (ptr->car));
}
else
mark_object (&ptr->car);
break;
}
- mark_object (&XCDR (tail));
+ mark_object (&XCDR_AS_LVALUE (tail));
}
else
mark_object (&buffer->undo_list);
mark_object (&kb->Vsystem_key_alist);
mark_object (&kb->system_key_syms);
mark_object (&kb->Vdefault_minibuffer_frame);
+ mark_object (&kb->echo_string);
}
}
/* Check if the symbol was created during loadup. In such a case
it might be pointed to by pure bytecode which we don't trace,
so we conservatively assume that it is live. */
- int pure_p = PURE_POINTER_P (sym->name);
+ int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
if (!XMARKBIT (sym->plist) && !pure_p)
{
{
++num_used;
if (!pure_p)
- UNMARK_STRING (sym->name);
+ UNMARK_STRING (XSTRING (sym->xname));
XUNMARK (sym->plist);
}
}
/* Debugging aids. */
DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
- "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
-This may be helpful in debugging Emacs's memory usage.\n\
-We divide the value by 1024 to make sure it fits in a Lisp integer.")
- ()
+ doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
+This may be helpful in debugging Emacs's memory usage.
+We divide the value by 1024 to make sure it fits in a Lisp integer. */)
+ ()
{
Lisp_Object end;
}
DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
- "Return a list of counters that measure how much consing there has been.\n\
-Each of these counters increments for a certain kind of object.\n\
-The counters wrap around from the largest positive integer to zero.\n\
-Garbage collection does not decrease them.\n\
-The elements of the value are as follows:\n\
- (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
-All are in units of 1 = one object consed\n\
-except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
-objects consed.\n\
-MISCS include overlays, markers, and some internal types.\n\
-Frames, windows, buffers, and subprocesses count as vectors\n\
- (but the contents of a buffer's text do not count here).")
- ()
+ doc: /* Return a list of counters that measure how much consing there has been.
+Each of these counters increments for a certain kind of object.
+The counters wrap around from the largest positive integer to zero.
+Garbage collection does not decrease them.
+The elements of the value are as follows:
+ (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
+All are in units of 1 = one object consed
+except for VECTOR-CELLS and STRING-CHARS, which count the total length of
+objects consed.
+MISCS include overlays, markers, and some internal types.
+Frames, windows, buffers, and subprocesses count as vectors
+ (but the contents of a buffer's text do not count here). */)
+ ()
{
Lisp_Object consed[8];
- XSETINT (consed[0],
- cons_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
- XSETINT (consed[1],
- floats_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
- XSETINT (consed[2],
- vector_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
- XSETINT (consed[3],
- symbols_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
- XSETINT (consed[4],
- string_chars_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
- XSETINT (consed[5],
- misc_objects_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
- XSETINT (consed[6],
- intervals_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
- XSETINT (consed[7],
- strings_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
+ consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed));
+ consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed));
+ consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed));
+ consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed));
+ consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed));
+ consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed));
+ consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed));
+ consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
return Flist (8, consed);
}
init_alloc_once ()
{
/* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
+ purebeg = PUREBEG;
+ pure_size = PURESIZE;
pure_bytes_used = 0;
+ pure_bytes_used_before_overflow = 0;
+
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
mem_init ();
Vdead = make_pure_string ("DEAD", 4, 4, 0);
#endif
-#ifdef HAVE_SHM
- pure_size = PURESIZE;
-#endif
+
all_vectors = 0;
ignore_warnings = 1;
#ifdef DOUG_LEA_MALLOC
syms_of_alloc ()
{
DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
- "*Number of bytes of consing between garbage collections.\n\
-Garbage collection can happen automatically once this many bytes have been\n\
-allocated since the last garbage collection. All data types count.\n\n\
-Garbage collection happens automatically only when `eval' is called.\n\n\
-By binding this temporarily to a large number, you can effectively\n\
-prevent garbage collection during a part of the program.");
+ doc: /* *Number of bytes of consing between garbage collections.
+Garbage collection can happen automatically once this many bytes have been
+allocated since the last garbage collection. All data types count.
+
+Garbage collection happens automatically only when `eval' is called.
+
+By binding this temporarily to a large number, you can effectively
+prevent garbage collection during a part of the program. */);
DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
- "Number of bytes of sharable Lisp data allocated so far.");
+ doc: /* Number of bytes of sharable Lisp data allocated so far. */);
DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
- "Number of cons cells that have been consed so far.");
+ doc: /* Number of cons cells that have been consed so far. */);
DEFVAR_INT ("floats-consed", &floats_consed,
- "Number of floats that have been consed so far.");
+ doc: /* Number of floats that have been consed so far. */);
DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
- "Number of vector cells that have been consed so far.");
+ doc: /* Number of vector cells that have been consed so far. */);
DEFVAR_INT ("symbols-consed", &symbols_consed,
- "Number of symbols that have been consed so far.");
+ doc: /* Number of symbols that have been consed so far. */);
DEFVAR_INT ("string-chars-consed", &string_chars_consed,
- "Number of string characters that have been consed so far.");
+ doc: /* Number of string characters that have been consed so far. */);
DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
- "Number of miscellaneous objects that have been consed so far.");
+ doc: /* Number of miscellaneous objects that have been consed so far. */);
DEFVAR_INT ("intervals-consed", &intervals_consed,
- "Number of intervals that have been consed so far.");
+ doc: /* Number of intervals that have been consed so far. */);
DEFVAR_INT ("strings-consed", &strings_consed,
- "Number of strings that have been consed so far.");
+ doc: /* Number of strings that have been consed so far. */);
DEFVAR_LISP ("purify-flag", &Vpurify_flag,
- "Non-nil means loading Lisp code in order to dump an executable.\n\
-This means that certain objects should be allocated in shared (pure) space.");
+ doc: /* Non-nil means loading Lisp code in order to dump an executable.
+This means that certain objects should be allocated in shared (pure) space. */);
DEFVAR_INT ("undo-limit", &undo_limit,
- "Keep no more undo information once it exceeds this size.\n\
-This limit is applied when garbage collection happens.\n\
-The size is counted as the number of bytes occupied,\n\
-which includes both saved text and other data.");
+ doc: /* Keep no more undo information once it exceeds this size.
+This limit is applied when garbage collection happens.
+The size is counted as the number of bytes occupied,
+which includes both saved text and other data. */);
undo_limit = 20000;
DEFVAR_INT ("undo-strong-limit", &undo_strong_limit,
- "Don't keep more than this much size of undo information.\n\
-A command which pushes past this size is itself forgotten.\n\
-This limit is applied when garbage collection happens.\n\
-The size is counted as the number of bytes occupied,\n\
-which includes both saved text and other data.");
+ doc: /* Don't keep more than this much size of undo information.
+A command which pushes past this size is itself forgotten.
+This limit is applied when garbage collection happens.
+The size is counted as the number of bytes occupied,
+which includes both saved text and other data. */);
undo_strong_limit = 30000;
DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
- "Non-nil means display messages at start and end of garbage collection.");
+ doc: /* Non-nil means display messages at start and end of garbage collection. */);
garbage_collection_messages = 0;
+ DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook,
+ doc: /* Hook run after garbage collection has finished. */);
+ Vpost_gc_hook = Qnil;
+ Qpost_gc_hook = intern ("post-gc-hook");
+ staticpro (&Qpost_gc_hook);
+
+ DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
+ doc: /* Precomputed `signal' argument for memory-full error. */);
/* We build this in advance because if we wait until we need it, we might
not be able to allocate the memory to hold it. */
- memory_signal_data
- = Fcons (Qerror, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil));
- staticpro (&memory_signal_data);
+ Vmemory_signal_data
+ = list2 (Qerror,
+ 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. */);
+ Vmemory_full = Qnil;
staticpro (&Qgc_cons_threshold);
Qgc_cons_threshold = intern ("gc-cons-threshold");