/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc.
+ Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 1998
+ 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>
#include "window.h"
#include "frame.h"
#include "blockinput.h"
+#include "keyboard.h"
+#include "charset.h"
#endif
#include "syssignal.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__
+#include <stddef.h>
+#define __malloc_size_t size_t
+#else
+#define __malloc_size_t unsigned int
+#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))
/* Macro to verify that storage intended for Lisp objects is not
out of range to fit in the space for a pointer.
} \
} while (0)
+/* Value of _bytes_used, when spare_memory was freed. */
+static __malloc_size_t bytes_used_when_full;
+
/* Number of bytes of consing done since the last gc */
int consing_since_gc;
+/* 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;
+
/* Number of bytes of consing since gc before another gc should be done. */
int gc_cons_threshold;
/* 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;
+
+/* Amount of spare memory to keep in reserve. */
+#define SPARE_MEMORY (1 << 14)
+
+/* Number of extra blocks malloc should get when it needs more core. */
+static int malloc_hysteresis;
+
+/* Nonzero when malloc is called for allocating Lisp object space. */
+int allocating_for_lisp;
+
/* Non-nil means defun should do purecopy on the function definition */
Lisp_Object Vpurify_flag;
#define MAX_SAVE_STACK 16000
#endif
+/* 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-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. */
+#ifndef DONT_COPY_FLAG
+#define DONT_COPY_FLAG 1
+#endif /* no DONT_COPY_FLAG */
+
/* Buffer in which we save a copy of the C stack at each GC. */
char *stack_copy;
/* Non-zero means ignore malloc warnings. Set during initialization. */
int ignore_warnings;
-static void mark_object (), mark_buffer ();
+Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
+
+static void mark_object (), mark_buffer (), mark_kboards ();
static void clear_marks (), gc_sweep ();
static void compact_strings ();
+
+extern int message_enable_multibyte;
\f
/* Versions of malloc and realloc that print warnings as memory gets full. */
}
/* 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;
+#endif
+
+ /* The first time we get here, free the spare memory. */
+ if (spare_memory)
+ {
+ free (spare_memory);
+ spare_memory = 0;
+ }
+
+ /* This used to call error, but if we've run out of memory, we could get
+ infinite recursion trying to build the string. */
+ while (1)
+ Fsignal (Qnil, memory_signal_data);
+}
+
+/* Called if we can't allocate relocatable space for a buffer. */
+
+void
+buffer_memory_full ()
+{
+ /* If buffers use the relocating allocator,
+ no need to free spare_memory, because we may have plenty of malloc
+ space left that we could get, and if we don't, the malloc that fails
+ will itself cause spare_memory to be freed.
+ If buffers don't use the relocating allocator,
+ treat this like any other failing malloc. */
+
+#ifndef REL_ALLOC
+ memory_full ();
+#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)
extern void (*__free_hook) ();
static void (*old_free_hook) ();
+/* This function is used as the hook for free to call. */
+
static void
emacs_blocked_free (ptr)
void *ptr;
BLOCK_INPUT;
__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. */
+ if (spare_memory == 0
+ /* Verify there is enough space that even with the malloc
+ hysteresis this call won't run out again.
+ The code here is correct as long as SPARE_MEMORY
+ is substantially larger than the block size malloc uses. */
+ && (bytes_used_when_full
+ > BYTES_USED + max (malloc_hysteresis, 4) * SPARE_MEMORY))
+ spare_memory = (char *) malloc (SPARE_MEMORY);
+
__free_hook = emacs_blocked_free;
UNBLOCK_INPUT;
}
+/* If we released our reserve (due to running out of memory),
+ and we have a fair amount free once again,
+ try to set aside another reserve in case we run out once more.
+
+ This is called when a relocatable block is freed in ralloc.c. */
+
+void
+refill_memory_reserve ()
+{
+ if (spare_memory == 0)
+ spare_memory = (char *) malloc (SPARE_MEMORY);
+}
+
+/* This function is the malloc hook that Emacs uses. */
+
static void *
emacs_blocked_malloc (size)
unsigned size;
BLOCK_INPUT;
__malloc_hook = old_malloc_hook;
+#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;
static void
init_intervals ()
{
+ allocating_for_lisp = 1;
interval_block
= (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;
}
{
if (interval_block_index == INTERVAL_BLOCK_SIZE)
{
- register struct interval_block *newi
- = (struct interval_block *) xmalloc (sizeof (struct interval_block));
+ register struct interval_block *newi;
+ allocating_for_lisp = 1;
+ newi = (struct interval_block *) xmalloc (sizeof (struct interval_block));
+
+ allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (newi, sizeof *newi);
newi->next = interval_block;
interval_block = newi;
val = &interval_block->intervals[interval_block_index++];
}
consing_since_gc += sizeof (struct interval);
+ intervals_consed++;
RESET_INTERVAL (val);
return val;
}
#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)
void
init_float ()
{
+ allocating_for_lisp = 1;
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;
{
- XSETFASTINT (ptr->type, (EMACS_INT) 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 *) XFASTINT (float_free_list->type);
+ float_free_list = *(struct Lisp_Float **)&float_free_list->data;
}
else
{
if (float_block_index == FLOAT_BLOCK_SIZE)
{
- register struct float_block *new = (struct float_block *) xmalloc (sizeof (struct float_block));
+ register struct float_block *new;
+
+ allocating_for_lisp = 1;
+ new = (struct float_block *) xmalloc (sizeof (struct float_block));
+ allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = float_block;
float_block = new;
XFLOAT (val)->data = float_value;
XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */
consing_since_gc += sizeof (struct Lisp_Float);
+ floats_consed++;
return val;
}
void
init_cons ()
{
+ allocating_for_lisp = 1;
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;
{
- XSETFASTINT (ptr->car, (EMACS_INT) 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 *) XFASTINT (cons_free_list->car);
+ cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr;
}
else
{
if (cons_block_index == CONS_BLOCK_SIZE)
{
- register struct cons_block *new = (struct cons_block *) xmalloc (sizeof (struct cons_block));
+ register struct cons_block *new;
+ allocating_for_lisp = 1;
+ new = (struct cons_block *) xmalloc (sizeof (struct cons_block));
+ allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = cons_block;
cons_block = new;
XCONS (val)->car = car;
XCONS (val)->cdr = cdr;
consing_since_gc += sizeof (struct Lisp_Cons);
+ cons_cells_consed++;
return val;
}
+\f
+/* Make a list of 2, 3, 4 or 5 specified objects. */
+
+Lisp_Object
+list2 (arg1, arg2)
+ Lisp_Object arg1, arg2;
+{
+ return Fcons (arg1, Fcons (arg2, Qnil));
+}
+
+Lisp_Object
+list3 (arg1, arg2, arg3)
+ Lisp_Object arg1, arg2, arg3;
+{
+ return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
+}
+
+Lisp_Object
+list4 (arg1, arg2, arg3, arg4)
+ Lisp_Object arg1, arg2, arg3, arg4;
+{
+ return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
+}
+
+Lisp_Object
+list5 (arg1, arg2, arg3, arg4, arg5)
+ Lisp_Object arg1, arg2, arg3, arg4, arg5;
+{
+ return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
+ Fcons (arg5, Qnil)))));
+}
DEFUN ("list", Flist, Slist, 0, MANY, 0,
"Return a newly created list with specified arguments as elements.\n\
int nargs;
register Lisp_Object *args;
{
- register Lisp_Object len, val, val_tail;
+ register Lisp_Object val;
+ val = Qnil;
- XSETFASTINT (len, nargs);
- val = Fmake_list (len, Qnil);
- val_tail = val;
- while (!NILP (val_tail))
+ while (nargs > 0)
{
- XCONS (val_tail)->car = *args++;
- val_tail = XCONS (val_tail)->cdr;
+ nargs--;
+ val = Fcons (args[nargs], val);
}
return val;
}
register Lisp_Object val;
register int size;
- if (!INTEGERP (length) || XINT (length) < 0)
- length = wrong_type_argument (Qnatnump, length);
- size = XINT (length);
+ CHECK_NATNUM (length, 0);
+ size = XFASTINT (length);
val = Qnil;
while (size-- > 0)
struct Lisp_Vector *all_vectors;
+struct Lisp_Vector *
+allocate_vectorlike (len)
+ EMACS_INT len;
+{
+ 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)
+ + (len - 1) * sizeof (Lisp_Object));
+ vector_cells_consed += len;
+
+ p->next = all_vectors;
+ all_vectors = p;
+ return p;
+}
+
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)
register Lisp_Object length, init;
{
- register int sizei, index;
- register Lisp_Object vector;
+ Lisp_Object vector;
+ register EMACS_INT sizei;
+ register int index;
register struct Lisp_Vector *p;
- if (!INTEGERP (length) || XINT (length) < 0)
- length = wrong_type_argument (Qnatnump, length);
- sizei = XINT (length);
+ CHECK_NATNUM (length, 0);
+ sizei = XFASTINT (length);
- p = (struct Lisp_Vector *) xmalloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object));
- VALIDATE_LISP_STORAGE (p, 0);
+ p = allocate_vectorlike (sizei);
+ p->size = sizei;
+ for (index = 0; index < sizei; index++)
+ p->contents[index] = init;
XSETVECTOR (vector, p);
- consing_since_gc += sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object);
+ return vector;
+}
- p->size = sizei;
- p->next = all_vectors;
- all_vectors = p;
+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)
+ register Lisp_Object purpose, init;
+{
+ Lisp_Object vector;
+ 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;
+}
- for (index = 0; index < sizei; index++)
- p->contents[index] = init;
+/* 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];
}
- XSETTYPE (val, Lisp_Compiled);
+ XSETCOMPILED (val, p);
return val;
}
\f
void
init_symbol ()
{
+ allocating_for_lisp = 1;
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_free_list);
- symbol_free_list
- = (struct Lisp_Symbol *) XFASTINT (symbol_free_list->value);
+ symbol_free_list = *(struct Lisp_Symbol **)&symbol_free_list->value;
}
else
{
if (symbol_block_index == SYMBOL_BLOCK_SIZE)
{
- struct symbol_block *new = (struct symbol_block *) xmalloc (sizeof (struct symbol_block));
+ struct symbol_block *new;
+ allocating_for_lisp = 1;
+ new = (struct symbol_block *) xmalloc (sizeof (struct symbol_block));
+ allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = symbol_block;
symbol_block = new;
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;
p->next = 0;
consing_since_gc += sizeof (struct Lisp_Symbol);
+ symbols_consed++;
return val;
}
\f
void
init_marker ()
{
+ allocating_for_lisp = 1;
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;
}
{
if (marker_block_index == MARKER_BLOCK_SIZE)
{
- struct marker_block *new
- = (struct marker_block *) xmalloc (sizeof (struct marker_block));
+ struct marker_block *new;
+ allocating_for_lisp = 1;
+ new = (struct marker_block *) xmalloc (sizeof (struct marker_block));
+ allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (new, sizeof *new);
new->next = marker_block;
marker_block = new;
XSETMISC (val, &marker_block->markers[marker_block_index++]);
}
consing_since_gc += sizeof (union Lisp_Misc);
+ misc_objects_consed++;
return val;
}
register struct Lisp_Marker *p;
val = allocate_misc ();
- XMISC (val)->type = Lisp_Misc_Marker;
+ XMISCTYPE (val) = Lisp_Misc_Marker;
p = XMARKER (val);
p->buffer = 0;
- p->bufpos = 0;
+ p->bytepos = 0;
+ p->charpos = 0;
p->chain = Qnil;
+ 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
/* If SIZE is the length of a string, this returns how many bytes
the string occupies in a string_block (including padding). */
-#define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
- & ~(PAD - 1))
-#define PAD (sizeof (EMACS_INT))
+#define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \
+ & ~(STRING_PAD - 1))
+ /* Add 1 for the null terminator,
+ and add STRING_PAD - 1 as part of rounding up. */
+
+#define STRING_PAD (sizeof (EMACS_INT))
+/* Size of the stuff in the string not including its data. */
+#define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD)
#if 0
#define STRING_FULLSIZE(SIZE) \
void
init_strings ()
{
+ allocating_for_lisp = 1;
current_string_block = (struct string_block *) malloc (sizeof (struct string_block));
+ allocating_for_lisp = 0;
first_string_block = current_string_block;
consing_since_gc += sizeof (struct string_block);
current_string_block->next = 0;
Lisp_Object length, init;
{
register Lisp_Object val;
- register unsigned char *p, *end, c;
+ register unsigned char *p, *end;
+ int c, nbytes;
- if (!INTEGERP (length) || XINT (length) < 0)
- length = wrong_type_argument (Qnatnump, length);
+ CHECK_NATNUM (length, 0);
CHECK_NUMBER (init, 1);
- val = make_uninit_string (XINT (length));
+
c = XINT (init);
- p = XSTRING (val)->data;
- end = p + XSTRING (val)->size;
- while (p != end)
- *p++ = c;
+ if (SINGLE_BYTE_CHAR_P (c))
+ {
+ nbytes = XINT (length);
+ val = make_uninit_multibyte_string (nbytes, nbytes);
+ p = XSTRING (val)->data;
+ end = p + XSTRING (val)->size;
+ while (p != end)
+ *p++ = c;
+ }
+ else
+ {
+ unsigned char work[4], *str;
+ int len = CHAR_STRING (c, work, str);
+
+ nbytes = len * XINT (length);
+ val = make_uninit_multibyte_string (XINT (length), nbytes);
+ p = XSTRING (val)->data;
+ end = p + nbytes;
+ while (p != end)
+ {
+ bcopy (str, p, len);
+ 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)
+ Lisp_Object length, init;
+{
+ register Lisp_Object val;
+ struct Lisp_Bool_Vector *p;
+ int real_init, i;
+ int length_in_chars, length_in_elts, bits_per_value;
+
+ CHECK_NATNUM (length, 0);
+
+ 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);
+
+ /* 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;
+ 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;
+
+ return val;
+}
+
+/* Make a string from NBYTES bytes at CONTENTS,
+ and compute the number of characters from the contents. */
+
Lisp_Object
-make_string (contents, length)
+make_string (contents, nbytes)
+ char *contents;
+ int nbytes;
+{
+ register Lisp_Object val;
+ int nchars = chars_in_text (contents, nbytes);
+ val = make_uninit_multibyte_string (nchars, nbytes);
+ bcopy (contents, XSTRING (val)->data, nbytes);
+ return val;
+}
+
+/* Make a string from LENGTH bytes at CONTENTS,
+ assuming each byte is a character. */
+
+Lisp_Object
+make_unibyte_string (contents, length)
char *contents;
int length;
{
return val;
}
+/* Make a string from NCHARS characters occupying NBYTES bytes at CONTENTS. */
+
+Lisp_Object
+make_multibyte_string (contents, nchars, nbytes)
+ char *contents;
+ int nchars, nbytes;
+{
+ register Lisp_Object val;
+ val = make_uninit_multibyte_string (nchars, nbytes);
+ bcopy (contents, XSTRING (val)->data, nbytes);
+ return val;
+}
+
+/* Make a string from the data at STR,
+ treating it as multibyte if the data warrants. */
+
Lisp_Object
build_string (str)
char *str;
Lisp_Object
make_uninit_string (length)
int length;
+{
+ return make_uninit_multibyte_string (length, length);
+}
+
+Lisp_Object
+make_uninit_multibyte_string (length, length_byte)
+ int length, length_byte;
{
register Lisp_Object val;
- register int fullsize = STRING_FULLSIZE (length);
+ register int fullsize = STRING_FULLSIZE (length_byte);
if (length < 0) abort ();
else if (fullsize > STRING_BLOCK_OUTSIZE)
/* This string gets its own string block */
{
- register struct string_block *new
- = (struct string_block *) xmalloc (sizeof (struct string_block_head) + fullsize);
+ 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;
new->pos = fullsize;
else
/* Make a new current string block and start it off with this string */
{
- register struct string_block *new
- = (struct string_block *) xmalloc (sizeof (struct string_block));
+ register struct string_block *new;
+ allocating_for_lisp = 1;
+ new = (struct string_block *) xmalloc (sizeof (struct string_block));
+ allocating_for_lisp = 0;
VALIDATE_LISP_STORAGE (new, sizeof *new);
consing_since_gc += sizeof (struct string_block);
current_string_block->next = new;
(struct Lisp_String *) current_string_block->chars);
}
+ string_chars_consed += fullsize;
XSTRING (val)->size = length;
- XSTRING (val)->data[length] = 0;
+ XSTRING (val)->size_byte = length_byte;
+ XSTRING (val)->data[length_byte] = 0;
INITIALIZE_INTERVAL (XSTRING (val), NULL_INTERVAL);
return val;
{
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]);
then the string is not protected from gc. */
Lisp_Object
-make_pure_string (data, length)
+make_pure_string (data, length, length_byte)
char *data;
int length;
+ int length_byte;
{
register Lisp_Object new;
- register int size = sizeof (EMACS_INT) + INTERVAL_PTR_SIZE + length + 1;
+ register int size = STRING_FULLSIZE (length_byte);
if (pureptr + size > PURESIZE)
error ("Pure Lisp storage exhausted");
XSETSTRING (new, PUREBEG + pureptr);
XSTRING (new)->size = length;
- bcopy (data, XSTRING (new)->data, length);
- XSTRING (new)->data[length] = 0;
+ XSTRING (new)->size_byte = length_byte;
+ bcopy (data, XSTRING (new)->data, length_byte);
+ XSTRING (new)->data[length_byte] = 0;
/* We must give strings in pure storage some kind of interval. So we
give them a null one. */
#if defined (USE_TEXT_PROPERTIES)
XSTRING (new)->intervals = NULL_INTERVAL;
#endif
- pureptr += (size + sizeof (EMACS_INT) - 1)
- / sizeof (EMACS_INT) * sizeof (EMACS_INT);
+ pureptr += size;
return new;
}
(obj)
register Lisp_Object obj;
{
- register Lisp_Object new, tem;
- register int i;
-
if (NILP (Vpurify_flag))
return obj;
&& (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
return obj;
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XTYPE (obj))
-#else
- switch (XTYPE (obj))
-#endif
- {
- case Lisp_Misc:
- switch (XMISC (obj)->type)
- {
- case Lisp_Misc_Marker:
- error ("Attempt to copy a marker to pure storage");
-
- default:
- abort ();
- }
-
- case Lisp_Cons:
- return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr);
-
+ if (CONSP (obj))
+ return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr);
#ifdef LISP_FLOAT_TYPE
- case Lisp_Float:
- return make_pure_float (XFLOAT (obj)->data);
+ else if (FLOATP (obj))
+ return make_pure_float (XFLOAT (obj)->data);
#endif /* LISP_FLOAT_TYPE */
-
- case Lisp_String:
- return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size);
-
- case Lisp_Compiled:
- case Lisp_Vector:
- new = make_pure_vector (XVECTOR (obj)->size);
- for (i = 0; i < XVECTOR (obj)->size; i++)
- {
- tem = XVECTOR (obj)->contents[i];
- XVECTOR (new)->contents[i] = Fpurecopy (tem);
- }
- XSETTYPE (new, XTYPE (obj));
- return new;
-
- default:
+ else if (STRINGP (obj))
+ return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size,
+ XSTRING (obj)->size_byte);
+ else if (COMPILEDP (obj) || VECTORP (obj))
+ {
+ register struct Lisp_Vector *vec;
+ register int i, size;
+
+ size = XVECTOR (obj)->size;
+ if (size & PSEUDOVECTOR_FLAG)
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ 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))
+ XSETCOMPILED (obj, vec);
+ else
+ XSETVECTOR (obj, vec);
return obj;
}
+ else if (MARKERP (obj))
+ error ("Attempt to copy a marker to pure storage");
+ else
+ return obj;
}
\f
/* Recording what needs to be marked for gc. */
struct gcpro *gcprolist;
-#define NSTATICS 512
+#define NSTATICS 768
Lisp_Object *staticvec[NSTATICS] = {0};
Lisp_Object tag;
Lisp_Object val;
struct catchtag *next;
-/* jmp_buf jmp; /* We don't need this for GC purposes */
+#if 0 /* We don't need this for GC purposes */
+ jmp_buf jmp;
+#endif
};
struct backtrace
\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
+inhibit_garbage_collection ()
+{
+ int count = specpdl_ptr - specpdl;
+ Lisp_Object number;
+ int nbits = min (VALBITS, BITS_PER_INT);
+
+ XSETINT (number, ((EMACS_INT) 1 << (nbits - 1)) - 1);
+
+ specbind (Qgc_cons_threshold, number);
+
+ 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))\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.")
()
register Lisp_Object tem;
char *omessage = echo_area_glyphs;
int omessage_length = echo_area_glyphs_length;
+ int oldmultibyte = message_enable_multibyte;
char stack_top_variable;
register int i;
+ /* In case user calls debug_print during GC,
+ don't let that cause a recursive GC. */
+ consing_since_gc = 0;
+
/* Save a copy of the contents of the stack, for debugging. */
#if MAX_SAVE_STACK > 0
if (NILP (Vpurify_flag))
}
#endif /* MAX_SAVE_STACK > 0 */
- if (!noninteractive)
- message1 ("Garbage collecting...");
+ 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. */
XMARK (backlist->args[i]);
}
}
+ mark_kboards ();
gc_sweep ();
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 (omessage, omessage_length);
- else if (!noninteractive)
- message1 ("Garbage collecting...done");
+ if (garbage_collection_messages)
+ {
+ if (omessage || minibuf_level > 0)
+ message2_nolog (omessage, omessage_length, oldmultibyte);
+ 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
{
register int i;
for (i = 0; i < lim; i++)
- if (sblk->markers[i].type == Lisp_Misc_Marker)
+ if (sblk->markers[i].u_marker.type == Lisp_Misc_Marker)
XUNMARK (sblk->markers[i].u_marker.chain);
lim = MARKER_BLOCK_SIZE;
}
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:
if (last_marked_index == LAST_MARKED_SIZE)
last_marked_index = 0;
-#ifdef SWITCH_ENUM_BUG
- switch ((int) XGCTYPE (obj))
-#else
- switch (XGCTYPE (obj))
-#endif
+ switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
{
case Lisp_String:
{
{
/* A small string. Put this reference
into the chain of references to it.
- The address OBJPTR is even, so if the address
- includes MARKBIT, put it in the low bit
+ If the address includes MARKBIT, put that bit elsewhere
when we store OBJPTR into the size field. */
if (XMARKBIT (*objptr))
}
else
XSETFASTINT (*objptr, ptr->size);
- if ((EMACS_INT) objptr & 1) abort ();
- ptr->size = (EMACS_INT) objptr & ~MARKBIT;
- if ((EMACS_INT) objptr & MARKBIT)
- ptr->size ++;
- }
- }
- break;
- case Lisp_Vector:
- case Lisp_Window:
- case Lisp_Process:
- case Lisp_Window_Configuration:
- {
- register struct Lisp_Vector *ptr = XVECTOR (obj);
- register EMACS_INT size = ptr->size;
- /* The reason we use ptr1 is to avoid an apparent hardware bug
- that happens occasionally on the FSF's HP 300s.
- The bug is that a2 gets clobbered by recursive calls to mark_object.
- The clobberage seems to happen during function entry,
- perhaps in the moveml instruction.
- Yes, this is a crock, but we have to do it. */
- struct Lisp_Vector *volatile ptr1 = ptr;
- register int i;
-
- if (size & ARRAY_MARK_FLAG) break; /* Already marked */
- ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
- for (i = 0; i < size; i++) /* and then mark its elements */
- mark_object (&ptr1->contents[i]);
- }
- break;
-
- case Lisp_Compiled:
- /* We could treat this just like a vector, but it is better
- to save the COMPILED_CONSTANTS element for last and avoid recursion
- there. */
- {
- register struct Lisp_Vector *ptr = XVECTOR (obj);
- register EMACS_INT size = ptr->size;
- /* See comment above under Lisp_Vector. */
- struct Lisp_Vector *volatile ptr1 = ptr;
- register int i;
-
- if (size & ARRAY_MARK_FLAG) break; /* Already marked */
- ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
- for (i = 0; i < size; i++) /* and then mark its elements */
- {
- if (i != COMPILED_CONSTANTS)
- mark_object (&ptr1->contents[i]);
+ if ((EMACS_INT) objptr & DONT_COPY_FLAG)
+ abort ();
+ ptr->size = (EMACS_INT) objptr;
+ if (ptr->size & MARKBIT)
+ ptr->size ^= MARKBIT | DONT_COPY_FLAG;
}
- /* This cast should be unnecessary, but some Mips compiler complains
- (MIPS-ABI + SysVR4, DC/OSx, etc). */
- objptr = (Lisp_Object *) &ptr1->contents[COMPILED_CONSTANTS];
- goto loop;
}
+ break;
-#ifdef MULTI_FRAME
- case Lisp_Frame:
- {
- /* See comment above under Lisp_Vector for why this is volatile. */
- register struct frame *volatile ptr = XFRAME (obj);
- register EMACS_INT size = ptr->size;
-
- if (size & ARRAY_MARK_FLAG) break; /* Already marked */
- ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+ case Lisp_Vectorlike:
+ if (GC_BUFFERP (obj))
+ {
+ if (!XMARKBIT (XBUFFER (obj)->name))
+ mark_buffer (obj);
+ }
+ else if (GC_SUBRP (obj))
+ break;
+ else if (GC_COMPILEDP (obj))
+ /* We could treat this just like a vector, but it is better
+ to save the COMPILED_CONSTANTS element for last and avoid recursion
+ there. */
+ {
+ register struct Lisp_Vector *ptr = XVECTOR (obj);
+ register EMACS_INT size = ptr->size;
+ /* See comment above under Lisp_Vector. */
+ struct Lisp_Vector *volatile ptr1 = ptr;
+ register int i;
+
+ if (size & ARRAY_MARK_FLAG)
+ break; /* Already marked */
+ ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ for (i = 0; i < size; i++) /* and then mark its elements */
+ {
+ if (i != COMPILED_CONSTANTS)
+ mark_object (&ptr1->contents[i]);
+ }
+ /* This cast should be unnecessary, but some Mips compiler complains
+ (MIPS-ABI + SysVR4, DC/OSx, etc). */
+ objptr = (Lisp_Object *) &ptr1->contents[COMPILED_CONSTANTS];
+ goto loop;
+ }
+ else if (GC_FRAMEP (obj))
+ {
+ /* See comment above under Lisp_Vector for why this is volatile. */
+ register struct frame *volatile ptr = XFRAME (obj);
+ register EMACS_INT size = ptr->size;
+
+ if (size & ARRAY_MARK_FLAG) break; /* Already marked */
+ ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+
+ 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->param_alist);
+ mark_object (&ptr->scroll_bars);
+ mark_object (&ptr->condemned_scroll_bars);
+ mark_object (&ptr->menu_bar_items);
+ mark_object (&ptr->face_alist);
+ mark_object (&ptr->menu_bar_vector);
+ mark_object (&ptr->buffer_predicate);
+ mark_object (&ptr->buffer_list);
+ }
+ else if (GC_BOOL_VECTOR_P (obj))
+ {
+ register struct Lisp_Vector *ptr = XVECTOR (obj);
- mark_object (&ptr->name);
- mark_object (&ptr->focus_frame);
- mark_object (&ptr->width);
- mark_object (&ptr->height);
- mark_object (&ptr->selected_window);
- mark_object (&ptr->minibuffer_window);
- mark_object (&ptr->param_alist);
- mark_object (&ptr->scroll_bars);
- mark_object (&ptr->condemned_scroll_bars);
- mark_object (&ptr->menu_bar_items);
- mark_object (&ptr->menu_bar_vector);
- mark_object (&ptr->face_alist);
- }
+ 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);
+ register EMACS_INT size = ptr->size;
+ /* The reason we use ptr1 is to avoid an apparent hardware bug
+ that happens occasionally on the FSF's HP 300s.
+ The bug is that a2 gets clobbered by recursive calls to mark_object.
+ The clobberage seems to happen during function entry,
+ perhaps in the moveml instruction.
+ Yes, this is a crock, but we have to do it. */
+ struct Lisp_Vector *volatile ptr1 = ptr;
+ register int i;
+
+ if (size & ARRAY_MARK_FLAG) break; /* Already marked */
+ ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
+ if (size & PSEUDOVECTOR_FLAG)
+ size &= PSEUDOVECTOR_SIZE_MASK;
+ for (i = 0; i < size; i++) /* and then mark its elements */
+ mark_object (&ptr1->contents[i]);
+ }
break;
-#endif /* MULTI_FRAME */
case Lisp_Symbol:
{
mark_object (&ptr->plist);
XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
mark_object (&ptr->name);
+ /* 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. */
ptr = ptr->next;
if (ptr)
{
break;
case Lisp_Misc:
- switch (XMISC (obj)->type)
+ switch (XMISCTYPE (obj))
{
case Lisp_Misc_Marker:
XMARK (XMARKER (obj)->chain);
instead, markers are removed from the chain when freed by gc. */
break;
+ case Lisp_Misc_Buffer_Local_Value:
+ case Lisp_Misc_Some_Buffer_Local_Value:
+ {
+ register struct Lisp_Buffer_Local_Value *ptr
+ = XBUFFER_LOCAL_VALUE (obj);
+ if (XMARKBIT (ptr->car)) break;
+ XMARK (ptr->car);
+ /* If the cdr is nil, avoid recursion for the car. */
+ if (EQ (ptr->cdr, Qnil))
+ {
+ objptr = &ptr->car;
+ goto loop;
+ }
+ mark_object (&ptr->car);
+ /* See comment above under Lisp_Vector for why not use ptr here. */
+ objptr = &XBUFFER_LOCAL_VALUE (obj)->cdr;
+ goto loop;
+ }
+
+ case Lisp_Misc_Intfwd:
+ case Lisp_Misc_Boolfwd:
+ case Lisp_Misc_Objfwd:
+ case Lisp_Misc_Buffer_Objfwd:
+ case Lisp_Misc_Kboard_Objfwd:
+ /* Don't bother with Lisp_Buffer_Objfwd,
+ since all markable slots in current buffer marked anyway. */
+ /* Don't need to do Lisp_Objfwd, since the places they point
+ are protected with staticpro. */
+ break;
+
+ case Lisp_Misc_Overlay:
+ {
+ struct Lisp_Overlay *ptr = XOVERLAY (obj);
+ if (!XMARKBIT (ptr->plist))
+ {
+ XMARK (ptr->plist);
+ mark_object (&ptr->start);
+ mark_object (&ptr->end);
+ objptr = &ptr->plist;
+ goto loop;
+ }
+ }
+ break;
+
default:
abort ();
}
break;
case Lisp_Cons:
- case Lisp_Buffer_Local_Value:
- case Lisp_Some_Buffer_Local_Value:
- case Lisp_Overlay:
{
register struct Lisp_Cons *ptr = XCONS (obj);
if (XMARKBIT (ptr->car)) break;
break;
#endif /* LISP_FLOAT_TYPE */
- case Lisp_Buffer:
- if (!XMARKBIT (XBUFFER (obj)->name))
- mark_buffer (obj);
- break;
-
case Lisp_Int:
- case Lisp_Subr:
- case Lisp_Intfwd:
- case Lisp_Boolfwd:
- case Lisp_Objfwd:
- case Lisp_Buffer_Objfwd:
- /* Don't bother with Lisp_Buffer_Objfwd,
- since all markable slots in current buffer marked anyway. */
- /* Don't need to do Lisp_Objfwd, since the places they point
- are protected with staticpro. */
break;
default:
{
register struct buffer *buffer = XBUFFER (buf);
register Lisp_Object *ptr;
+ Lisp_Object base_buffer;
/* This is the buffer's markbit */
mark_object (&buffer->name);
XMARK (buffer->name);
- MARK_INTERVAL_TREE (buffer->intervals);
+ MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
#if 0
mark_object (buffer->syntax_table);
(char *)ptr < (char *)buffer + sizeof (struct buffer);
ptr++)
mark_object (ptr);
+
+ /* 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);
+ mark_buffer (base_buffer);
+ }
+}
+
+
+/* Mark the pointers in the kboard objects. */
+
+static void
+mark_kboards ()
+{
+ KBOARD *kb;
+ Lisp_Object *p;
+ for (kb = all_kboards; kb; kb = kb->next_kboard)
+ {
+ if (kb->kbd_macro_buffer)
+ for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++)
+ mark_object (p);
+ mark_object (&kb->Vprefix_arg);
+ mark_object (&kb->kbd_queue);
+ mark_object (&kb->Vlast_kbd_macro);
+ mark_object (&kb->Vsystem_key_alist);
+ mark_object (&kb->system_key_syms);
+ }
}
\f
/* Sweep: find all structures not marked, and free them. */
/* 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))
{
- XSETFASTINT (cblk->conses[i].car, (EMACS_INT) cons_free_list);
num_free++;
+ 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))
{
- XSETFASTINT (fblk->floats[i].type, (EMACS_INT) float_free_list);
num_free++;
+ 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))
{
- XSETFASTINT (sblk->symbols[i].value, (EMACS_INT) symbol_free_list);
+ *(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 Lisp_Marker *tem1;
+ 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++)
- if (mblk->markers[i].type == Lisp_Misc_Marker)
- {
- if (!XMARKBIT (mblk->markers[i].u_marker.chain))
- {
- Lisp_Object tem;
- tem1 = &mblk->markers[i].u_marker; /* tem1 avoids Sun compiler bug */
- XSETMARKER (tem, tem1);
- unchain_marker (tem);
- /* We could leave the type alone, since nobody checks it,
- but this might catch bugs faster. */
- mblk->markers[i].type = Lisp_Misc_Free;
- mblk->markers[i].u_free.chain = marker_free_list;
- marker_free_list = &mblk->markers[i];
- num_free++;
- }
- else
- {
- num_used++;
- XUNMARK (mblk->markers[i].u_marker.chain);
- }
- }
+ {
+ Lisp_Object *markword;
+ switch (mblk->markers[i].u_marker.type)
+ {
+ case Lisp_Misc_Marker:
+ markword = &mblk->markers[i].u_marker.chain;
+ break;
+ case Lisp_Misc_Buffer_Local_Value:
+ case Lisp_Misc_Some_Buffer_Local_Value:
+ markword = &mblk->markers[i].u_buffer_local_value.car;
+ break;
+ case Lisp_Misc_Overlay:
+ markword = &mblk->markers[i].u_overlay.plist;
+ break;
+ case Lisp_Misc_Free:
+ /* If the object was already free, keep it
+ on the free list. */
+ markword = (Lisp_Object *) &already_free;
+ break;
+ default:
+ markword = 0;
+ break;
+ }
+ if (markword && !XMARKBIT (*markword))
+ {
+ Lisp_Object tem;
+ if (mblk->markers[i].u_marker.type == Lisp_Misc_Marker)
+ {
+ /* tem1 avoids Sun compiler bug */
+ struct Lisp_Marker *tem1 = &mblk->markers[i].u_marker;
+ XSETMARKER (tem, tem1);
+ unchain_marker (tem);
+ }
+ /* Set the type of the freed object to Lisp_Misc_Free.
+ We could leave the type alone, since nobody checks it,
+ but this might catch bugs faster. */
+ mblk->markers[i].u_marker.type = Lisp_Misc_Free;
+ mblk->markers[i].u_free.chain = marker_free_list;
+ marker_free_list = &mblk->markers[i];
+ num_free++;
+ this_free++;
+ }
+ else
+ {
+ num_used++;
+ if (markword)
+ XUNMARK (*markword);
+ }
+ }
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;
else
{
XUNMARK (buffer->name);
- UNMARK_BALANCE_INTERVALS (buffer->intervals);
+ UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
#if 0
/* Each `struct Lisp_String *' was turned into a Lisp_Object
else
{
vector->size &= ~ARRAY_MARK_FLAG;
- total_vector_size += vector->size;
+ if (vector->size & PSEUDOVECTOR_FLAG)
+ total_vector_size += (PSEUDOVECTOR_SIZE_MASK & vector->size);
+ else
+ total_vector_size += vector->size;
prev = vector, vector = vector->next;
}
}
register struct Lisp_String *newaddr;
register EMACS_INT size = nextstr->size;
+ EMACS_INT size_byte = nextstr->size_byte;
/* NEXTSTR is the old address of the next string.
Just skip it if it isn't marked. */
- if ((EMACS_UINT) size > STRING_BLOCK_SIZE)
+ if (((EMACS_UINT) size & ~DONT_COPY_FLAG) > STRING_BLOCK_SIZE)
{
/* It is marked, so its size field is really a chain of refs.
Find the end of the chain, where the actual size lives. */
- while ((EMACS_UINT) size > STRING_BLOCK_SIZE)
+ while (((EMACS_UINT) size & ~DONT_COPY_FLAG) > STRING_BLOCK_SIZE)
{
- if (size & 1) size ^= MARKBIT | 1;
+ if (size & DONT_COPY_FLAG)
+ size ^= MARKBIT | DONT_COPY_FLAG;
size = *(EMACS_INT *)size & ~MARKBIT;
}
- total_string_size += size;
+ total_string_size += size_byte;
/* If it won't fit in TO_SB, close it out,
and move to the next sb. Keep doing so until
since FROM_SB is large enough to contain this string.
Any string blocks skipped here
will be patched out and freed later. */
- while (to_pos + STRING_FULLSIZE (size)
+ while (to_pos + STRING_FULLSIZE (size_byte)
> max (to_sb->pos, STRING_BLOCK_SIZE))
{
to_sb->pos = to_pos;
/* Compute new address of this string
and update TO_POS for the space being used. */
newaddr = (struct Lisp_String *) &to_sb->chars[to_pos];
- to_pos += STRING_FULLSIZE (size);
+ to_pos += STRING_FULLSIZE (size_byte);
/* Copy the string itself to the new place. */
if (nextstr != newaddr)
- bcopy (nextstr, newaddr, size + 1 + sizeof (EMACS_INT)
- + INTERVAL_PTR_SIZE);
+ bcopy (nextstr, newaddr, STRING_FULLSIZE (size_byte));
/* Go through NEXTSTR's chain of references
and make each slot in the chain point to
the new address of this string. */
size = newaddr->size;
- while ((EMACS_UINT) size > STRING_BLOCK_SIZE)
+ while (((EMACS_UINT) size & ~DONT_COPY_FLAG) > STRING_BLOCK_SIZE)
{
register Lisp_Object *objptr;
- if (size & 1) size ^= MARKBIT | 1;
+ if (size & DONT_COPY_FLAG)
+ size ^= MARKBIT | DONT_COPY_FLAG;
objptr = (Lisp_Object *)size;
size = XFASTINT (*objptr) & ~MARKBIT;
}
#endif /* USE_TEXT_PROPERTIES */
}
- pos += STRING_FULLSIZE (size);
+ pos += STRING_FULLSIZE (size_byte);
}
}
return 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)\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).")
+ ()
+{
+ Lisp_Object lisp_cons_cells_consed;
+ Lisp_Object lisp_floats_consed;
+ Lisp_Object lisp_vector_cells_consed;
+ Lisp_Object lisp_symbols_consed;
+ Lisp_Object lisp_string_chars_consed;
+ Lisp_Object lisp_misc_objects_consed;
+ Lisp_Object lisp_intervals_consed;
+
+ XSETINT (lisp_cons_cells_consed,
+ cons_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
+ XSETINT (lisp_floats_consed,
+ floats_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
+ XSETINT (lisp_vector_cells_consed,
+ vector_cells_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
+ XSETINT (lisp_symbols_consed,
+ symbols_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
+ XSETINT (lisp_string_chars_consed,
+ string_chars_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
+ XSETINT (lisp_misc_objects_consed,
+ misc_objects_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
+ XSETINT (lisp_intervals_consed,
+ intervals_consed & ~(((EMACS_INT) 1) << (VALBITS - 1)));
+
+ return Fcons (lisp_cons_cells_consed,
+ Fcons (lisp_floats_consed,
+ Fcons (lisp_vector_cells_consed,
+ Fcons (lisp_symbols_consed,
+ Fcons (lisp_string_chars_consed,
+ Fcons (lisp_misc_objects_consed,
+ Fcons (lisp_intervals_consed,
+ Qnil)))))));
+}
\f
/* Initialization */
#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 ();
#endif /* LISP_FLOAT_TYPE */
INIT_INTERVALS;
+#ifdef REL_ALLOC
+ malloc_hysteresis = 32;
+#else
+ malloc_hysteresis = 0;
+#endif
+
+ spare_memory = (char *) malloc (SPARE_MEMORY);
+
ignore_warnings = 0;
gcprolist = 0;
staticidx = 0;
consing_since_gc = 0;
- gc_cons_threshold = 100000;
+ gc_cons_threshold = 100000 * sizeof (Lisp_Object);
#ifdef VIRT_ADDR_VARIES
malloc_sbrk_unused = 1<<22; /* A large number */
malloc_sbrk_used = 100000; /* as reasonable as any number */
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
- = Fcons (Qerror, Fcons (build_string ("Memory exhausted"), Qnil));
+ = Fcons (Qerror, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil));
staticpro (&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);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
+ defsubr (&Smake_char_table);
defsubr (&Smake_string);
+ defsubr (&Smake_bool_vector);
defsubr (&Smake_symbol);
defsubr (&Smake_marker);
defsubr (&Spurecopy);
defsubr (&Sgarbage_collect);
defsubr (&Smemory_limit);
+ defsubr (&Smemory_use_counts);
}
HCoop / bpt / emacs.git / blobdiff