X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/3f872b675a1c21775d763c0359fed2cb13756daa..26c76ace8de7d0fa687d8a76b3a3bce5fb1ee692:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 402bc9486e..9f79ee5aa6 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -1,5 +1,5 @@ /* Storage allocation and gc for GNU Emacs Lisp interpreter. - Copyright (C) 1985, 1986, 1988, 1993 Free Software Foundation, Inc. + Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -15,8 +15,10 @@ GNU General Public License for more details. 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 #include @@ -28,11 +30,26 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include "window.h" #include "frame.h" #include "blockinput.h" +#include "keyboard.h" #endif #include "syssignal.h" +extern char *sbrk (); + +/* The following come from gmalloc.c. */ + +#if defined (__STDC__) && __STDC__ +#include +#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; + #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. @@ -42,7 +59,7 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ do \ { \ Lisp_Object val; \ - XSET (val, Lisp_Cons, (char *) address + size); \ + XSETCONS (val, (char *) address + size); \ if ((char *) XCONS (val) != (char *) address + size) \ { \ xfree (address); \ @@ -50,15 +67,30 @@ do \ } \ } 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 */ @@ -73,11 +105,24 @@ extern int undo_limit; int undo_strong_limit; +/* 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; #ifndef HAVE_SHM -int pure[PURESIZE / sizeof (int)] = {0,}; /* Force it into data space! */ +EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {0,}; /* Force it into data space! */ #define PUREBEG (char *) pure #else #define pure PURE_SEG_BITS /* Use shared memory segment */ @@ -89,7 +134,7 @@ int pure[PURESIZE / sizeof (int)] = {0,}; /* Force it into data space! */ you should be able to change that without too much recompilation. So map_in_data initializes pure_size, and the dependencies work out. */ -int pure_size; +EMACS_INT pure_size; #endif /* not HAVE_SHM */ /* Index in pure at which next pure object will be allocated. */ @@ -107,6 +152,17 @@ Lisp_Object memory_signal_data; #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; @@ -115,7 +171,9 @@ int stack_copy_size; /* 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 (); @@ -149,8 +207,42 @@ display_malloc_warning () } /* Called if malloc returns zero */ + 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 (Qerror, 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) @@ -221,6 +313,8 @@ static void * (*old_realloc_hook) (); 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; @@ -228,10 +322,37 @@ emacs_blocked_free (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; @@ -240,6 +361,7 @@ emacs_blocked_malloc (size) BLOCK_INPUT; __malloc_hook = old_malloc_hook; + __malloc_extra_blocks = malloc_hysteresis; value = (void *) malloc (size); __malloc_hook = emacs_blocked_malloc; UNBLOCK_INPUT; @@ -297,10 +419,12 @@ INTERVAL interval_free_list; 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; } @@ -321,9 +445,12 @@ make_interval () { 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; @@ -332,6 +459,7 @@ make_interval () val = &interval_block->intervals[interval_block_index++]; } consing_since_gc += sizeof (struct interval); + intervals_consed++; RESET_INTERVAL (val); return val; } @@ -424,9 +552,11 @@ struct Lisp_Float *float_free_list; 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; } @@ -435,7 +565,7 @@ init_float () free_float (ptr) struct Lisp_Float *ptr; { - XFASTINT (ptr->type) = (int) float_free_list; + *(struct Lisp_Float **)&ptr->type = float_free_list; float_free_list = ptr; } @@ -447,24 +577,29 @@ make_float (float_value) if (float_free_list) { - XSET (val, Lisp_Float, float_free_list); - float_free_list = (struct Lisp_Float *) XFASTINT (float_free_list->type); + XSETFLOAT (val, float_free_list); + float_free_list = *(struct Lisp_Float **)&float_free_list->type; } 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; float_block_index = 0; } - XSET (val, Lisp_Float, &float_block->floats[float_block_index++]); + XSETFLOAT (val, &float_block->floats[float_block_index++]); } XFLOAT (val)->data = float_value; - XFLOAT (val)->type = 0; /* bug chasing -wsr */ + XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */ consing_since_gc += sizeof (struct Lisp_Float); + floats_consed++; return val; } @@ -497,9 +632,11 @@ struct Lisp_Cons *cons_free_list; 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; } @@ -508,7 +645,7 @@ init_cons () free_cons (ptr) struct Lisp_Cons *ptr; { - XFASTINT (ptr->car) = (int) cons_free_list; + *(struct Lisp_Cons **)&ptr->car = cons_free_list; cons_free_list = ptr; } @@ -521,24 +658,28 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, if (cons_free_list) { - XSET (val, Lisp_Cons, cons_free_list); - cons_free_list = (struct Lisp_Cons *) XFASTINT (cons_free_list->car); + XSETCONS (val, cons_free_list); + cons_free_list = *(struct Lisp_Cons **)&cons_free_list->car; } 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; cons_block_index = 0; } - XSET (val, Lisp_Cons, &cons_block->conses[cons_block_index++]); + XSETCONS (val, &cons_block->conses[cons_block_index++]); } XCONS (val)->car = car; XCONS (val)->cdr = cdr; consing_since_gc += sizeof (struct Lisp_Cons); + cons_cells_consed++; return val; } @@ -549,15 +690,13 @@ Any number of arguments, even zero arguments, are allowed.") int nargs; register Lisp_Object *args; { - register Lisp_Object len, val, val_tail; + register Lisp_Object val; + val = Qnil; - XFASTINT (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; } @@ -570,9 +709,8 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, register Lisp_Object val; register int size; - if (XTYPE (length) != Lisp_Int || XINT (length) < 0) - length = wrong_type_argument (Qnatnump, length); - size = XINT (length); + CHECK_NATNUM (length, 0); + size = XFASTINT (length); val = Qnil; while (size-- > 0) @@ -584,33 +722,70 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, struct Lisp_Vector *all_vectors; +struct Lisp_Vector * +allocate_vectorlike (len) + EMACS_INT len; +{ + struct Lisp_Vector *p; + + allocating_for_lisp = 1; + p = (struct Lisp_Vector *)xmalloc (sizeof (struct Lisp_Vector) + + (len - 1) * sizeof (Lisp_Object)); + 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 (XTYPE (length) != Lisp_Int || XINT (length) < 0) - length = wrong_type_argument (Qnatnump, length); - sizei = XINT (length); - - p = (struct Lisp_Vector *) xmalloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object)); - VALIDATE_LISP_STORAGE (p, 0); - - XSET (vector, Lisp_Vector, p); - consing_since_gc += sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object); + CHECK_NATNUM (length, 0); + sizei = XFASTINT (length); + p = allocate_vectorlike (sizei); p->size = sizei; - p->next = all_vectors; - all_vectors = p; - for (index = 0; index < sizei; index++) p->contents[index] = init; + XSETVECTOR (vector, p); + return vector; +} + +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-slot' 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)->parent = Qnil; + XCHAR_TABLE (vector)->purpose = purpose; + XSETCHAR_TABLE (vector, XCHAR_TABLE (vector)); return vector; } @@ -625,7 +800,7 @@ Any number of arguments, even zero arguments, are allowed.") register int index; register struct Lisp_Vector *p; - XFASTINT (len) = nargs; + XSETFASTINT (len, nargs); val = Fmake_vector (len, Qnil); p = XVECTOR (val); for (index = 0; index < nargs; index++) @@ -647,9 +822,9 @@ significance.") register int index; register struct Lisp_Vector *p; - XFASTINT (len) = nargs; + 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); @@ -659,7 +834,7 @@ significance.") args[index] = Fpurecopy (args[index]); p->contents[index] = args[index]; } - XSETTYPE (val, Lisp_Compiled); + XSETCOMPILED (val, val); return val; } @@ -687,9 +862,11 @@ struct Lisp_Symbol *symbol_free_list; 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; } @@ -697,99 +874,120 @@ init_symbol () 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) { - XSET (val, Lisp_Symbol, symbol_free_list); - symbol_free_list - = (struct Lisp_Symbol *) XFASTINT (symbol_free_list->value); + XSETSYMBOL (val, symbol_free_list); + 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; symbol_block_index = 0; } - XSET (val, Lisp_Symbol, &symbol_block->symbols[symbol_block_index++]); + 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; } -/* Allocation of markers. +/* Allocation of markers and other objects that share that structure. Works like allocation of conses. */ #define MARKER_BLOCK_SIZE \ - ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker)) + ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc)) struct marker_block { struct marker_block *next; - struct Lisp_Marker markers[MARKER_BLOCK_SIZE]; + union Lisp_Misc markers[MARKER_BLOCK_SIZE]; }; struct marker_block *marker_block; int marker_block_index; -struct Lisp_Marker *marker_free_list; +union Lisp_Misc *marker_free_list; 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; } -DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, - "Return a newly allocated marker which does not point at any place.") - () +/* Return a newly allocated Lisp_Misc object, with no substructure. */ +Lisp_Object +allocate_misc () { - register Lisp_Object val; - register struct Lisp_Marker *p; + Lisp_Object val; if (marker_free_list) { - XSET (val, Lisp_Marker, marker_free_list); - marker_free_list - = (struct Lisp_Marker *) XFASTINT (marker_free_list->chain); + XSETMISC (val, marker_free_list); + marker_free_list = marker_free_list->u_free.chain; } else { 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; marker_block_index = 0; } - XSET (val, Lisp_Marker, &marker_block->markers[marker_block_index++]); + XSETMISC (val, &marker_block->markers[marker_block_index++]); } + consing_since_gc += sizeof (union Lisp_Misc); + misc_objects_consed++; + return val; +} + +DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, + "Return a newly allocated marker which does not point at any place.") + () +{ + register Lisp_Object val; + register struct Lisp_Marker *p; + + val = allocate_misc (); + XMISCTYPE (val) = Lisp_Misc_Marker; p = XMARKER (val); p->buffer = 0; p->bufpos = 0; p->chain = Qnil; - consing_since_gc += sizeof (struct Lisp_Marker); + p->insertion_type = 0; return val; } @@ -820,13 +1018,13 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, struct string_block_head { struct string_block *next, *prev; - int pos; + EMACS_INT pos; }; struct string_block { struct string_block *next, *prev; - int pos; + EMACS_INT pos; char chars[STRING_BLOCK_SIZE]; }; @@ -847,17 +1045,19 @@ struct string_block *large_string_blocks; #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \ & ~(PAD - 1)) -#define PAD (sizeof (int)) +#define PAD (sizeof (EMACS_INT)) #if 0 #define STRING_FULLSIZE(SIZE) \ -(((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1)) +(((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1)) #endif 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; @@ -875,10 +1075,9 @@ Both LENGTH and INIT must be numbers.") register Lisp_Object val; register unsigned char *p, *end, c; - if (XTYPE (length) != Lisp_Int || XINT (length) < 0) - length = wrong_type_argument (Qnatnump, length); + CHECK_NATNUM (length, 0); CHECK_NUMBER (init, 1); - val = make_uninit_string (XINT (length)); + val = make_uninit_string (XFASTINT (length)); c = XINT (init); p = XSTRING (val)->data; end = p + XSTRING (val)->size; @@ -888,6 +1087,38 @@ Both LENGTH and INIT must be numbers.") return val; } +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.") + (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); + + val = Fmake_vector (make_number (length_in_elts), 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; +} + Lisp_Object make_string (contents, length) char *contents; @@ -918,28 +1149,34 @@ make_uninit_string (length) if (fullsize <= STRING_BLOCK_SIZE - current_string_block->pos) /* This string can fit in the current string block */ { - XSET (val, Lisp_String, - (struct Lisp_String *) (current_string_block->chars + current_string_block->pos)); + XSETSTRING (val, + ((struct Lisp_String *) + (current_string_block->chars + current_string_block->pos))); current_string_block->pos += fullsize; } 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; + new = (struct string_block *) xmalloc (sizeof (struct string_block_head) + fullsize); + allocating_for_lisp = 0; VALIDATE_LISP_STORAGE (new, 0); consing_since_gc += sizeof (struct string_block_head) + fullsize; new->pos = fullsize; new->next = large_string_blocks; large_string_blocks = new; - XSET (val, Lisp_String, - (struct Lisp_String *) ((struct string_block_head *)new + 1)); + XSETSTRING (val, + ((struct Lisp_String *) + ((struct string_block_head *)new + 1))); } 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; @@ -947,10 +1184,11 @@ make_uninit_string (length) new->next = 0; current_string_block = new; new->pos = fullsize; - XSET (val, Lisp_String, - (struct Lisp_String *) current_string_block->chars); + XSETSTRING (val, + (struct Lisp_String *) current_string_block->chars); } + string_chars_consed += fullsize; XSTRING (val)->size = length; XSTRING (val)->data[length] = 0; INITIALIZE_INTERVAL (XSTRING (val), NULL_INTERVAL); @@ -975,15 +1213,16 @@ make_event_array (nargs, args) /* The things that fit in a string are characters that are in 0...127, after discarding the meta bit and all the bits above it. */ - if (XTYPE (args[i]) != Lisp_Int + if (!INTEGERP (args[i]) || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200) return Fvector (nargs, args); /* Since the loop exited, we know that all the things in it are characters, so we can make a string. */ { - Lisp_Object result = Fmake_string (nargs, make_number (0)); + Lisp_Object result; + result = Fmake_string (nargs, make_number (0)); for (i = 0; i < nargs; i++) { XSTRING (result)->data[i] = XINT (args[i]); @@ -1009,11 +1248,11 @@ make_pure_string (data, length) int length; { register Lisp_Object new; - register int size = sizeof (int) + INTERVAL_PTR_SIZE + length + 1; + register int size = sizeof (EMACS_INT) + INTERVAL_PTR_SIZE + length + 1; if (pureptr + size > PURESIZE) error ("Pure Lisp storage exhausted"); - XSET (new, Lisp_String, PUREBEG + pureptr); + XSETSTRING (new, PUREBEG + pureptr); XSTRING (new)->size = length; bcopy (data, XSTRING (new)->data, length); XSTRING (new)->data[length] = 0; @@ -1023,8 +1262,8 @@ make_pure_string (data, length) #if defined (USE_TEXT_PROPERTIES) XSTRING (new)->intervals = NULL_INTERVAL; #endif - pureptr += (size + sizeof (int) - 1) - / sizeof (int) * sizeof (int); + pureptr += (size + sizeof (EMACS_INT) - 1) + / sizeof (EMACS_INT) * sizeof (EMACS_INT); return new; } @@ -1036,7 +1275,7 @@ pure_cons (car, cdr) if (pureptr + sizeof (struct Lisp_Cons) > PURESIZE) error ("Pure Lisp storage exhausted"); - XSET (new, Lisp_Cons, PUREBEG + pureptr); + XSETCONS (new, PUREBEG + pureptr); pureptr += sizeof (struct Lisp_Cons); XCONS (new)->car = Fpurecopy (car); XCONS (new)->cdr = Fpurecopy (cdr); @@ -1074,10 +1313,10 @@ make_pure_float (num) if (pureptr + sizeof (struct Lisp_Float) > PURESIZE) error ("Pure Lisp storage exhausted"); - XSET (new, Lisp_Float, PUREBEG + pureptr); + XSETFLOAT (new, PUREBEG + pureptr); pureptr += sizeof (struct Lisp_Float); XFLOAT (new)->data = num; - XFLOAT (new)->type = 0; /* bug chasing -wsr */ + XSETFASTINT (XFLOAT (new)->type, 0); /* bug chasing -wsr */ return new; } @@ -1085,15 +1324,15 @@ make_pure_float (num) Lisp_Object make_pure_vector (len) - int len; + EMACS_INT len; { register Lisp_Object new; - register int size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object); + register EMACS_INT size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object); if (pureptr + size > PURESIZE) error ("Pure Lisp storage exhausted"); - XSET (new, Lisp_Vector, PUREBEG + pureptr); + XSETVECTOR (new, PUREBEG + pureptr); pureptr += size; XVECTOR (new)->size = len; return new; @@ -1106,9 +1345,6 @@ Does not copy symbols.") (obj) register Lisp_Object obj; { - register Lisp_Object new, tem; - register int i; - if (NILP (Vpurify_flag)) return obj; @@ -1116,47 +1352,42 @@ Does not copy symbols.") && (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_Marker: - error ("Attempt to copy a marker to pure storage"); - - 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); + 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; } /* Recording what needs to be marked for gc. */ struct gcpro *gcprolist; -#define NSTATICS 512 +#define NSTATICS 768 Lisp_Object *staticvec[NSTATICS] = {0}; @@ -1199,12 +1430,28 @@ int total_free_conses, total_free_markers, total_free_symbols; 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.") () @@ -1220,6 +1467,10 @@ Garbage collection happens automatically if you cons more than\n\ 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)) @@ -1234,7 +1485,7 @@ Garbage collection happens automatically if you cons more than\n\ stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i)); if (stack_copy) { - if ((int) (&stack_top_variable - stack_bottom) > 0) + if ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0) bcopy (stack_bottom, stack_copy, i); else bcopy (&stack_top_variable, stack_copy, i); @@ -1243,8 +1494,8 @@ Garbage collection happens automatically if you cons more than\n\ } #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); @@ -1271,7 +1522,7 @@ Garbage collection happens automatically if you cons more than\n\ 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. */ @@ -1330,6 +1581,7 @@ Garbage collection happens automatically if you cons more than\n\ XMARK (backlist->args[i]); } } + mark_kboards (); gc_sweep (); @@ -1351,17 +1603,20 @@ Garbage collection happens automatically if you cons more than\n\ 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); + else + message1_nolog ("Garbage collecting...done"); + } return Fcons (Fcons (make_number (total_conses), make_number (total_free_conses)), @@ -1371,15 +1626,21 @@ Garbage collection happens automatically if you cons more than\n\ 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))))))); } #if 0 @@ -1423,7 +1684,8 @@ clear_marks () { register int i; for (i = 0; i < lim; i++) - XUNMARK (sblk->markers[i].chain); + if (sblk->markers[i].u_marker.type == Lisp_Misc_Marker) + XUNMARK (sblk->markers[i].u_marker.chain); lim = MARKER_BLOCK_SIZE; } } @@ -1455,9 +1717,10 @@ Lisp_Object *last_marked[LAST_MARKED_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: @@ -1473,11 +1736,7 @@ mark_object (objptr) 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: { @@ -1491,94 +1750,111 @@ mark_object (objptr) { /* 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)) { - XFASTINT (*objptr) = ptr->size; + XSETFASTINT (*objptr, ptr->size); XMARK (*objptr); } else - XFASTINT (*objptr) = ptr->size; - if ((int)objptr & 1) abort (); - ptr->size = (int) objptr & ~MARKBIT; - if ((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 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 int size = ptr->size; - /* See comment above under Lisp_Vector. */ - struct Lisp_Vector *volatile ptr1 = ptr; - register int i; + XSETFASTINT (*objptr, ptr->size); - 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; } - objptr = &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 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); + } + 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->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: { @@ -1607,17 +1883,66 @@ mark_object (objptr) } break; - case Lisp_Marker: - XMARK (XMARKER (obj)->chain); - /* DO NOT mark thru the marker's chain. - The buffer's markers chain does not preserve markers from gc; - instead, markers are removed from the chain when freed by gc. */ + case Lisp_Misc: + switch (XMISCTYPE (obj)) + { + case Lisp_Misc_Marker: + XMARK (XMARKER (obj)->chain); + /* DO NOT mark thru the marker's chain. + The buffer's markers chain does not preserve markers from gc; + 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; @@ -1640,23 +1965,7 @@ mark_object (objptr) break; #endif /* LISP_FLOAT_TYPE */ - case Lisp_Buffer: - if (!XMARKBIT (XBUFFER (obj)->name)) - mark_buffer (obj); - break; - case Lisp_Int: - case Lisp_Void: - case Lisp_Subr: - case Lisp_Intfwd: - case Lisp_Boolfwd: - case Lisp_Objfwd: - case Lisp_Buffer_Objfwd: - case Lisp_Internal_Stream: - /* 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: @@ -1672,12 +1981,13 @@ mark_buffer (buf) { 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); @@ -1686,18 +1996,14 @@ mark_buffer (buf) Since the strings may be relocated, we must mark them in their actual slots. So gc_sweep must convert each slot back to an ordinary C pointer. */ - XSET (*(Lisp_Object *)&buffer->upcase_table, - Lisp_String, buffer->upcase_table); + XSETSTRING (*(Lisp_Object *)&buffer->upcase_table, buffer->upcase_table); mark_object ((Lisp_Object *)&buffer->upcase_table); - XSET (*(Lisp_Object *)&buffer->downcase_table, - Lisp_String, buffer->downcase_table); + XSETSTRING (*(Lisp_Object *)&buffer->downcase_table, buffer->downcase_table); mark_object ((Lisp_Object *)&buffer->downcase_table); - XSET (*(Lisp_Object *)&buffer->sort_table, - Lisp_String, buffer->sort_table); + XSETSTRING (*(Lisp_Object *)&buffer->sort_table, buffer->sort_table); mark_object ((Lisp_Object *)&buffer->sort_table); - XSET (*(Lisp_Object *)&buffer->folding_sort_table, - Lisp_String, buffer->folding_sort_table); + XSETSTRING (*(Lisp_Object *)&buffer->folding_sort_table, buffer->folding_sort_table); mark_object ((Lisp_Object *)&buffer->folding_sort_table); #endif @@ -1705,6 +2011,34 @@ mark_buffer (buf) (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); + } } /* Sweep: find all structures not marked, and free them. */ @@ -1729,8 +2063,8 @@ gc_sweep () for (i = 0; i < lim; i++) if (!XMARKBIT (cblk->conses[i].car)) { - XFASTINT (cblk->conses[i].car) = (int) cons_free_list; num_free++; + *(struct Lisp_Cons **)&cblk->conses[i].car = cons_free_list; cons_free_list = &cblk->conses[i]; } else @@ -1759,8 +2093,8 @@ gc_sweep () for (i = 0; i < lim; i++) if (!XMARKBIT (fblk->floats[i].type)) { - XFASTINT (fblk->floats[i].type) = (int) float_free_list; num_free++; + *(struct Lisp_Float **)&fblk->floats[i].type = float_free_list; float_free_list = &fblk->floats[i]; } else @@ -1823,7 +2157,7 @@ gc_sweep () for (i = 0; i < lim; i++) if (!XMARKBIT (sblk->symbols[i].plist)) { - XFASTINT (sblk->symbols[i].value) = (int) symbol_free_list; + *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list; symbol_free_list = &sblk->symbols[i]; num_free++; } @@ -1842,10 +2176,10 @@ gc_sweep () #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; register int lim = marker_block_index; register int num_free = 0, num_used = 0; @@ -1854,22 +2188,57 @@ gc_sweep () for (mblk = marker_block; mblk; mblk = mblk->next) { register int i; + EMACS_INT already_free = -1; + for (i = 0; i < lim; i++) - if (!XMARKBIT (mblk->markers[i].chain)) - { - Lisp_Object tem; - tem1 = &mblk->markers[i]; /* tem1 avoids Sun compiler bug */ - XSET (tem, Lisp_Marker, tem1); - unchain_marker (tem); - XFASTINT (mblk->markers[i].chain) = (int) marker_free_list; - marker_free_list = &mblk->markers[i]; - num_free++; - } - else - { - num_used++; - XUNMARK (mblk->markers[i].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 = &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++; + } + else + { + num_used++; + if (markword) + XUNMARK (*markword); + } + } lim = MARKER_BLOCK_SIZE; } @@ -1895,7 +2264,7 @@ gc_sweep () 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 @@ -1936,7 +2305,10 @@ gc_sweep () 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; } } @@ -1998,18 +2370,19 @@ compact_strings () = (struct Lisp_String *) &from_sb->chars[pos]; register struct Lisp_String *newaddr; - register int size = nextstr->size; + register EMACS_INT size = nextstr->size; /* NEXTSTR is the old address of the next string. Just skip it if it isn't marked. */ - if ((unsigned) 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 ((unsigned) size > STRING_BLOCK_SIZE) + while (((EMACS_UINT) size & ~DONT_COPY_FLAG) > STRING_BLOCK_SIZE) { - if (size & 1) size ^= MARKBIT | 1; - size = *(int *)size & ~MARKBIT; + if (size & DONT_COPY_FLAG) + size ^= MARKBIT | DONT_COPY_FLAG; + size = *(EMACS_INT *)size & ~MARKBIT; } total_string_size += size; @@ -2035,27 +2408,28 @@ compact_strings () /* Copy the string itself to the new place. */ if (nextstr != newaddr) - bcopy (nextstr, newaddr, size + 1 + sizeof (int) + bcopy (nextstr, newaddr, size + 1 + sizeof (EMACS_INT) + INTERVAL_PTR_SIZE); /* 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 ((unsigned) 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; if (XMARKBIT (*objptr)) { - XSET (*objptr, Lisp_String, newaddr); + XSETSTRING (*objptr, newaddr); XMARK (*objptr); } else - XSET (*objptr, Lisp_String, newaddr); + XSETSTRING (*objptr, newaddr); } /* Store the actual size in the size field. */ newaddr->size = size; @@ -2066,9 +2440,8 @@ compact_strings () if (! NULL_INTERVAL_P (newaddr->intervals)) { UNMARK_BALANCE_INTERVALS (newaddr->intervals); - XSET (* (Lisp_Object *) &newaddr->intervals->parent, - Lisp_String, - newaddr); + XSETSTRING (* (Lisp_Object *) &newaddr->intervals->parent, + newaddr); } #endif /* USE_TEXT_PROPERTIES */ } @@ -2117,11 +2490,58 @@ We divide the value by 1024 to make sure it fits in a Lisp integer.") { Lisp_Object end; - XSET (end, Lisp_Int, (int) sbrk (0) / 1024); + XSETINT (end, (EMACS_INT) sbrk (0) / 1024); 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))))))); +} /* Initialization */ @@ -2143,11 +2563,19 @@ init_alloc_once () #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 */ @@ -2173,6 +2601,27 @@ prevent garbage collection during a part of the program."); 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."); @@ -2200,22 +2649,35 @@ The size is counted as the number of bytes occupied,\n\ 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); }