X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/1fb577f7e53a5d2e02752c0cce2e5912b33bbcec..773bb028e7355d831a58c06348ddc4cd1bfe61af:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 5776a2be92..c667acecdf 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, 1994 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. @@ -50,9 +67,21 @@ 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; @@ -73,6 +102,19 @@ 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; @@ -110,7 +152,7 @@ Lisp_Object memory_signal_data; /* Define DONT_COPY_FLAG to be some bit which will always be zero in a pointer to a Lisp_Object, when that pointer is viewed as an integer. (On most machines, pointers are even, so we can use the low bit. - Word-addressible architectures may need to override this in the m-file.) + Word-addressable architectures may need to override this in the m-file.) When linking references to small strings through the size field, we use this slot to hold the bit that would otherwise be interpreted as the GC mark bit. */ @@ -126,7 +168,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 (); @@ -160,8 +204,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) @@ -232,6 +310,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; @@ -239,10 +319,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; @@ -251,6 +358,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; @@ -308,10 +416,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; } @@ -332,9 +442,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; @@ -343,6 +456,7 @@ make_interval () val = &interval_block->intervals[interval_block_index++]; } consing_since_gc += sizeof (struct interval); + intervals_consed++; RESET_INTERVAL (val); return val; } @@ -435,9 +549,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; } @@ -465,7 +581,11 @@ make_float (float_value) { 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; @@ -476,6 +596,7 @@ make_float (float_value) XFLOAT (val)->data = float_value; XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */ consing_since_gc += sizeof (struct Lisp_Float); + floats_consed++; return val; } @@ -508,9 +629,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; } @@ -539,7 +662,10 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, { 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; @@ -550,6 +676,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, XCONS (val)->car = car; XCONS (val)->cdr = cdr; consing_since_gc += sizeof (struct Lisp_Cons); + cons_cells_consed++; return val; } @@ -560,15 +687,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; - 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; } @@ -600,11 +725,14 @@ allocate_vectorlike (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; @@ -634,6 +762,30 @@ See also the function `vector'.") 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; +} + DEFUN ("vector", Fvector, Svector, 0, MANY, 0, "Return a newly created vector with specified arguments as elements.\n\ Any number of arguments, even zero arguments, are allowed.") @@ -707,9 +859,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; } @@ -717,13 +871,13 @@ 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) { @@ -734,7 +888,10 @@ Its value and function definition are void, and its property list is nil.") { 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; @@ -743,12 +900,13 @@ Its value and function definition are void, and its property list is nil.") XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]); } p = XSYMBOL (val); - p->name = XSTRING (str); + p->name = XSTRING (name); p->plist = Qnil; p->value = Qunbound; p->function = Qunbound; p->next = 0; consing_since_gc += sizeof (struct Lisp_Symbol); + symbols_consed++; return val; } @@ -772,9 +930,11 @@ 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; } @@ -794,8 +954,10 @@ allocate_misc () { 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; @@ -804,6 +966,7 @@ allocate_misc () XSETMISC (val, &marker_block->markers[marker_block_index++]); } consing_since_gc += sizeof (union Lisp_Misc); + misc_objects_consed++; return val; } @@ -815,11 +978,12 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, 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->chain = Qnil; + p->insertion_type = 0; return val; } @@ -850,7 +1014,7 @@ 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 @@ -887,7 +1051,9 @@ struct string_block *large_string_blocks; 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; @@ -917,6 +1083,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; @@ -955,8 +1153,10 @@ make_uninit_string (length) 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; @@ -969,8 +1169,10 @@ make_uninit_string (length) 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; @@ -982,6 +1184,7 @@ make_uninit_string (length) (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); @@ -1159,6 +1362,8 @@ Does not copy symbols.") register int i, size; size = XVECTOR (obj)->size; + if (size & PSEUDOVECTOR_FLAG) + size &= PSEUDOVECTOR_SIZE_MASK; vec = XVECTOR (make_pure_vector (size)); for (i = 0; i < size; i++) vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); @@ -1178,7 +1383,7 @@ Does not copy symbols.") struct gcpro *gcprolist; -#define NSTATICS 512 +#define NSTATICS 768 Lisp_Object *staticvec[NSTATICS] = {0}; @@ -1221,6 +1426,22 @@ 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\ @@ -1242,6 +1463,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)) @@ -1352,6 +1577,7 @@ Garbage collection happens automatically if you cons more than\n\ XMARK (backlist->args[i]); } } + mark_kboards (); gc_sweep (); @@ -1445,7 +1671,7 @@ clear_marks () { 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; } @@ -1478,9 +1704,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: @@ -1496,11 +1723,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: { @@ -1578,6 +1801,8 @@ mark_object (objptr) 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); @@ -1590,6 +1815,8 @@ mark_object (objptr) mark_object (&ptr->buffer_predicate); } #endif /* MULTI_FRAME */ + else if (GC_BOOL_VECTOR_P (obj)) + ; else { register struct Lisp_Vector *ptr = XVECTOR (obj); @@ -1640,7 +1867,7 @@ mark_object (objptr) break; case Lisp_Misc: - switch (XMISC (obj)->type) + switch (XMISCTYPE (obj)) { case Lisp_Misc_Marker: XMARK (XMARKER (obj)->chain); @@ -1672,6 +1899,7 @@ mark_object (objptr) 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 @@ -1774,6 +2002,27 @@ mark_buffer (buf) 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. */ @@ -1910,7 +2159,7 @@ 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; @@ -1922,10 +2171,12 @@ gc_sweep () for (mblk = marker_block; mblk; mblk = mblk->next) { register int i; + EMACS_INT already_free = -1; + for (i = 0; i < lim; i++) { Lisp_Object *markword; - switch (mblk->markers[i].type) + switch (mblk->markers[i].u_marker.type) { case Lisp_Misc_Marker: markword = &mblk->markers[i].u_marker.chain; @@ -1937,6 +2188,11 @@ gc_sweep () 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; @@ -1944,16 +2200,17 @@ gc_sweep () if (markword && !XMARKBIT (*markword)) { Lisp_Object tem; - if (mblk->markers[i].type == Lisp_Misc_Marker) + 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); } - /* We could leave the type alone, since nobody checks it, + /* 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].type = Lisp_Misc_Free; + 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++; @@ -2031,7 +2288,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; } } @@ -2218,6 +2478,53 @@ We divide the value by 1024 to make sure it fits in a Lisp integer.") 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 */ @@ -2239,11 +2546,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 */ @@ -2299,19 +2614,28 @@ which includes both saved text and other data."); /* 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); }