X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/cc4c29808c7c90c8011f123bf8320c25de3ae1b6..26c76ace8de7d0fa687d8a76b3a3bce5fb1ee692:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 79cf8365e9..9f79ee5aa6 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -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,10 +30,13 @@ 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__ @@ -44,6 +49,7 @@ 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. @@ -67,12 +73,24 @@ 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 */ @@ -97,6 +115,9 @@ static char *spare_memory; /* 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; @@ -134,7 +155,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. */ @@ -142,10 +163,6 @@ Lisp_Object memory_signal_data; #define DONT_COPY_FLAG 1 #endif /* no DONT_COPY_FLAG */ -#if DONT_COPY_FLAG == MARKBIT -you lose -#endif - /* Buffer in which we save a copy of the C stack at each GC. */ char *stack_copy; @@ -154,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 (), mark_perdisplays (); +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 (); @@ -400,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; } @@ -424,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; @@ -435,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; } @@ -527,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; } @@ -557,7 +584,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; @@ -568,6 +599,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; } @@ -600,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; } @@ -631,7 +665,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; @@ -642,6 +679,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; } @@ -652,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; - 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; } @@ -692,11 +728,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; @@ -726,6 +765,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.") @@ -761,7 +824,7 @@ significance.") 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); @@ -799,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; } @@ -809,13 +874,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) { @@ -826,7 +891,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; @@ -835,12 +903,14 @@ 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->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; } @@ -864,9 +934,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; } @@ -886,8 +958,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; @@ -896,6 +970,7 @@ allocate_misc () XSETMISC (val, &marker_block->markers[marker_block_index++]); } consing_since_gc += sizeof (union Lisp_Misc); + misc_objects_consed++; return val; } @@ -907,11 +982,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; } @@ -942,7 +1018,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 @@ -979,7 +1055,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; @@ -1009,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; @@ -1047,8 +1157,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; @@ -1061,8 +1173,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; @@ -1074,6 +1188,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); @@ -1253,7 +1368,7 @@ Does not copy symbols.") size = XVECTOR (obj)->size; if (size & PSEUDOVECTOR_FLAG) size &= PSEUDOVECTOR_SIZE_MASK; - vec = XVECTOR (make_pure_vector (size)); + vec = XVECTOR (make_pure_vector ((EMACS_INT) size)); for (i = 0; i < size; i++) vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); if (COMPILEDP (obj)) @@ -1272,7 +1387,7 @@ Does not copy symbols.") struct gcpro *gcprolist; -#define NSTATICS 512 +#define NSTATICS 768 Lisp_Object *staticvec[NSTATICS] = {0}; @@ -1315,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.") () @@ -1336,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)) @@ -1359,7 +1494,7 @@ Garbage collection happens automatically if you cons more than\n\ } #endif /* MAX_SAVE_STACK > 0 */ - if (!noninteractive) + if (garbage_collection_messages) message1_nolog ("Garbage collecting..."); /* Don't keep command history around forever */ @@ -1387,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. */ @@ -1446,7 +1581,7 @@ Garbage collection happens automatically if you cons more than\n\ XMARK (backlist->args[i]); } } - mark_perdisplays (); + mark_kboards (); gc_sweep (); @@ -1468,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_nolog (omessage, omessage_length); - else if (!noninteractive) - message1_nolog ("Garbage collecting...done"); + if (garbage_collection_messages) + { + if (omessage || minibuf_level > 0) + message2_nolog (omessage, omessage_length); + else + message1_nolog ("Garbage collecting...done"); + } return Fcons (Fcons (make_number (total_conses), make_number (total_free_conses)), @@ -1488,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 @@ -1540,7 +1684,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; } @@ -1573,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: @@ -1658,7 +1803,6 @@ mark_object (objptr) objptr = (Lisp_Object *) &ptr1->contents[COMPILED_CONSTANTS]; goto loop; } -#ifdef MULTI_FRAME else if (GC_FRAMEP (obj)) { /* See comment above under Lisp_Vector for why this is volatile. */ @@ -1669,6 +1813,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); @@ -1680,7 +1826,14 @@ mark_object (objptr) mark_object (&ptr->menu_bar_vector); mark_object (&ptr->buffer_predicate); } -#endif /* MULTI_FRAME */ + else if (GC_BOOL_VECTOR_P (obj)) + { + register struct Lisp_Vector *ptr = XVECTOR (obj); + + if (ptr->size & ARRAY_MARK_FLAG) + break; /* Already marked */ + ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ + } else { register struct Lisp_Vector *ptr = XVECTOR (obj); @@ -1731,7 +1884,7 @@ mark_object (objptr) break; case Lisp_Misc: - switch (XMISC (obj)->type) + switch (XMISCTYPE (obj)) { case Lisp_Misc_Marker: XMARK (XMARKER (obj)->chain); @@ -1763,7 +1916,7 @@ mark_object (objptr) case Lisp_Misc_Boolfwd: case Lisp_Misc_Objfwd: case Lisp_Misc_Buffer_Objfwd: - case Lisp_Misc_Display_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 @@ -1868,17 +2021,23 @@ mark_buffer (buf) } -/* Mark the pointers in the perdisplay objects. */ +/* Mark the pointers in the kboard objects. */ static void -mark_perdisplays () +mark_kboards () { - PERDISPLAY *perd; - for (perd = all_perdisplays; perd; perd = perd->next_perdisplay) + KBOARD *kb; + Lisp_Object *p; + for (kb = all_kboards; kb; kb = kb->next_kboard) { - mark_object (&perd->Vprefix_arg); - mark_object (&perd->Vcurrent_prefix_arg); - mark_object (&perd->kbd_queue); + 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); } } @@ -2017,7 +2176,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; @@ -2029,10 +2188,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; @@ -2044,6 +2205,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; @@ -2051,16 +2217,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++; @@ -2138,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; } } @@ -2325,6 +2495,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 */ @@ -2358,7 +2575,7 @@ init_alloc_once () 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 */ @@ -2384,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."); @@ -2411,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--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); }