/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
+ Copyright (C) 1985, 86, 88, 93, 94, 95, 97 Free Software Foundation, Inc.
This file is part of GNU Emacs.
You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+/* Note that this declares bzero on OSF/1. How dumb. */
#include <signal.h>
#include <config.h>
extern char *sbrk ();
+#ifdef DOUG_LEA_MALLOC
+#include <malloc.h>
+#define __malloc_size_t int
+#else
/* The following come from gmalloc.c. */
#if defined (__STDC__) && __STDC__
#endif
extern __malloc_size_t _bytes_used;
extern int __malloc_extra_blocks;
+#endif /* !defined(DOUG_LEA_MALLOC) */
+
+extern Lisp_Object Vhistory_length;
#define max(A,B) ((A) > (B) ? (A) : (B))
#define min(A,B) ((A) < (B) ? (A) : (B))
/* Nonzero during gc */
int gc_in_progress;
+/* Nonzero means display messages at beginning and end of GC. */
+int garbage_collection_messages;
+
#ifndef VIRT_ADDR_VARIES
extern
#endif /* VIRT_ADDR_VARIES */
int undo_limit;
int undo_strong_limit;
+int total_conses, total_markers, total_symbols, total_string_size, total_vector_size;
+int total_free_conses, total_free_markers, total_free_symbols;
+#ifdef LISP_FLOAT_TYPE
+int total_free_floats, total_floats;
+#endif /* LISP_FLOAT_TYPE */
+
/* Points to memory space allocated as "spare",
to be freed if we run out of memory. */
static char *spare_memory;
/* Define DONT_COPY_FLAG to be some bit which will always be zero in a
pointer to a Lisp_Object, when that pointer is viewed as an integer.
(On most machines, pointers are even, so we can use the low bit.
- Word-addressible architectures may need to override this in the m-file.)
+ Word-addressable architectures may need to override this in the m-file.)
When linking references to small strings through the size field, we
use this slot to hold the bit that would otherwise be interpreted as
the GC mark bit. */
/* Non-zero means ignore malloc warnings. Set during initialization. */
int ignore_warnings;
-Lisp_Object Qgc_cons_threshold;
+Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
static void mark_object (), mark_buffer (), mark_kboards ();
static void clear_marks (), gc_sweep ();
}
/* malloc calls this if it finds we are near exhausting storage */
+
+void
malloc_warning (str)
char *str;
{
pending_malloc_warning = str;
}
+void
display_malloc_warning ()
{
register Lisp_Object val;
internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val);
}
+#ifdef DOUG_LEA_MALLOC
+# define BYTES_USED (mallinfo ().arena)
+#else
+# define BYTES_USED _bytes_used
+#endif
+
/* Called if malloc returns zero */
+void
memory_full ()
{
#ifndef SYSTEM_MALLOC
- bytes_used_when_full = _bytes_used;
+ bytes_used_when_full = BYTES_USED;
#endif
/* The first time we get here, free the spare memory. */
/* 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, memory_signal_data);
}
/* Called if we can't allocate relocatable space for a buffer. */
The code here is correct as long as SPARE_MEMORY
is substantially larger than the block size malloc uses. */
&& (bytes_used_when_full
- > _bytes_used + max (malloc_hysteresis, 4) * SPARE_MEMORY))
+ > BYTES_USED + max (malloc_hysteresis, 4) * SPARE_MEMORY))
spare_memory = (char *) malloc (SPARE_MEMORY);
__free_hook = emacs_blocked_free;
BLOCK_INPUT;
__malloc_hook = old_malloc_hook;
- __malloc_extra_blocks = malloc_hysteresis;
+#ifdef DOUG_LEA_MALLOC
+ mallopt (M_TOP_PAD, malloc_hysteresis * 4096);
+#else
+ __malloc_extra_blocks = malloc_hysteresis;
+#endif
value = (void *) malloc (size);
__malloc_hook = emacs_blocked_malloc;
UNBLOCK_INPUT;
= (struct interval_block *) malloc (sizeof (struct interval_block));
allocating_for_lisp = 0;
interval_block->next = 0;
- bzero (interval_block->intervals, sizeof interval_block->intervals);
+ bzero ((char *) interval_block->intervals, sizeof interval_block->intervals);
interval_block_index = 0;
interval_free_list = 0;
}
#define MARK_INTERVAL_TREE(i) \
do { \
if (!NULL_INTERVAL_P (i) \
- && ! XMARKBIT ((Lisp_Object) i->parent)) \
+ && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
mark_interval_tree (i); \
} while (0)
float_block = (struct float_block *) malloc (sizeof (struct float_block));
allocating_for_lisp = 0;
float_block->next = 0;
- bzero (float_block->floats, sizeof float_block->floats);
+ bzero ((char *) float_block->floats, sizeof float_block->floats);
float_block_index = 0;
float_free_list = 0;
}
free_float (ptr)
struct Lisp_Float *ptr;
{
- *(struct Lisp_Float **)&ptr->type = float_free_list;
+ *(struct Lisp_Float **)&ptr->data = float_free_list;
float_free_list = ptr;
}
if (float_free_list)
{
+ /* We use the data field for chaining the free list
+ so that we won't use the same field that has the mark bit. */
XSETFLOAT (val, float_free_list);
- float_free_list = *(struct Lisp_Float **)&float_free_list->type;
+ float_free_list = *(struct Lisp_Float **)&float_free_list->data;
}
else
{
cons_block = (struct cons_block *) malloc (sizeof (struct cons_block));
allocating_for_lisp = 0;
cons_block->next = 0;
- bzero (cons_block->conses, sizeof cons_block->conses);
+ bzero ((char *) cons_block->conses, sizeof cons_block->conses);
cons_block_index = 0;
cons_free_list = 0;
}
/* Explicitly free a cons cell. */
+
+void
free_cons (ptr)
struct Lisp_Cons *ptr;
{
- *(struct Lisp_Cons **)&ptr->car = cons_free_list;
+ *(struct Lisp_Cons **)&ptr->cdr = cons_free_list;
cons_free_list = ptr;
}
if (cons_free_list)
{
+ /* We use the cdr for chaining the free list
+ so that we won't use the same field that has the mark bit. */
XSETCONS (val, cons_free_list);
- cons_free_list = *(struct Lisp_Cons **)&cons_free_list->car;
+ cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr;
}
else
{
int nargs;
register Lisp_Object *args;
{
- register Lisp_Object val = Qnil;
+ register Lisp_Object val;
+ val = Qnil;
- while (nargs--)
- val = Fcons (args[nargs], val);
+ while (nargs > 0)
+ {
+ nargs--;
+ val = Fcons (args[nargs], val);
+ }
return val;
}
struct Lisp_Vector *p;
allocating_for_lisp = 1;
+#ifdef DOUG_LEA_MALLOC
+ /* Prevent mmap'ing the chunk (which is potentially very large). */
+ mallopt (M_MMAP_MAX, 0);
+#endif
p = (struct Lisp_Vector *)xmalloc (sizeof (struct Lisp_Vector)
+ (len - 1) * sizeof (Lisp_Object));
+#ifdef DOUG_LEA_MALLOC
+ /* Back to a reasonable maximum of mmap'ed areas. */
+ mallopt (M_MMAP_MAX, 64);
+#endif
allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (p, 0);
consing_since_gc += (sizeof (struct Lisp_Vector)
return vector;
}
-DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 0, 2, 0,
- "Return a newly created char-table, with N \"extra\" slots.\n\
+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\
-N may not be more than ten.\n\
-See `char-table-extra-slot' and `set-char-table-extra-slot'.")
- (n, init)
- register Lisp_Object n, init;
+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)
+ register Lisp_Object purpose, init;
{
Lisp_Object vector;
- CHECK_NUMBER (n, 1);
+ Lisp_Object n;
+ CHECK_SYMBOL (purpose, 1);
+ n = Fget (purpose, Qchar_table_extra_slots);
+ CHECK_NUMBER (n, 0);
if (XINT (n) < 0 || XINT (n) > 10)
args_out_of_range (n, Qnil);
/* Add 2 to the size for the defalt and parent slots. */
vector = Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS + XINT (n)),
init);
+ XCHAR_TABLE (vector)->top = Qt;
+ XCHAR_TABLE (vector)->parent = Qnil;
+ XCHAR_TABLE (vector)->purpose = purpose;
+ XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
+ return vector;
+}
+
+/* Return a newly created sub char table with default value DEFALT.
+ Since a sub char table does not appear as a top level Emacs Lisp
+ object, we don't need a Lisp interface to make it. */
+
+Lisp_Object
+make_sub_char_table (defalt)
+ Lisp_Object defalt;
+{
+ Lisp_Object vector
+ = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), Qnil);
+ XCHAR_TABLE (vector)->top = Qnil;
+ XCHAR_TABLE (vector)->defalt = defalt;
XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
return vector;
}
XSETFASTINT (len, nargs);
if (!NILP (Vpurify_flag))
- val = make_pure_vector (len);
+ val = make_pure_vector ((EMACS_INT) nargs);
else
val = Fmake_vector (len, Qnil);
p = XVECTOR (val);
args[index] = Fpurecopy (args[index]);
p->contents[index] = args[index];
}
- XSETCOMPILED (val, val);
+ XSETCOMPILED (val, p);
return val;
}
\f
symbol_block = (struct symbol_block *) malloc (sizeof (struct symbol_block));
allocating_for_lisp = 0;
symbol_block->next = 0;
- bzero (symbol_block->symbols, sizeof symbol_block->symbols);
+ bzero ((char *) symbol_block->symbols, sizeof symbol_block->symbols);
symbol_block_index = 0;
symbol_free_list = 0;
}
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.")
- (str)
- Lisp_Object str;
+ (name)
+ Lisp_Object name;
{
register Lisp_Object val;
register struct Lisp_Symbol *p;
- CHECK_STRING (str, 0);
+ CHECK_STRING (name, 0);
if (symbol_free_list)
{
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
}
p = XSYMBOL (val);
- p->name = XSTRING (str);
+ p->name = XSTRING (name);
+ p->obarray = Qnil;
p->plist = Qnil;
p->value = Qunbound;
p->function = Qunbound;
marker_block = (struct marker_block *) malloc (sizeof (struct marker_block));
allocating_for_lisp = 0;
marker_block->next = 0;
- bzero (marker_block->markers, sizeof marker_block->markers);
+ bzero ((char *) marker_block->markers, sizeof marker_block->markers);
marker_block_index = 0;
marker_free_list = 0;
}
p->insertion_type = 0;
return val;
}
+
+/* Put MARKER back on the free list after using it temporarily. */
+
+void
+free_marker (marker)
+ Lisp_Object marker;
+{
+ unchain_marker (marker);
+
+ XMISC (marker)->u_marker.type = Lisp_Misc_Free;
+ XMISC (marker)->u_free.chain = marker_free_list;
+ marker_free_list = XMISC (marker);
+
+ total_free_markers++;
+}
\f
/* Allocation of strings */
struct string_block_head
{
struct string_block *next, *prev;
- int pos;
+ EMACS_INT pos;
};
struct string_block
}
DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
- "Return a newly created bitstring of length LENGTH, with INIT as each element.\n\
-Both LENGTH and INIT must be numbers. INIT matters only in whether it is t or nil.")
+ "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)
Lisp_Object length, init;
{
CHECK_NATNUM (length, 0);
- bits_per_value = sizeof (EMACS_INT) * INTBITS / sizeof (int);
+ bits_per_value = sizeof (EMACS_INT) * BITS_PER_CHAR;
length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
length_in_chars = length_in_elts * sizeof (EMACS_INT);
- val = Fmake_vector (make_number (length_in_elts), Qnil);
+ /* We must allocate one more elements than LENGTH_IN_ELTS for the
+ 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;
{
register struct string_block *new;
allocating_for_lisp = 1;
+#ifdef DOUG_LEA_MALLOC
+ /* Prevent mmap'ing the chunk (which is potentially very large). */
+ mallopt (M_MMAP_MAX, 0);
+#endif
new = (struct string_block *) xmalloc (sizeof (struct string_block_head) + fullsize);
+#ifdef DOUG_LEA_MALLOC
+ /* Back to a reasonable maximum of mmap'ed areas. */
+ mallopt (M_MMAP_MAX, 64);
+#endif
allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (new, 0);
consing_since_gc += sizeof (struct string_block_head) + fullsize;
{
Lisp_Object result;
- result = Fmake_string (nargs, make_number (0));
+ result = Fmake_string (make_number (nargs), make_number (0));
for (i = 0; i < nargs; i++)
{
XSTRING (result)->data[i] = XINT (args[i]);
size = XVECTOR (obj)->size;
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
- vec = XVECTOR (make_pure_vector (size));
+ vec = XVECTOR (make_pure_vector ((EMACS_INT) size));
for (i = 0; i < size; i++)
vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
if (COMPILEDP (obj))
\f
/* Garbage collection! */
-int total_conses, total_markers, total_symbols, total_string_size, total_vector_size;
-int total_free_conses, total_free_markers, total_free_symbols;
-#ifdef LISP_FLOAT_TYPE
-int total_free_floats, total_floats;
-#endif /* LISP_FLOAT_TYPE */
-
/* Temporarily prevent garbage collection. */
int
{
int count = specpdl_ptr - specpdl;
Lisp_Object number;
- int nbits = min (VALBITS, INTBITS);
+ int nbits = min (VALBITS, BITS_PER_INT);
XSETINT (number, ((EMACS_INT) 1 << (nbits - 1)) - 1);
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))\n\
+ (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
Garbage collection happens automatically if you cons more than\n\
`gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
()
}
#endif /* MAX_SAVE_STACK > 0 */
- if (!noninteractive)
+ if (garbage_collection_messages)
message1_nolog ("Garbage collecting...");
- /* Don't keep command history around forever */
- tem = Fnthcdr (make_number (30), Vcommand_history);
- if (CONSP (tem))
- XCONS (tem)->cdr = Qnil;
+ /* Don't keep command history around forever. */
+ if (NUMBERP (Vhistory_length) && XINT (Vhistory_length) > 0)
+ {
+ tem = Fnthcdr (Vhistory_length, Vcommand_history);
+ if (CONSP (tem))
+ XCONS (tem)->cdr = Qnil;
+ }
/* Likewise for undo information. */
{
gc_in_progress = 1;
-/* clear_marks (); */
+ /* clear_marks (); */
/* In each "large string", set the MARKBIT of the size field.
That enables mark_object to recognize them. */
XUNMARK (buffer_defaults.name);
XUNMARK (buffer_local_symbols.name);
-/* clear_marks (); */
+ /* clear_marks (); */
gc_in_progress = 0;
consing_since_gc = 0;
if (gc_cons_threshold < 10000)
gc_cons_threshold = 10000;
- if (omessage || minibuf_level > 0)
- message2_nolog (omessage, omessage_length);
- else if (!noninteractive)
- message1_nolog ("Garbage collecting...done");
+ if (garbage_collection_messages)
+ {
+ if (omessage || minibuf_level > 0)
+ message2_nolog (omessage, omessage_length);
+ else
+ message1_nolog ("Garbage collecting...done");
+ }
return Fcons (Fcons (make_number (total_conses),
make_number (total_free_conses)),
make_number (total_free_markers)),
Fcons (make_number (total_string_size),
Fcons (make_number (total_vector_size),
-
+ Fcons (Fcons
#ifdef LISP_FLOAT_TYPE
- Fcons (Fcons (make_number (total_floats),
- make_number (total_free_floats)),
- Qnil)
+ (make_number (total_floats),
+ make_number (total_free_floats)),
#else /* not LISP_FLOAT_TYPE */
- Qnil
+ (make_number (0), make_number (0)),
#endif /* not LISP_FLOAT_TYPE */
- )))));
+ Fcons (Fcons
+#ifdef USE_TEXT_PROPERTIES
+ (make_number (total_intervals),
+ make_number (total_free_intervals)),
+#else /* not USE_TEXT_PROPERTIES */
+ (make_number (0), make_number (0)),
+#endif /* not USE_TEXT_PROPERTIES */
+ Qnil)))))));
}
\f
#if 0
int last_marked_index;
static void
-mark_object (objptr)
- Lisp_Object *objptr;
+mark_object (argptr)
+ Lisp_Object *argptr;
{
+ Lisp_Object *objptr = argptr;
register Lisp_Object obj;
loop:
objptr = (Lisp_Object *) &ptr1->contents[COMPILED_CONSTANTS];
goto loop;
}
-#ifdef MULTI_FRAME
else if (GC_FRAMEP (obj))
{
/* See comment above under Lisp_Vector for why this is volatile. */
mark_object (&ptr->name);
mark_object (&ptr->icon_name);
+ mark_object (&ptr->title);
mark_object (&ptr->focus_frame);
mark_object (&ptr->selected_window);
mark_object (&ptr->minibuffer_window);
mark_object (&ptr->face_alist);
mark_object (&ptr->menu_bar_vector);
mark_object (&ptr->buffer_predicate);
+ mark_object (&ptr->buffer_list);
}
-#endif /* MULTI_FRAME */
else if (GC_BOOL_VECTOR_P (obj))
- ;
+ {
+ register struct Lisp_Vector *ptr = XVECTOR (obj);
+
+ if (ptr->size & ARRAY_MARK_FLAG)
+ break; /* Already marked */
+ ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+ }
else
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
/* Put all unmarked conses on free list */
{
register struct cons_block *cblk;
+ struct cons_block **cprev = &cons_block;
register int lim = cons_block_index;
register int num_free = 0, num_used = 0;
cons_free_list = 0;
- for (cblk = cons_block; cblk; cblk = cblk->next)
+ for (cblk = cons_block; cblk; cblk = *cprev)
{
register int i;
+ int this_free = 0;
for (i = 0; i < lim; i++)
if (!XMARKBIT (cblk->conses[i].car))
{
num_free++;
- *(struct Lisp_Cons **)&cblk->conses[i].car = cons_free_list;
+ this_free++;
+ *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list;
cons_free_list = &cblk->conses[i];
}
else
XUNMARK (cblk->conses[i].car);
}
lim = CONS_BLOCK_SIZE;
+ /* If this block contains only free conses and we have already
+ seen more than two blocks worth of free conses then deallocate
+ this block. */
+ if (this_free == CONS_BLOCK_SIZE && num_free > 2*CONS_BLOCK_SIZE)
+ {
+ num_free -= CONS_BLOCK_SIZE;
+ *cprev = cblk->next;
+ /* Unhook from the free list. */
+ cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr;
+ xfree (cblk);
+ }
+ else
+ cprev = &cblk->next;
}
total_conses = num_used;
total_free_conses = num_free;
/* Put all unmarked floats on free list */
{
register struct float_block *fblk;
+ struct float_block **fprev = &float_block;
register int lim = float_block_index;
register int num_free = 0, num_used = 0;
float_free_list = 0;
- for (fblk = float_block; fblk; fblk = fblk->next)
+ for (fblk = float_block; fblk; fblk = *fprev)
{
register int i;
+ int this_free = 0;
for (i = 0; i < lim; i++)
if (!XMARKBIT (fblk->floats[i].type))
{
num_free++;
- *(struct Lisp_Float **)&fblk->floats[i].type = float_free_list;
+ this_free++;
+ *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list;
float_free_list = &fblk->floats[i];
}
else
XUNMARK (fblk->floats[i].type);
}
lim = FLOAT_BLOCK_SIZE;
+ /* If this block contains only free floats and we have already
+ seen more than two blocks worth of free floats then deallocate
+ this block. */
+ if (this_free == FLOAT_BLOCK_SIZE && num_free > 2*FLOAT_BLOCK_SIZE)
+ {
+ num_free -= FLOAT_BLOCK_SIZE;
+ *fprev = fblk->next;
+ /* Unhook from the free list. */
+ float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data;
+ xfree (fblk);
+ }
+ else
+ fprev = &fblk->next;
}
total_floats = num_used;
total_free_floats = num_free;
/* Put all unmarked intervals on free list */
{
register struct interval_block *iblk;
+ struct interval_block **iprev = &interval_block;
register int lim = interval_block_index;
register int num_free = 0, num_used = 0;
interval_free_list = 0;
- for (iblk = interval_block; iblk; iblk = iblk->next)
+ for (iblk = interval_block; iblk; iblk = *iprev)
{
register int i;
+ int this_free = 0;
for (i = 0; i < lim; i++)
{
iblk->intervals[i].parent = interval_free_list;
interval_free_list = &iblk->intervals[i];
num_free++;
+ this_free++;
}
else
{
}
}
lim = INTERVAL_BLOCK_SIZE;
+ /* If this block contains only free intervals and we have already
+ seen more than two blocks worth of free intervals then
+ deallocate this block. */
+ if (this_free == INTERVAL_BLOCK_SIZE
+ && num_free > 2*INTERVAL_BLOCK_SIZE)
+ {
+ num_free -= INTERVAL_BLOCK_SIZE;
+ *iprev = iblk->next;
+ /* Unhook from the free list. */
+ interval_free_list = iblk->intervals[0].parent;
+ xfree (iblk);
+ }
+ else
+ iprev = &iblk->next;
}
total_intervals = num_used;
total_free_intervals = num_free;
/* Put all unmarked symbols on free list */
{
register struct symbol_block *sblk;
+ struct symbol_block **sprev = &symbol_block;
register int lim = symbol_block_index;
register int num_free = 0, num_used = 0;
symbol_free_list = 0;
- for (sblk = symbol_block; sblk; sblk = sblk->next)
+ for (sblk = symbol_block; sblk; sblk = *sprev)
{
register int i;
+ int this_free = 0;
for (i = 0; i < lim; i++)
if (!XMARKBIT (sblk->symbols[i].plist))
{
*(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list;
symbol_free_list = &sblk->symbols[i];
num_free++;
+ this_free++;
}
else
{
XUNMARK (sblk->symbols[i].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
+ this block. */
+ if (this_free == SYMBOL_BLOCK_SIZE && num_free > 2*SYMBOL_BLOCK_SIZE)
+ {
+ num_free -= SYMBOL_BLOCK_SIZE;
+ *sprev = sblk->next;
+ /* Unhook from the free list. */
+ symbol_free_list = *(struct Lisp_Symbol **)&sblk->symbols[0].value;
+ xfree (sblk);
+ }
+ else
+ sprev = &sblk->next;
}
total_symbols = num_used;
total_free_symbols = num_free;
#ifndef standalone
/* Put all unmarked markers on free list.
- Dechain each one first from the buffer it points into,
+ Unchain each one first from the buffer it points into,
but only if it's a real marker. */
{
register struct marker_block *mblk;
+ struct marker_block **mprev = &marker_block;
register int lim = marker_block_index;
register int num_free = 0, num_used = 0;
marker_free_list = 0;
- for (mblk = marker_block; mblk; mblk = mblk->next)
+ for (mblk = marker_block; mblk; mblk = *mprev)
{
register int i;
+ int this_free = 0;
EMACS_INT already_free = -1;
for (i = 0; i < lim; i++)
case Lisp_Misc_Free:
/* If the object was already free, keep it
on the free list. */
- markword = &already_free;
+ markword = (Lisp_Object *) &already_free;
break;
default:
markword = 0;
mblk->markers[i].u_free.chain = marker_free_list;
marker_free_list = &mblk->markers[i];
num_free++;
+ this_free++;
}
else
{
}
}
lim = MARKER_BLOCK_SIZE;
+ /* If this block contains only free markers and we have already
+ seen more than two blocks worth of free markers then deallocate
+ this block. */
+ if (this_free == MARKER_BLOCK_SIZE && num_free > 2*MARKER_BLOCK_SIZE)
+ {
+ num_free -= MARKER_BLOCK_SIZE;
+ *mprev = mblk->next;
+ /* Unhook from the free list. */
+ marker_free_list = mblk->markers[0].u_free.chain;
+ xfree (mblk);
+ }
+ else
+ mprev = &mblk->next;
}
total_markers = num_used;
Lisp_Object lisp_intervals_consed;
XSETINT (lisp_cons_cells_consed,
- cons_cells_consed & ~(1 << (VALBITS - 1)));
+ cons_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
XSETINT (lisp_floats_consed,
- floats_consed & ~(1 << (VALBITS - 1)));
+ floats_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
XSETINT (lisp_vector_cells_consed,
- vector_cells_consed & ~(1 << (VALBITS - 1)));
+ vector_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
XSETINT (lisp_symbols_consed,
- symbols_consed & ~(1 << (VALBITS - 1)));
+ symbols_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
XSETINT (lisp_string_chars_consed,
- string_chars_consed & ~(1 << (VALBITS - 1)));
+ string_chars_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
XSETINT (lisp_misc_objects_consed,
- misc_objects_consed & ~(1 << (VALBITS - 1)));
+ misc_objects_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
XSETINT (lisp_intervals_consed,
- intervals_consed & ~(1 << (VALBITS - 1)));
+ intervals_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
return Fcons (lisp_cons_cells_consed,
Fcons (lisp_floats_consed,
#endif
all_vectors = 0;
ignore_warnings = 1;
+#ifdef DOUG_LEA_MALLOC
+ mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
+ mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
+ mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
+#endif
init_strings ();
init_cons ();
init_symbol ();
DEFVAR_INT ("pure-bytes-used", &pureptr,
"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 ("floats-consed", &floats_consed,
+ "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 ("symbols-consed", &symbols_consed,
+ "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 ("misc-objects-consed", &misc_objects_consed,
+ "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.");
+
#if 0
DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used,
"Number of bytes of unshared memory allocated in this session.");
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.");
+ garbage_collection_messages = 0;
+
/* 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
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");
+
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);