/* 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>
#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
- is the amount of space within which objects can start. */
-
-#define VALIDATE_LISP_STORAGE(address, size) \
-do \
- { \
- Lisp_Object val; \
- XSETCONS (val, (char *) address + size); \
- if ((char *) XCONS (val) != (char *) address + size) \
- { \
- xfree (address); \
- memory_full (); \
- } \
- } while (0)
-
/* Value of _bytes_used, when spare_memory was freed. */
static __malloc_size_t bytes_used_when_full;
/* 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. */
int gc_in_progress;
+/* Nonzero means abort if try to GC.
+ This is for code which is written on the assumption that
+ no GC will happen, so as to verify that assumption. */
+
+int abort_on_gc;
+
/* Nonzero means display messages at beginning and end of GC. */
int garbage_collection_messages;
/* 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 */
-EMACS_INT pure_size;
+/* Pointer to the pure area, and its size. */
-#endif /* not HAVE_SHM */
+static char *purebeg;
+static size_t pure_size;
+
+/* 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;
+
+Lisp_Object Vgc_elapsed; /* accumulated elapsed time in GC */
+EMACS_INT gcs_done; /* accumulated GCs */
+
static void mark_buffer P_ ((Lisp_Object));
static void mark_kboards P_ ((void));
static void gc_sweep P_ ((void));
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;
/* Node color. */
enum {MEM_BLACK, MEM_RED} color;
-
+
/* Memory type. */
enum mem_type type;
};
/* 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);
number of bytes to allocate, TYPE describes the intended use of the
allcated memory block (for strings, for conses, ...). */
+static void *lisp_malloc_loser;
+
static POINTER_TYPE *
lisp_malloc (nbytes, type)
size_t nbytes;
#ifdef GC_MALLOC_CHECK
allocated_mem_type = type;
#endif
-
+
val = (void *) malloc (nbytes);
+ /* If the memory just allocated cannot be addressed thru a Lisp
+ object's pointer, and it needs to be,
+ that's equivalent to running out of memory. */
+ if (val && type != MEM_TYPE_NON_LISP)
+ {
+ Lisp_Object tem;
+ XSETCONS (tem, (char *) val + nbytes - 1);
+ if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
+ {
+ lisp_malloc_loser = val;
+ free (val);
+ val = 0;
+ }
+ }
+
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
if (val && type != MEM_TYPE_NON_LISP)
mem_insert (val, (char *) val + nbytes, type);
#endif
-
+
UNBLOCK_INPUT;
if (!val && nbytes)
memory_full ();
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);
+ return b;
}
elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
pairs; unfortunately, we have no idea what C library functions
might call malloc, so we can't really protect them unless you're
- using GNU malloc. Fortunately, most of the major operating can use
- GNU malloc. */
+ using GNU malloc. Fortunately, most of the major operating systems
+ can use GNU malloc. */
#ifndef SYSTEM_MALLOC
#ifndef DOUG_LEA_MALLOC
if (ptr)
{
struct mem_node *m;
-
+
m = mem_find (ptr);
if (m == MEM_NIL || m->start != ptr)
{
}
}
#endif /* GC_MALLOC_CHECK */
-
+
__free_hook = old_free_hook;
free (ptr);
-
+
/* 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. */
}
}
#endif /* GC_MALLOC_CHECK */
-
+
__malloc_hook = emacs_blocked_malloc;
UNBLOCK_INPUT;
mem_delete (m);
}
-
+
/* fprintf (stderr, "%p -> realloc\n", ptr); */
-
+
/* Prevent malloc from registering blocks. */
dont_register_blocks = 1;
#endif /* GC_MALLOC_CHECK */
/* Can't handle zero size regions in the red-black tree. */
mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
}
-
+
/* fprintf (stderr, "%p <- realloc\n", value); */
#endif /* GC_MALLOC_CHECK */
-
+
__realloc_hook = emacs_blocked_realloc;
UNBLOCK_INPUT;
newi = (struct interval_block *) lisp_malloc (sizeof *newi,
MEM_TYPE_NON_LISP);
- VALIDATE_LISP_STORAGE (newi, sizeof *newi);
newi->next = interval_block;
interval_block = newi;
interval_block_index = 0;
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.
struct Lisp_String *string;
#ifdef GC_CHECK_STRING_BYTES
-
+
EMACS_INT nbytes;
unsigned char data[1];
-
+
#define SDATA_NBYTES(S) (S)->nbytes
#define SDATA_DATA(S) (S)->data
-
+
#else /* not GC_CHECK_STRING_BYTES */
union
/* When STRING is null. */
EMACS_INT nbytes;
} u;
-
+
#define SDATA_NBYTES(S) (S)->u.nbytes
#define SDATA_DATA(S) (S)->u.data
S must be live, i.e. S->data must not be null. S->data is actually
a pointer to the `u.data' member of its sdata structure; the
structure starts at a constant offset in front of that. */
-
+
#ifdef GC_CHECK_STRING_BYTES
#define SDATA_OF_STRING(S) \
abort ();
return nbytes;
}
-
-/* Check validity Lisp strings' string_bytes member in B. */
+
+/* Check validity of Lisp strings' string_bytes member in B. */
void
check_sblock (b)
struct sblock *b;
{
struct sdata *from, *end, *from_end;
-
+
end = b->next_free;
-
+
for (from = &b->first_data; from < end; from = from_end)
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
int nbytes;
-
+
/* Check that the string size recorded in the string is the
same as the one recorded in the sdata structure. */
if (from->string)
CHECK_STRING_BYTES (from->string);
-
+
if (from->string)
nbytes = GC_STRING_BYTES (from->string);
else
nbytes = SDATA_NBYTES (from);
-
+
nbytes = SDATA_SIZE (nbytes);
from_end = (struct sdata *) ((char *) from + nbytes);
}
if (s)
CHECK_STRING_BYTES (s);
}
-
+
for (b = oldest_sblock; b; b = b->next)
check_sblock (b);
}
int i;
b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
- VALIDATE_LISP_STORAGE (b, sizeof *b);
bzero (b, sizeof *b);
b->next = string_blocks;
string_blocks = b;
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive
-#ifdef macintosh
+#ifdef MAC_OS8
&& current_sblock
#endif
)
#endif
b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP);
-
+
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
-
+
b->next_free = &b->first_data;
b->first_data.string = NULL;
b->next = large_sblocks;
old_data = s->data ? SDATA_OF_STRING (s) : NULL;
old_nbytes = GC_STRING_BYTES (s);
-
+
data = b->next_free;
data->string = s;
s->data = SDATA_DATA (data);
s->size_byte = nbytes;
s->data[nbytes] = '\0';
b->next_free = (struct sdata *) ((char *) data + needed);
-
+
/* 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
in it. */
{
struct string_block *b, *next;
struct string_block *live_blocks = NULL;
-
+
string_free_list = NULL;
total_strings = total_free_strings = 0;
total_string_size = 0;
{
/* String is live; unmark it and its intervals. */
UNMARK_STRING (s);
-
+
if (!NULL_INTERVAL_P (s->intervals))
UNMARK_BALANCE_INTERVALS (s->intervals);
{
struct sblock *b, *next;
struct sblock *live_blocks = NULL;
-
+
for (b = large_sblocks; b; b = next)
{
next = b->next;
{
end = b->next_free;
xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
-
+
for (from = &b->first_data; from < end; from = from_end)
{
/* Compute the next FROM here because copying below may
&& GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
abort ();
#endif /* GC_CHECK_STRING_BYTES */
-
+
if (from->string)
nbytes = GC_STRING_BYTES (from->string);
else
nbytes = SDATA_NBYTES (from);
-
+
nbytes = SDATA_SIZE (nbytes);
from_end = (struct sdata *) ((char *) from + nbytes);
-
+
/* FROM->string non-null means it's alive. Copy its data. */
if (from->string)
{
to = &tb->first_data;
to_end = (struct sdata *) ((char *) to + nbytes);
}
-
+
/* Copy, and update the string's `data' pointer. */
if (from != to)
{
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)
{
p += len;
}
}
-
+
*p = 0;
return val;
}
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;
slot `size' of the struct Lisp_Bool_Vector. */
val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
p = XBOOL_VECTOR (val);
-
+
/* Get rid of any bits that would cause confusion. */
p->vector_size = 0;
XSETBOOL_VECTOR (val, p);
p->size = XFASTINT (length);
-
+
real_init = (NILP (init) ? 0 : -1);
for (i = 0; i < length_in_chars ; i++)
p->data[i] = real_init;
-
+
/* Clear the extraneous bits in the last byte. */
if (XINT (length) != length_in_chars * BITS_PER_CHAR)
XBOOL_VECTOR (val)->data[length_in_chars - 1]
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;
}
Lisp_Object
make_string_from_bytes (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);
- 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;
}
/* Make a string from NCHARS characters occupying NBYTES bytes at
CONTENTS. The argument MULTIBYTE controls whether to label the
- string as multibyte. */
+ string as multibyte. If NCHARS is negative, it counts the number of
+ characters by itself. */
Lisp_Object
make_specified_string (contents, nchars, nbytes, multibyte)
- char *contents;
+ const char *contents;
int nchars, nbytes;
int multibyte;
{
register Lisp_Object val;
+
+ if (nchars < 0)
+ {
+ if (multibyte)
+ nchars = multibyte_chars_in_text (contents, nbytes);
+ else
+ nchars = nbytes;
+ }
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 ()
new = (struct float_block *) lisp_malloc (sizeof *new,
MEM_TYPE_FLOAT);
- VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = float_block;
float_block = new;
float_block_index = 0;
}
XSETFLOAT (val, &float_block->floats[float_block_index++]);
}
-
+
XFLOAT_DATA (val) = float_value;
XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */
consing_since_gc += sizeof (struct Lisp_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;
register struct cons_block *new;
new = (struct cons_block *) lisp_malloc (sizeof *new,
MEM_TYPE_CONS);
- VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
}
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;
{
val = Fcons (init, val);
--size;
-
+
if (size > 0)
{
val = Fcons (init, val);
--size;
-
+
if (size > 0)
{
val = Fcons (init, val);
--size;
-
+
if (size > 0)
{
val = Fcons (init, val);
QUIT;
}
-
+
return val;
}
a dumped Emacs. */
mallopt (M_MMAP_MAX, 0);
#endif
-
+
nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);
-
+
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
-
- VALIDATE_LISP_STORAGE (p, 0);
+
consing_since_gc += nbytes;
vector_cells_consed += len;
EMACS_INT len = VECSIZE (struct Lisp_Hash_Table);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE);
EMACS_INT i;
-
+
v->size = len;
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
-
+
return (struct Lisp_Hash_Table *) v;
}
EMACS_INT len = VECSIZE (struct window);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW);
EMACS_INT i;
-
+
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
v->size = len;
-
+
return (struct window *) v;
}
EMACS_INT len = VECSIZE (struct frame);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME);
EMACS_INT i;
-
+
for (i = 0; i < len; ++i)
v->contents[i] = make_number (0);
v->size = len;
EMACS_INT len = VECSIZE (struct Lisp_Process);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS);
EMACS_INT i;
-
+
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
v->size = len;
-
+
return (struct Lisp_Process *) v;
}
{
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR);
EMACS_INT i;
-
+
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
v->size = len;
-
+
return v;
}
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 ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &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)
{
struct symbol_block *new;
new = (struct symbol_block *) lisp_malloc (sizeof *new,
MEM_TYPE_SYMBOL);
- VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = symbol_block;
symbol_block = new;
symbol_block_index = 0;
}
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
}
-
+
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;
struct marker_block *new;
new = (struct marker_block *) lisp_malloc (sizeof *new,
MEM_TYPE_MISC);
- VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = marker_block;
marker_block = new;
marker_block_index = 0;
}
XSETMISC (val, &marker_block->markers[marker_block_index++]);
}
-
+
consing_since_gc += sizeof (union Lisp_Misc);
misc_objects_consed++;
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;
characters, so we can make a string. */
{
Lisp_Object result;
-
+
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
parent = NULL;
#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
-
+
while (c != MEM_NIL)
{
if (start >= c->start && start < c->end)
parent = c;
c = start < c->start ? c->left : c->right;
}
-
+
#else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
-
+
while (c != MEM_NIL)
{
parent = c;
c = start < c->start ? c->left : c->right;
}
-
+
#endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
/* Create a new node. */
else
parent->right = x;
}
- else
+ else
mem_root = x;
/* Re-establish red-black tree properties. */
{
/* X is red and its parent is red. This is a violation of
red-black tree property #3. */
-
+
if (x->parent == x->parent->parent->left)
{
/* We're on the left side of our grandparent, and Y is our
"uncle". */
struct mem_node *y = x->parent->parent->right;
-
+
if (y->color == MEM_RED)
{
/* Uncle and parent are red but should be black because
{
/* This is the symmetrical case of above. */
struct mem_node *y = x->parent->parent->left;
-
+
if (y->color == MEM_RED)
{
x->parent->color = MEM_BLACK;
x = x->parent;
mem_rotate_right (x);
}
-
+
x->parent->color = MEM_BLACK;
x->parent->parent->color = MEM_RED;
mem_rotate_left (x->parent->parent);
}
-/* (x) (y)
- / \ / \
+/* (x) (y)
+ / \ / \
a (y) ===> (x) c
/ \ / \
b c a b */
}
-/* (x) (Y)
- / \ / \
- (y) c ===> a (x)
- / \ / \
+/* (x) (Y)
+ / \ / \
+ (y) c ===> a (x)
+ / \ / \
a b b c */
static void
x->left = y->right;
if (y->right != MEM_NIL)
y->right->parent = x;
-
+
if (y != MEM_NIL)
y->parent = x->parent;
if (x->parent)
}
else
mem_root = y;
-
+
y->right = x;
if (x != MEM_NIL)
x->parent = y;
z->end = y->end;
z->type = y->type;
}
-
+
if (y->color == MEM_BLACK)
mem_delete_fixup (x);
if (x == x->parent->left)
{
struct mem_node *w = x->parent->right;
-
+
if (w->color == MEM_RED)
{
w->color = MEM_BLACK;
mem_rotate_left (x->parent);
w = x->parent->right;
}
-
+
if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
{
w->color = MEM_RED;
else
{
struct mem_node *w = x->parent->left;
-
+
if (w->color == MEM_RED)
{
w->color = MEM_BLACK;
mem_rotate_right (x->parent);
w = x->parent->left;
}
-
+
if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
{
w->color = MEM_RED;
mem_rotate_left (w);
w = x->parent->left;
}
-
+
w->color = x->parent->color;
x->parent->color = MEM_BLACK;
w->left->color = MEM_BLACK;
}
}
}
-
+
x->color = MEM_BLACK;
}
{
struct symbol_block *b = (struct symbol_block *) m->start;
int offset = (char *) p - (char *) &b->symbols[0];
-
+
/* 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. */
{
struct float_block *b = (struct float_block *) m->start;
int offset = (char *) p - (char *) &b->floats[0];
-
+
/* 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. */
{
struct marker_block *b = (struct marker_block *) m->start;
int offset = (char *) p - (char *) &b->markers[0];
-
+
/* 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. */
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");
+ Lisp_Object args[8], zombie_list = Qnil;
+ int i;
+ for (i = 0; i < nzombies; i++)
+ zombie_list = Fcons (zombies[i], zombie_list);
+ args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
args[1] = make_number (ngcs);
args[2] = make_float (avg_live);
args[3] = make_float (avg_zombies);
args[4] = make_float (avg_zombies / avg_live / 100);
args[5] = make_number (max_live);
args[6] = make_number (max_zombies);
- return Fmessage (7, args);
+ args[7] = zombie_list;
+ return Fmessage (8, args);
}
#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
{
void *po = (void *) XPNTR (obj);
struct mem_node *m = mem_find (po);
-
+
if (m != MEM_NIL)
{
int mark_p = 0;
case Lisp_Misc_Marker:
mark_p = !XMARKBIT (XMARKER (obj)->chain);
break;
-
+
case Lisp_Misc_Buffer_Local_Value:
case Lisp_Misc_Some_Buffer_Local_Value:
mark_p = !XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
break;
-
+
case Lisp_Misc_Overlay:
mark_p = !XMARKBIT (XOVERLAY (obj)->plist);
break;
{
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
if (nzombies < MAX_ZOMBIES)
- zombies[nzombies] = *p;
+ zombies[nzombies] = obj;
++nzombies;
#endif
mark_object (&obj);
assume that Lisp data is aligned on even addresses. */
if ((EMACS_INT) p & 1)
return;
-
+
m = mem_find (p);
if (m != MEM_NIL)
{
Lisp_Object obj = Qnil;
-
+
switch (m->type)
{
case MEM_TYPE_NON_LISP:
/* Nothing to do; not a pointer to Lisp memory. */
break;
-
+
case MEM_TYPE_BUFFER:
if (live_buffer_p (m, p)
&& !XMARKBIT (((struct buffer *) p)->name))
XSETVECTOR (obj, p);
break;
-
+
case MEM_TYPE_CONS:
if (live_cons_p (m, p)
&& !XMARKBIT (((struct Lisp_Cons *) p)->car))
XSETCONS (obj, p);
break;
-
+
case MEM_TYPE_STRING:
if (live_string_p (m, p)
&& !STRING_MARKED_P ((struct Lisp_String *) p))
{
Lisp_Object tem;
XSETMISC (tem, p);
-
+
switch (XMISCTYPE (tem))
{
case Lisp_Misc_Marker:
if (!XMARKBIT (XMARKER (tem)->chain))
obj = tem;
break;
-
+
case Lisp_Misc_Buffer_Local_Value:
case Lisp_Misc_Some_Buffer_Local_Value:
if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem)->realvalue))
obj = tem;
break;
-
+
case Lisp_Misc_Overlay:
if (!XMARKBIT (XOVERLAY (tem)->plist))
obj = tem;
}
}
break;
-
+
case MEM_TYPE_SYMBOL:
if (live_symbol_p (m, p)
&& !XMARKBIT (((struct Lisp_Symbol *) p)->plist))
XSETSYMBOL (obj, p);
break;
-
+
case MEM_TYPE_FLOAT:
if (live_float_p (m, p)
&& !XMARKBIT (((struct Lisp_Float *) p)->type))
XSETFLOAT (obj, p);
break;
-
+
case MEM_TYPE_VECTOR:
case MEM_TYPE_PROCESS:
case MEM_TYPE_HASH_TABLE:
/* Mark Lisp objects referenced from the address range START..END. */
-static void
+static void
mark_memory (start, end)
void *start, *end;
{
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);
Here, `obj' isn't really used, and the compiler optimizes it
away. The only reference to the life string is through the
pointer `s'. */
-
+
for (pp = (void **) start; (void *) pp < end; ++pp)
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\
"
for (p = gcprolist; p; p = p->next)
for (i = 0; i < p->nvars; ++i)
if (!survives_gc_p (p->var[i]))
+ /* FIXME: It's not necessarily a bug. It might just be that the
+ GCPRO is unnecessary or should release the object sooner. */
abort ();
}
static void
mark_stack ()
{
+ int i;
jmp_buf j;
volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
void *end;
/* This trick flushes the register windows so that all the state of
the process is contained in the stack. */
+ /* Fixme: Code in the Boehm GC sugests flushing (with `flushrs') is
+ needed on ia64 too. See mach_dep.c, where it also says inline
+ assembler doesn't work with relevant proprietary compilers. */
#ifdef sparc
asm ("ta 3");
#endif
-
+
/* Save registers that we need to see on the stack. We need to see
registers used to hold register variables and registers used to
pass parameters. */
#ifdef GC_SAVE_REGISTERS_ON_STACK
GC_SAVE_REGISTERS_ON_STACK (end);
#else /* not GC_SAVE_REGISTERS_ON_STACK */
-
+
#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
setjmp will definitely work, test it
and print a message with the result
test_setjmp ();
}
#endif /* GC_SETJMP_WORKS */
-
+
setjmp (j);
end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
#endif /* not GC_SAVE_REGISTERS_ON_STACK */
/* 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);
+#ifndef GC_LISP_OBJECT_ALIGNMENT
+#ifdef __GNUC__
+#define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
#else
- mark_memory (stack_base, end);
+#define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
#endif
+#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 size;
int type;
{
- size_t nbytes;
POINTER_TYPE *result;
- char *beg = PUREBEG;
+ size_t alignment = sizeof (EMACS_INT);
/* Give Lisp_Floats an extra alignment. */
if (type == Lisp_Float)
{
- 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);
}
-
- nbytes = ALIGN (size, sizeof (EMACS_INT));
- if (pure_bytes_used + nbytes > PURESIZE)
- error ("Pure Lisp storage exhausted");
-
- result = (POINTER_TYPE *) (beg + pure_bytes_used);
- pure_bytes_used += nbytes;
- return result;
+
+ again:
+ result = (POINTER_TYPE *) ALIGN ((EMACS_UINT)purebeg + pure_bytes_used, alignment);
+ pure_bytes_used = ((char *)result - (char *)purebeg) + size;
+
+ if (pure_bytes_used <= pure_size)
+ return result;
+
+ /* 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 - size;
+ pure_bytes_used = 0;
+ goto again;
+}
+
+
+/* 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));
}
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 ();
+ EMACS_TIME t1, t2, t3;
+
+ if (abort_on_gc)
+ abort ();
+
+ EMACS_GET_TIME (t1);
+
+ /* 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
Qt tends to return NULL, which effectively turns undo back on.
So don't call truncate_undo_list if undo_list is Qt. */
if (! EQ (nextb->undo_list, Qt))
- nextb->undo_list
+ 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;
}
}
XMARK (tail->var[i]);
}
#endif
-
+
mark_byte_stack ();
for (bind = specpdl; bind != specpdl_ptr; bind++)
{
{
mark_object (&catch->tag);
mark_object (&catch->val);
- }
+ }
for (handler = handlerlist; handler; handler = handler->next)
{
mark_object (&handler->handler);
mark_object (&handler->var);
- }
+ }
for (backlist = backtrace_list; backlist; backlist = backlist->next)
{
if (!XMARKBIT (*backlist->function))
mark_object (&backlist->args[i]);
XMARK (backlist->args[i]);
}
- }
+ }
mark_kboards ();
/* Look thru every buffer's undo list
if (NILP (prev))
nextb->undo_list = tail = XCDR (tail);
else
- tail = XCDR (prev) = XCDR (tail);
+ {
+ tail = XCDR (tail);
+ XSETCDR (prev, tail);
+ }
}
else
{
mark_stack ();
#endif
+#ifdef USE_GTK
+ {
+ extern void xg_mark_data ();
+ xg_mark_data ();
+ }
+#endif
+
gc_sweep ();
/* Clear the mark bits that we set in certain root slots. */
for (i = 0; i < tail->nvars; i++)
XUNMARK (tail->var[i]);
#endif
-
+
unmark_byte_stack ();
for (backlist = backtrace_list; backlist; backlist = backlist->next)
{
i = backlist->nargs - 1;
for (; i >= 0; i--)
XUNMARK (backlist->args[i]);
- }
+ }
XUNMARK (buffer_defaults.name);
XUNMARK (buffer_local_symbols.name);
{
/* Compute average percentage of zombies. */
double nlive = 0;
-
+
for (i = 0; i < 7; ++i)
- nlive += XFASTINT (XCAR (total[i]));
+ if (CONSP (total[i]))
+ nlive += XFASTINT (XCAR (total[i]));
avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
max_live = max (nlive, max_live);
}
#endif
+ if (!NILP (Vpost_gc_hook))
+ {
+ int count = inhibit_garbage_collection ();
+ safe_run_hooks (Qpost_gc_hook);
+ unbind_to (count, Qnil);
+ }
+
+ /* Accumulate statistics. */
+ EMACS_GET_TIME (t2);
+ EMACS_SUB_TIME (t3, t2, t1);
+ if (FLOATP (Vgc_elapsed))
+ Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) +
+ EMACS_SECS (t3) +
+ EMACS_USECS (t3) * 1.0e-6);
+ gcs_done++;
+
return Flist (sizeof total / sizeof *total, total);
}
{
struct glyph *glyph = row->glyphs[area];
struct glyph *end_glyph = glyph + row->used[area];
-
+
for (; glyph < end_glyph; ++glyph)
if (GC_STRINGP (glyph->object)
&& !STRING_MARKED_P (XSTRING (glyph->object)))
struct image *img;
{
mark_object (&img->spec);
-
+
if (!NILP (img->data.lisp_val))
mark_object (&img->data.lisp_val);
}
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;
CHECK_ALLOCATED (); \
CHECK_LIVE (LIVEP); \
} while (0) \
-
+
#else /* not GC_CHECK_MARKED_OBJECTS */
-
+
#define CHECK_ALLOCATED() (void) 0
#define CHECK_LIVE(LIVEP) (void) 0
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
-
+
#endif /* not GC_CHECK_MARKED_OBJECTS */
switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
&& po != &buffer_local_symbols)
abort ();
#endif /* GC_CHECK_MARKED_OBJECTS */
-
+
if (GC_BUFFERP (obj))
{
if (!XMARKBIT (XBUFFER (obj)->name))
if (size & ARRAY_MARK_FLAG)
break; /* Already marked */
-
+
CHECK_LIVE (live_vector_p);
ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
size &= PSEUDOVECTOR_SIZE_MASK;
{
struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
EMACS_INT size = h->size;
-
+
/* Stop if already marked. */
if (size & ARRAY_MARK_FLAG)
break;
-
+
/* Mark it. */
CHECK_LIVE (live_vector_p);
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 (&h->key_and_value);
else
XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG;
-
+
}
else
{
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
slot except to check whether it is nil. */
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);
/* If this is an indirect buffer, mark its base buffer. */
if (buffer->base_buffer && !XMARKBIT (buffer->base_buffer->name))
{
- XSETBUFFER (base_buffer, buffer->base_buffer);
+ XSETBUFFER (base_buffer, buffer->base_buffer);
mark_buffer (base_buffer);
}
}
mark_object (&kb->Vsystem_key_alist);
mark_object (&kb->system_key_syms);
mark_object (&kb->Vdefault_minibuffer_frame);
+ mark_object (&kb->echo_string);
}
}
Lisp_Object obj;
{
int survives_p;
-
+
switch (XGCTYPE (obj))
{
case Lisp_Int:
case Lisp_Misc_Marker:
survives_p = XMARKBIT (obj);
break;
-
+
case Lisp_Misc_Buffer_Local_Value:
case Lisp_Misc_Some_Buffer_Local_Value:
survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
break;
-
+
case Lisp_Misc_Intfwd:
case Lisp_Misc_Boolfwd:
case Lisp_Misc_Objfwd:
case Lisp_Misc_Kboard_Objfwd:
survives_p = 1;
break;
-
+
case Lisp_Misc_Overlay:
survives_p = XMARKBIT (XOVERLAY (obj)->plist);
break;
register int num_free = 0, num_used = 0;
cons_free_list = 0;
-
+
for (cblk = cons_block; cblk; cblk = *cprev)
{
register int i;
register int num_free = 0, num_used = 0;
float_free_list = 0;
-
+
for (fblk = float_block; fblk; fblk = *fprev)
{
register int i;
register int num_free = 0, num_used = 0;
symbol_free_list = NULL;
-
+
for (sblk = symbol_block; sblk; sblk = *sprev)
{
int this_free = 0;
/* 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)
{
*(struct Lisp_Symbol **) &sym->value = symbol_free_list;
{
++num_used;
if (!pure_p)
- UNMARK_STRING (sym->name);
+ UNMARK_STRING (XSTRING (sym->xname));
XUNMARK (sym->plist);
}
}
-
+
lim = SYMBOL_BLOCK_SIZE;
/* If this block contains only free symbols and we have already
seen more than two blocks worth of free symbols then deallocate
register int num_free = 0, num_used = 0;
marker_free_list = 0;
-
+
for (mblk = marker_block; mblk; mblk = *mprev)
{
register int i;
prev = vector, vector = vector->next;
}
}
-
+
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive)
check_string_bytes (1);
/* 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
setjmp_tested_p = longjmps_done = 0;
#endif
#endif
+ Vgc_elapsed = make_float (0.0);
+ gcs_done = 0;
}
void
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");
staticpro (&Qchar_table_extra_slots);
Qchar_table_extra_slots = intern ("char-table-extra-slots");
+ DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
+ doc: /* Accumulated time elapsed in garbage collections.
+The time is in seconds as a floating point value.
+Programs may reset this to get statistics in a specific period. */);
+ DEFVAR_INT ("gcs-done", &gcs_done,
+ doc: /* Accumulated number of garbage collections done.
+Programs may reset this to get statistics in a specific period. */);
+
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);
HCoop / bpt / emacs.git / blobdiff