/* 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, 2003
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>
replaced, this file likely will not be used. */
#undef HIDE_LISP_IMPLEMENTATION
-#define DOC_STRINGS_IN_COMMENTS
#include "lisp.h"
#include "process.h"
#include "intervals.h"
/* 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! */
/* 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. */
struct mem_node
{
- struct mem_node *left, *right, *parent;
+ /* Children of this node. These pointers are never NULL. When there
+ is no child, the value is MEM_NIL, which points to a dummy node. */
+ struct mem_node *left, *right;
+
+ /* The parent of this node. In the root node, this is NULL. */
+ struct mem_node *parent;
/* Start and end of allocated region. */
void *start, *end;
/* 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);
/* 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.
-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.
-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;
}
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;
DEFUN ("list", Flist, Slist, 0, MANY, 0,
- /* Return a newly created list with specified arguments as elements.
-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.
-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.
+ 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))
+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.
-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.
+ 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. */
- (nargs, args))
+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.
-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->xname = name;
p->plist = Qnil;
p->value = Qunbound;
p->function = Qunbound;
return val;
}
+/* Return a Lisp_Misc_Save_Value object containing POINTER and
+ INTEGER. This is used to package C values to call record_unwind_protect.
+ The unwind function can get the C values back using XSAVE_VALUE. */
+
+Lisp_Object
+make_save_value (pointer, integer)
+ void *pointer;
+ int integer;
+{
+ register Lisp_Object val;
+ register struct Lisp_Save_Value *p;
+
+ val = allocate_misc ();
+ XMISCTYPE (val) = Lisp_Misc_Save_Value;
+ p = XSAVE_VALUE (val);
+ p->pointer = pointer;
+ p->integer = integer;
+ 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
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];
args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
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);
mark_maybe_pointer (*pp);
}
+/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
+ the GCC system configuration. In gcc 3.2, the only systems for
+ which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
+ by others?) and ns32k-pc532-min. */
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
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\
+\n\
+Note that you may get false negatives, depending on the compiler.\n\
+In particular, you need to use -O with GCC for this test.\n\
+\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;
+
+ again:
+ beg = purebeg;
+ result = (POINTER_TYPE *) (beg + pure_bytes_used);
+ nbytes = ALIGN (size, sizeof (EMACS_INT));
/* Give Lisp_Floats an extra alignment. */
if (type == Lisp_Float)
{
+ POINTER_TYPE *orig = result;
size_t alignment;
#if defined __GNUC__ && __GNUC__ >= 2
alignment = __alignof (struct Lisp_Float);
#else
alignment = sizeof (struct Lisp_Float);
#endif
- pure_bytes_used = ALIGN (pure_bytes_used, alignment);
+ /* Make sure result is correctly aligned for a
+ Lisp_Float, which might need stricter alignment than
+ EMACS_INT. */
+ result = (POINTER_TYPE *)ALIGN((EMACS_UINT)result, alignment);
+ nbytes += (char *)result - (char *)orig;
}
- nbytes = ALIGN (size, sizeof (EMACS_INT));
-
if (pure_bytes_used + nbytes > pure_size)
{
- beg = purebeg = (char *) xmalloc (PURESIZE);
- pure_size = PURESIZE;
+ /* Don't allocate a large amount here,
+ because it might get mmap'd and then its address
+ might not be usable. */
+ purebeg = (char *) xmalloc (10000);
+ pure_size = 10000;
pure_bytes_used_before_overflow += pure_bytes_used;
pure_bytes_used = 0;
+ goto again;
}
- result = (POINTER_TYPE *) (beg + pure_bytes_used);
pure_bytes_used += nbytes;
return result;
}
-/* Signal an error if PURESIZE is too small. */
+/* Print a warning if PURESIZE is too small. */
void
check_pure_size ()
{
if (pure_bytes_used_before_overflow)
- error ("Pure Lisp storage overflow (approx. %d bytes needed)",
- (int) (pure_bytes_used + pure_bytes_used_before_overflow));
+ message ("Pure Lisp storage overflow (approx. %d bytes needed)",
+ (int) (pure_bytes_used + pure_bytes_used_before_overflow));
}
DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
- /* Make a copy of OBJECT in pure storage.
+ 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))
+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;
- specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM));
+ int count = SPECPDL_INDEX ();
+ int nbits = min (VALBITS, BITS_PER_INT);
+
+ 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.
+ 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. */
- ())
+`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. */
/* 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;
}
}
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;
}
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.
+ 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. */
- ())
+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.
+ 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.
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). */
- ())
+ (but the contents of a buffer's text do not count here). */)
+ ()
{
Lisp_Object consed[8];
void
syms_of_alloc ()
{
- DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
- /* *Number of bytes of consing between garbage collections.
+ DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
+ 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.
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. */);
+ DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
+ 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. */);
+ DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
+ 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. */);
+ DEFVAR_INT ("floats-consed", &floats_consed,
+ 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. */);
+ DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
+ 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. */);
+ DEFVAR_INT ("symbols-consed", &symbols_consed,
+ 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. */);
+ DEFVAR_INT ("string-chars-consed", &string_chars_consed,
+ 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. */);
+ DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
+ 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. */);
+ DEFVAR_INT ("intervals-consed", &intervals_consed,
+ 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. */);
+ DEFVAR_INT ("strings-consed", &strings_consed,
+ 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.
+ DEFVAR_LISP ("purify-flag", &Vpurify_flag,
+ 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.
+ DEFVAR_INT ("undo-limit", &undo_limit,
+ 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.
+ DEFVAR_INT ("undo-strong-limit", &undo_strong_limit,
+ 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. */);
+ DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
+ 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
- /* Hook run after garbage collection has finished. */);
+ 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");
HCoop / bpt / emacs.git / blobdiff