X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/aba6deb8cd8dd014080497bebaa7e2d444350119..0457b5e41d5ecaf6eb84d1dbf4271afb8479bfe8:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 2f0cfd7023..fa5a3461fd 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -1,5 +1,6 @@ /* Storage allocation and gc for GNU Emacs Lisp interpreter. - Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc. + Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 1998 + Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -37,6 +38,10 @@ Boston, MA 02111-1307, USA. */ extern char *sbrk (); +#ifdef DOUG_LEA_MALLOC +#include +#define __malloc_size_t int +#else /* The following come from gmalloc.c. */ #if defined (__STDC__) && __STDC__ @@ -47,6 +52,9 @@ extern char *sbrk (); #endif extern __malloc_size_t _bytes_used; extern int __malloc_extra_blocks; +#endif /* !defined(DOUG_LEA_MALLOC) */ + +extern Lisp_Object Vhistory_length; #define max(A,B) ((A) > (B) ? (A) : (B)) #define min(A,B) ((A) < (B) ? (A) : (B)) @@ -88,6 +96,9 @@ 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 */ @@ -102,6 +113,12 @@ extern int undo_limit; int undo_strong_limit; +int total_conses, total_markers, total_symbols, total_string_size, total_vector_size; +int total_free_conses, total_free_markers, total_free_symbols; +#ifdef LISP_FLOAT_TYPE +int total_free_floats, total_floats; +#endif /* LISP_FLOAT_TYPE */ + /* Points to memory space allocated as "spare", to be freed if we run out of memory. */ static char *spare_memory; @@ -173,6 +190,8 @@ Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots; static void mark_object (), mark_buffer (), mark_kboards (); static void clear_marks (), gc_sweep (); static void compact_strings (); + +extern int message_enable_multibyte; /* Versions of malloc and realloc that print warnings as memory gets full. */ @@ -188,12 +207,15 @@ malloc_warning_1 (str) } /* malloc calls this if it finds we are near exhausting storage */ + +void malloc_warning (str) char *str; { pending_malloc_warning = str; } +void display_malloc_warning () { register Lisp_Object val; @@ -203,12 +225,19 @@ display_malloc_warning () internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val); } +#ifdef DOUG_LEA_MALLOC +# define BYTES_USED (mallinfo ().arena) +#else +# define BYTES_USED _bytes_used +#endif + /* Called if malloc returns zero */ +void memory_full () { #ifndef SYSTEM_MALLOC - bytes_used_when_full = _bytes_used; + bytes_used_when_full = BYTES_USED; #endif /* The first time we get here, free the spare memory. */ @@ -221,7 +250,7 @@ memory_full () /* This used to call error, but if we've run out of memory, we could get infinite recursion trying to build the string. */ while (1) - Fsignal (Qerror, memory_signal_data); + Fsignal (Qnil, memory_signal_data); } /* Called if we can't allocate relocatable space for a buffer. */ @@ -328,7 +357,7 @@ emacs_blocked_free (ptr) The code here is correct as long as SPARE_MEMORY is substantially larger than the block size malloc uses. */ && (bytes_used_when_full - > _bytes_used + max (malloc_hysteresis, 4) * SPARE_MEMORY)) + > BYTES_USED + max (malloc_hysteresis, 4) * SPARE_MEMORY)) spare_memory = (char *) malloc (SPARE_MEMORY); __free_hook = emacs_blocked_free; @@ -358,7 +387,11 @@ emacs_blocked_malloc (size) BLOCK_INPUT; __malloc_hook = old_malloc_hook; - __malloc_extra_blocks = malloc_hysteresis; +#ifdef DOUG_LEA_MALLOC + mallopt (M_TOP_PAD, malloc_hysteresis * 4096); +#else + __malloc_extra_blocks = malloc_hysteresis; +#endif value = (void *) malloc (size); __malloc_hook = emacs_blocked_malloc; UNBLOCK_INPUT; @@ -494,7 +527,7 @@ mark_interval_tree (tree) #define MARK_INTERVAL_TREE(i) \ do { \ if (!NULL_INTERVAL_P (i) \ - && ! XMARKBIT ((Lisp_Object) i->parent)) \ + && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \ mark_interval_tree (i); \ } while (0) @@ -562,7 +595,7 @@ init_float () free_float (ptr) struct Lisp_Float *ptr; { - *(struct Lisp_Float **)&ptr->type = float_free_list; + *(struct Lisp_Float **)&ptr->data = float_free_list; float_free_list = ptr; } @@ -574,8 +607,10 @@ make_float (float_value) if (float_free_list) { + /* We use the data field for chaining the free list + so that we won't use the same field that has the mark bit. */ XSETFLOAT (val, float_free_list); - float_free_list = *(struct Lisp_Float **)&float_free_list->type; + float_free_list = *(struct Lisp_Float **)&float_free_list->data; } else { @@ -639,10 +674,12 @@ init_cons () } /* Explicitly free a cons cell. */ + +void free_cons (ptr) struct Lisp_Cons *ptr; { - *(struct Lisp_Cons **)&ptr->car = cons_free_list; + *(struct Lisp_Cons **)&ptr->cdr = cons_free_list; cons_free_list = ptr; } @@ -655,8 +692,10 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, if (cons_free_list) { + /* We use the cdr for chaining the free list + so that we won't use the same field that has the mark bit. */ XSETCONS (val, cons_free_list); - cons_free_list = *(struct Lisp_Cons **)&cons_free_list->car; + cons_free_list = *(struct Lisp_Cons **)&cons_free_list->cdr; } else { @@ -679,6 +718,37 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, cons_cells_consed++; return val; } + +/* Make a list of 2, 3, 4 or 5 specified objects. */ + +Lisp_Object +list2 (arg1, arg2) + Lisp_Object arg1, arg2; +{ + return Fcons (arg1, Fcons (arg2, Qnil)); +} + +Lisp_Object +list3 (arg1, arg2, arg3) + Lisp_Object arg1, arg2, arg3; +{ + return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil))); +} + +Lisp_Object +list4 (arg1, arg2, arg3, arg4) + Lisp_Object arg1, arg2, arg3, arg4; +{ + return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil)))); +} + +Lisp_Object +list5 (arg1, arg2, arg3, arg4, arg5) + Lisp_Object arg1, arg2, arg3, arg4, arg5; +{ + return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, + Fcons (arg5, Qnil))))); +} DEFUN ("list", Flist, Slist, 0, MANY, 0, "Return a newly created list with specified arguments as elements.\n\ @@ -726,8 +796,16 @@ allocate_vectorlike (len) struct Lisp_Vector *p; allocating_for_lisp = 1; +#ifdef DOUG_LEA_MALLOC + /* Prevent mmap'ing the chunk (which is potentially very large). */ + mallopt (M_MMAP_MAX, 0); +#endif p = (struct Lisp_Vector *)xmalloc (sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object)); +#ifdef DOUG_LEA_MALLOC + /* Back to a reasonable maximum of mmap'ed areas. */ + mallopt (M_MMAP_MAX, 64); +#endif allocating_for_lisp = 0; VALIDATE_LISP_STORAGE (p, 0); consing_since_gc += (sizeof (struct Lisp_Vector) @@ -765,7 +843,7 @@ See also the function `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\ +PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\ The property's value should be an integer between 0 and 10.") (purpose, init) register Lisp_Object purpose, init; @@ -780,12 +858,29 @@ The property's value should be an integer between 0 and 10.") /* Add 2 to the size for the defalt and parent slots. */ vector = Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS + XINT (n)), init); + XCHAR_TABLE (vector)->top = Qt; XCHAR_TABLE (vector)->parent = Qnil; XCHAR_TABLE (vector)->purpose = purpose; XSETCHAR_TABLE (vector, XCHAR_TABLE (vector)); return vector; } +/* Return a newly created sub char table with default value DEFALT. + Since a sub char table does not appear as a top level Emacs Lisp + object, we don't need a Lisp interface to make it. */ + +Lisp_Object +make_sub_char_table (defalt) + Lisp_Object defalt; +{ + Lisp_Object vector + = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), Qnil); + XCHAR_TABLE (vector)->top = Qnil; + XCHAR_TABLE (vector)->defalt = defalt; + XSETCHAR_TABLE (vector, XCHAR_TABLE (vector)); + return vector; +} + 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.") @@ -821,7 +916,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); @@ -831,7 +926,7 @@ significance.") args[index] = Fpurecopy (args[index]); p->contents[index] = args[index]; } - XSETCOMPILED (val, val); + XSETCOMPILED (val, p); return val; } @@ -901,6 +996,7 @@ Its value and function definition are void, and its property list is nil.") } p = XSYMBOL (val); p->name = XSTRING (name); + p->obarray = Qnil; p->plist = Qnil; p->value = Qunbound; p->function = Qunbound; @@ -981,11 +1077,27 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, XMISCTYPE (val) = Lisp_Misc_Marker; p = XMARKER (val); p->buffer = 0; - p->bufpos = 0; + p->bytepos = 0; + p->charpos = 0; p->chain = Qnil; p->insertion_type = 0; return val; } + +/* Put MARKER back on the free list after using it temporarily. */ + +void +free_marker (marker) + Lisp_Object marker; +{ + unchain_marker (marker); + + XMISC (marker)->u_marker.type = Lisp_Misc_Free; + XMISC (marker)->u_free.chain = marker_free_list; + marker_free_list = XMISC (marker); + + total_free_markers++; +} /* Allocation of strings */ @@ -1014,7 +1126,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 @@ -1039,9 +1151,14 @@ struct string_block *large_string_blocks; /* If SIZE is the length of a string, this returns how many bytes the string occupies in a string_block (including padding). */ -#define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \ - & ~(PAD - 1)) -#define PAD (sizeof (EMACS_INT)) +#define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \ + & ~(STRING_PAD - 1)) + /* Add 1 for the null terminator, + and add STRING_PAD - 1 as part of rounding up. */ + +#define STRING_PAD (sizeof (EMACS_INT)) +/* Size of the stuff in the string not including its data. */ +#define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD) #if 0 #define STRING_FULLSIZE(SIZE) \ @@ -1084,8 +1201,8 @@ Both LENGTH and INIT must be numbers.") } DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0, - "Return a newly created bitstring of length LENGTH, with INIT as each element.\n\ -Both LENGTH and INIT must be numbers. INIT matters only in whether it is t or nil.") + "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\ +LENGTH must be a number. INIT matters only in whether it is t or nil.") (length, init) Lisp_Object length, init; { @@ -1101,7 +1218,9 @@ Both LENGTH and INIT must be numbers. INIT matters only in whether it is t or n length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value; length_in_chars = length_in_elts * sizeof (EMACS_INT); - val = Fmake_vector (make_number (length_in_elts), Qnil); + /* We must allocate one more elements than LENGTH_IN_ELTS for the + slot `size' of the struct Lisp_Bool_Vector. */ + val = Fmake_vector (make_number (length_in_elts + 1), Qnil); p = XBOOL_VECTOR (val); /* Get rid of any bits that would cause confusion. */ p->vector_size = 0; @@ -1115,8 +1234,26 @@ Both LENGTH and INIT must be numbers. INIT matters only in whether it is t or n return val; } +/* Make a string from NBYTES bytes at CONTENTS, + and compute the number of characters from the contents. */ + +Lisp_Object +make_string (contents, nbytes) + char *contents; + int nbytes; +{ + register Lisp_Object val; + int nchars = chars_in_text (contents, nbytes); + val = make_uninit_multibyte_string (nchars, nbytes); + bcopy (contents, XSTRING (val)->data, nbytes); + return val; +} + +/* Make a string from LENGTH bytes at CONTENTS, + assuming each byte is a character. */ + Lisp_Object -make_string (contents, length) +make_unibyte_string (contents, length) char *contents; int length; { @@ -1126,6 +1263,22 @@ make_string (contents, length) return val; } +/* Make a string from NCHARS characters occupying NBYTES bytes at CONTENTS. */ + +Lisp_Object +make_multibyte_string (contents, nchars, nbytes) + char *contents; + int nchars, nbytes; +{ + register Lisp_Object val; + val = make_uninit_multibyte_string (nchars, nbytes); + bcopy (contents, XSTRING (val)->data, nbytes); + return val; +} + +/* Make a string from the data at STR, + treating it as multibyte if the data warrants. */ + Lisp_Object build_string (str) char *str; @@ -1136,9 +1289,16 @@ build_string (str) Lisp_Object make_uninit_string (length) int length; +{ + return make_uninit_multibyte_string (length, length); +} + +Lisp_Object +make_uninit_multibyte_string (length, length_byte) + int length, length_byte; { register Lisp_Object val; - register int fullsize = STRING_FULLSIZE (length); + register int fullsize = STRING_FULLSIZE (length_byte); if (length < 0) abort (); @@ -1155,7 +1315,15 @@ make_uninit_string (length) { register struct string_block *new; allocating_for_lisp = 1; +#ifdef DOUG_LEA_MALLOC + /* Prevent mmap'ing the chunk (which is potentially very large). */ + mallopt (M_MMAP_MAX, 0); +#endif new = (struct string_block *) xmalloc (sizeof (struct string_block_head) + fullsize); +#ifdef DOUG_LEA_MALLOC + /* Back to a reasonable maximum of mmap'ed areas. */ + mallopt (M_MMAP_MAX, 64); +#endif allocating_for_lisp = 0; VALIDATE_LISP_STORAGE (new, 0); consing_since_gc += sizeof (struct string_block_head) + fullsize; @@ -1186,7 +1354,8 @@ make_uninit_string (length) string_chars_consed += fullsize; XSTRING (val)->size = length; - XSTRING (val)->data[length] = 0; + XSTRING (val)->size_byte = length_byte; + XSTRING (val)->data[length_byte] = 0; INITIALIZE_INTERVAL (XSTRING (val), NULL_INTERVAL); return val; @@ -1218,7 +1387,7 @@ make_event_array (nargs, args) { Lisp_Object result; - result = Fmake_string (nargs, make_number (0)); + result = Fmake_string (make_number (nargs), make_number (0)); for (i = 0; i < nargs; i++) { XSTRING (result)->data[i] = XINT (args[i]); @@ -1239,27 +1408,28 @@ make_event_array (nargs, args) then the string is not protected from gc. */ Lisp_Object -make_pure_string (data, length) +make_pure_string (data, length, length_byte) char *data; int length; + int length_byte; { register Lisp_Object new; - register int size = sizeof (EMACS_INT) + INTERVAL_PTR_SIZE + length + 1; + register int size = STRING_FULLSIZE (length_byte); if (pureptr + size > PURESIZE) error ("Pure Lisp storage exhausted"); XSETSTRING (new, PUREBEG + pureptr); XSTRING (new)->size = length; - bcopy (data, XSTRING (new)->data, length); - XSTRING (new)->data[length] = 0; + XSTRING (new)->size_byte = length_byte; + bcopy (data, XSTRING (new)->data, length_byte); + XSTRING (new)->data[length_byte] = 0; /* We must give strings in pure storage some kind of interval. So we give them a null one. */ #if defined (USE_TEXT_PROPERTIES) XSTRING (new)->intervals = NULL_INTERVAL; #endif - pureptr += (size + sizeof (EMACS_INT) - 1) - / sizeof (EMACS_INT) * sizeof (EMACS_INT); + pureptr += size; return new; } @@ -1355,7 +1525,8 @@ Does not copy symbols.") return make_pure_float (XFLOAT (obj)->data); #endif /* LISP_FLOAT_TYPE */ else if (STRINGP (obj)) - return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size); + return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size, + XSTRING (obj)->size_byte); else if (COMPILEDP (obj) || VECTORP (obj)) { register struct Lisp_Vector *vec; @@ -1364,7 +1535,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)) @@ -1405,7 +1576,9 @@ struct catchtag Lisp_Object tag; Lisp_Object val; struct catchtag *next; -/* jmp_buf jmp; /* We don't need this for GC purposes */ +#if 0 /* We don't need this for GC purposes */ + jmp_buf jmp; +#endif }; struct backtrace @@ -1420,12 +1593,6 @@ struct backtrace /* Garbage collection! */ -int total_conses, total_markers, total_symbols, total_string_size, total_vector_size; -int total_free_conses, total_free_markers, total_free_symbols; -#ifdef LISP_FLOAT_TYPE -int total_free_floats, total_floats; -#endif /* LISP_FLOAT_TYPE */ - /* Temporarily prevent garbage collection. */ int @@ -1447,7 +1614,7 @@ DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "", 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.") () @@ -1460,6 +1627,7 @@ Garbage collection happens automatically if you cons more than\n\ register Lisp_Object tem; char *omessage = echo_area_glyphs; int omessage_length = echo_area_glyphs_length; + int oldmultibyte = message_enable_multibyte; char stack_top_variable; register int i; @@ -1490,13 +1658,16 @@ 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 */ - tem = Fnthcdr (make_number (30), Vcommand_history); - if (CONSP (tem)) - XCONS (tem)->cdr = Qnil; + /* Don't keep command history around forever. */ + if (NUMBERP (Vhistory_length) && XINT (Vhistory_length) > 0) + { + tem = Fnthcdr (Vhistory_length, Vcommand_history); + if (CONSP (tem)) + XCONS (tem)->cdr = Qnil; + } /* Likewise for undo information. */ { @@ -1518,7 +1689,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. */ @@ -1599,17 +1770,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, oldmultibyte); + else + message1_nolog ("Garbage collecting...done"); + } return Fcons (Fcons (make_number (total_conses), make_number (total_free_conses)), @@ -1619,15 +1793,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 @@ -1790,7 +1970,6 @@ mark_object (argptr) 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. */ @@ -1813,10 +1992,16 @@ mark_object (argptr) mark_object (&ptr->face_alist); mark_object (&ptr->menu_bar_vector); mark_object (&ptr->buffer_predicate); + mark_object (&ptr->buffer_list); } -#endif /* MULTI_FRAME */ else if (GC_BOOL_VECTOR_P (obj)) - ; + { + register struct Lisp_Vector *ptr = XVECTOR (obj); + + if (ptr->size & ARRAY_MARK_FLAG) + break; /* Already marked */ + ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ + } else { register struct Lisp_Vector *ptr = XVECTOR (obj); @@ -1852,6 +2037,9 @@ mark_object (argptr) mark_object (&ptr->plist); XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String); mark_object (&ptr->name); + /* Note that we do not mark the obarray of the symbol. + It is safe not to do so because nothing accesses that + slot except to check whether it is nil. */ ptr = ptr->next; if (ptr) { @@ -2035,19 +2223,22 @@ gc_sweep () /* Put all unmarked conses on free list */ { register struct cons_block *cblk; + struct cons_block **cprev = &cons_block; register int lim = cons_block_index; register int num_free = 0, num_used = 0; cons_free_list = 0; - for (cblk = cons_block; cblk; cblk = cblk->next) + for (cblk = cons_block; cblk; cblk = *cprev) { register int i; + int this_free = 0; for (i = 0; i < lim; i++) if (!XMARKBIT (cblk->conses[i].car)) { num_free++; - *(struct Lisp_Cons **)&cblk->conses[i].car = cons_free_list; + this_free++; + *(struct Lisp_Cons **)&cblk->conses[i].cdr = cons_free_list; cons_free_list = &cblk->conses[i]; } else @@ -2056,6 +2247,19 @@ gc_sweep () XUNMARK (cblk->conses[i].car); } lim = CONS_BLOCK_SIZE; + /* If this block contains only free conses and we have already + seen more than two blocks worth of free conses then deallocate + this block. */ + if (this_free == CONS_BLOCK_SIZE && num_free > 2*CONS_BLOCK_SIZE) + { + num_free -= CONS_BLOCK_SIZE; + *cprev = cblk->next; + /* Unhook from the free list. */ + cons_free_list = *(struct Lisp_Cons **) &cblk->conses[0].cdr; + xfree (cblk); + } + else + cprev = &cblk->next; } total_conses = num_used; total_free_conses = num_free; @@ -2065,19 +2269,22 @@ gc_sweep () /* Put all unmarked floats on free list */ { register struct float_block *fblk; + struct float_block **fprev = &float_block; register int lim = float_block_index; register int num_free = 0, num_used = 0; float_free_list = 0; - for (fblk = float_block; fblk; fblk = fblk->next) + for (fblk = float_block; fblk; fblk = *fprev) { register int i; + int this_free = 0; for (i = 0; i < lim; i++) if (!XMARKBIT (fblk->floats[i].type)) { num_free++; - *(struct Lisp_Float **)&fblk->floats[i].type = float_free_list; + this_free++; + *(struct Lisp_Float **)&fblk->floats[i].data = float_free_list; float_free_list = &fblk->floats[i]; } else @@ -2086,6 +2293,19 @@ gc_sweep () XUNMARK (fblk->floats[i].type); } lim = FLOAT_BLOCK_SIZE; + /* If this block contains only free floats and we have already + seen more than two blocks worth of free floats then deallocate + this block. */ + if (this_free == FLOAT_BLOCK_SIZE && num_free > 2*FLOAT_BLOCK_SIZE) + { + num_free -= FLOAT_BLOCK_SIZE; + *fprev = fblk->next; + /* Unhook from the free list. */ + float_free_list = *(struct Lisp_Float **) &fblk->floats[0].data; + xfree (fblk); + } + else + fprev = &fblk->next; } total_floats = num_used; total_free_floats = num_free; @@ -2096,14 +2316,16 @@ gc_sweep () /* Put all unmarked intervals on free list */ { register struct interval_block *iblk; + struct interval_block **iprev = &interval_block; register int lim = interval_block_index; register int num_free = 0, num_used = 0; interval_free_list = 0; - for (iblk = interval_block; iblk; iblk = iblk->next) + for (iblk = interval_block; iblk; iblk = *iprev) { register int i; + int this_free = 0; for (i = 0; i < lim; i++) { @@ -2112,6 +2334,7 @@ gc_sweep () iblk->intervals[i].parent = interval_free_list; interval_free_list = &iblk->intervals[i]; num_free++; + this_free++; } else { @@ -2120,6 +2343,20 @@ gc_sweep () } } lim = INTERVAL_BLOCK_SIZE; + /* If this block contains only free intervals and we have already + seen more than two blocks worth of free intervals then + deallocate this block. */ + if (this_free == INTERVAL_BLOCK_SIZE + && num_free > 2*INTERVAL_BLOCK_SIZE) + { + num_free -= INTERVAL_BLOCK_SIZE; + *iprev = iblk->next; + /* Unhook from the free list. */ + interval_free_list = iblk->intervals[0].parent; + xfree (iblk); + } + else + iprev = &iblk->next; } total_intervals = num_used; total_free_intervals = num_free; @@ -2129,20 +2366,23 @@ gc_sweep () /* Put all unmarked symbols on free list */ { register struct symbol_block *sblk; + struct symbol_block **sprev = &symbol_block; register int lim = symbol_block_index; register int num_free = 0, num_used = 0; symbol_free_list = 0; - for (sblk = symbol_block; sblk; sblk = sblk->next) + for (sblk = symbol_block; sblk; sblk = *sprev) { register int i; + int this_free = 0; for (i = 0; i < lim; i++) if (!XMARKBIT (sblk->symbols[i].plist)) { *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list; symbol_free_list = &sblk->symbols[i]; num_free++; + this_free++; } else { @@ -2152,6 +2392,19 @@ gc_sweep () XUNMARK (sblk->symbols[i].plist); } lim = SYMBOL_BLOCK_SIZE; + /* If this block contains only free symbols and we have already + seen more than two blocks worth of free symbols then deallocate + this block. */ + if (this_free == SYMBOL_BLOCK_SIZE && num_free > 2*SYMBOL_BLOCK_SIZE) + { + num_free -= SYMBOL_BLOCK_SIZE; + *sprev = sblk->next; + /* Unhook from the free list. */ + symbol_free_list = *(struct Lisp_Symbol **)&sblk->symbols[0].value; + xfree (sblk); + } + else + sprev = &sblk->next; } total_symbols = num_used; total_free_symbols = num_free; @@ -2163,14 +2416,16 @@ gc_sweep () but only if it's a real marker. */ { register struct marker_block *mblk; + struct marker_block **mprev = &marker_block; register int lim = marker_block_index; register int num_free = 0, num_used = 0; marker_free_list = 0; - for (mblk = marker_block; mblk; mblk = mblk->next) + for (mblk = marker_block; mblk; mblk = *mprev) { register int i; + int this_free = 0; EMACS_INT already_free = -1; for (i = 0; i < lim; i++) @@ -2191,7 +2446,7 @@ gc_sweep () case Lisp_Misc_Free: /* If the object was already free, keep it on the free list. */ - markword = &already_free; + markword = (Lisp_Object *) &already_free; break; default: markword = 0; @@ -2214,6 +2469,7 @@ gc_sweep () mblk->markers[i].u_free.chain = marker_free_list; marker_free_list = &mblk->markers[i]; num_free++; + this_free++; } else { @@ -2223,6 +2479,19 @@ gc_sweep () } } lim = MARKER_BLOCK_SIZE; + /* If this block contains only free markers and we have already + seen more than two blocks worth of free markers then deallocate + this block. */ + if (this_free == MARKER_BLOCK_SIZE && num_free > 2*MARKER_BLOCK_SIZE) + { + num_free -= MARKER_BLOCK_SIZE; + *mprev = mblk->next; + /* Unhook from the free list. */ + marker_free_list = mblk->markers[0].u_free.chain; + xfree (mblk); + } + else + mprev = &mblk->next; } total_markers = num_used; @@ -2354,6 +2623,7 @@ compact_strings () register struct Lisp_String *newaddr; register EMACS_INT size = nextstr->size; + EMACS_INT size_byte = nextstr->size_byte; /* NEXTSTR is the old address of the next string. Just skip it if it isn't marked. */ @@ -2368,7 +2638,7 @@ compact_strings () size = *(EMACS_INT *)size & ~MARKBIT; } - total_string_size += size; + total_string_size += size_byte; /* If it won't fit in TO_SB, close it out, and move to the next sb. Keep doing so until @@ -2377,7 +2647,7 @@ compact_strings () since FROM_SB is large enough to contain this string. Any string blocks skipped here will be patched out and freed later. */ - while (to_pos + STRING_FULLSIZE (size) + while (to_pos + STRING_FULLSIZE (size_byte) > max (to_sb->pos, STRING_BLOCK_SIZE)) { to_sb->pos = to_pos; @@ -2387,12 +2657,11 @@ compact_strings () /* Compute new address of this string and update TO_POS for the space being used. */ newaddr = (struct Lisp_String *) &to_sb->chars[to_pos]; - to_pos += STRING_FULLSIZE (size); + to_pos += STRING_FULLSIZE (size_byte); /* Copy the string itself to the new place. */ if (nextstr != newaddr) - bcopy (nextstr, newaddr, size + 1 + sizeof (EMACS_INT) - + INTERVAL_PTR_SIZE); + bcopy (nextstr, newaddr, STRING_FULLSIZE (size_byte)); /* Go through NEXTSTR's chain of references and make each slot in the chain point to @@ -2428,7 +2697,7 @@ compact_strings () } #endif /* USE_TEXT_PROPERTIES */ } - pos += STRING_FULLSIZE (size); + pos += STRING_FULLSIZE (size_byte); } } @@ -2537,6 +2806,11 @@ init_alloc_once () #endif all_vectors = 0; ignore_warnings = 1; +#ifdef DOUG_LEA_MALLOC + mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */ + mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */ + mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */ +#endif init_strings (); init_cons (); init_symbol (); @@ -2584,6 +2858,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."); @@ -2611,6 +2906,10 @@ 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