X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/eae936e2c83821d12cc043cfd2c7a56cec97a258..8030369ccb5c871d3ce11b96c220f318bc741ed8:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 94ad4d59df..1d7c9044c7 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, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001 + Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -122,18 +122,18 @@ 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; -int strings_consed; +EMACS_INT cons_cells_consed; +EMACS_INT floats_consed; +EMACS_INT vector_cells_consed; +EMACS_INT symbols_consed; +EMACS_INT string_chars_consed; +EMACS_INT misc_objects_consed; +EMACS_INT intervals_consed; +EMACS_INT strings_consed; /* Number of bytes of consing since GC before another GC should be done. */ -int gc_cons_threshold; +EMACS_INT gc_cons_threshold; /* Nonzero during GC. */ @@ -155,8 +155,8 @@ int malloc_sbrk_unused; /* Two limits controlling how much undo information to keep. */ -int undo_limit; -int undo_strong_limit; +EMACS_INT undo_limit; +EMACS_INT undo_strong_limit; /* Number of live and free conses etc. */ @@ -181,6 +181,10 @@ static int malloc_hysteresis; Lisp_Object Vpurify_flag; +/* Non-nil means we are handling a memory-full error. */ + +Lisp_Object Vmemory_full; + #ifndef HAVE_SHM /* Force it into data space! */ @@ -215,7 +219,7 @@ static size_t pure_bytes_used_before_overflow; /* Index in pure at which next pure object will be allocated.. */ -int pure_bytes_used; +EMACS_INT pure_bytes_used; /* If nonzero, this is a warning delivered by malloc and not yet displayed. */ @@ -224,7 +228,7 @@ char *pending_malloc_warning; /* Pre-computed signal argument for use when memory is exhausted. */ -Lisp_Object memory_signal_data; +Lisp_Object Vmemory_signal_data; /* Maximum amount of C stack to save when a GC happens. */ @@ -396,7 +400,7 @@ struct gcpro *gcprolist; /* Addresses of staticpro'd variables. */ -#define NSTATICS 1024 +#define NSTATICS 1280 Lisp_Object *staticvec[NSTATICS] = {0}; /* Index of next unused slot in staticvec. */ @@ -469,6 +473,8 @@ display_malloc_warning () void memory_full () { + Vmemory_full = Qt; + #ifndef SYSTEM_MALLOC bytes_used_when_full = BYTES_USED; #endif @@ -483,7 +489,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 (Qnil, memory_signal_data); + Fsignal (Qnil, Vmemory_signal_data); } @@ -503,10 +509,12 @@ buffer_memory_full () memory_full (); #endif + Vmemory_full = Qt; + /* 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, Vmemory_signal_data); } @@ -567,7 +575,7 @@ xfree (block) char * xstrdup (s) - char *s; + const char *s; { size_t len = strlen (s) + 1; char *p = (char *) xmalloc (len); @@ -1020,7 +1028,7 @@ make_number (n) /* Lisp_Strings are allocated in string_block structures. When a new string_block is allocated, all the Lisp_Strings it contains are - added to a free-list stiing_free_list. When a new Lisp_String is + added to a free-list string_free_list. When a new Lisp_String is needed, it is taken from that list. During the sweep phase of GC, string_blocks that are entirely free are freed, except two which we keep. @@ -1341,7 +1349,7 @@ allocate_string () #ifdef GC_CHECK_STRING_BYTES if (!noninteractive -#ifdef macintosh +#ifdef MAC_OS8 && current_sblock #endif ) @@ -1676,8 +1684,8 @@ Both LENGTH and INIT must be numbers. */) { nbytes = XINT (length); val = make_uninit_string (nbytes); - p = XSTRING (val)->data; - end = p + XSTRING (val)->size; + p = SDATA (val); + end = p + SCHARS (val); while (p != end) *p++ = c; } @@ -1688,7 +1696,7 @@ Both LENGTH and INIT must be numbers. */) nbytes = len * XINT (length); val = make_uninit_multibyte_string (XINT (length), nbytes); - p = XSTRING (val)->data; + p = SDATA (val); end = p + nbytes; while (p != end) { @@ -1749,7 +1757,7 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */) Lisp_Object make_string (contents, nbytes) - char *contents; + const char *contents; int nbytes; { register Lisp_Object val; @@ -1770,13 +1778,13 @@ make_string (contents, nbytes) Lisp_Object make_unibyte_string (contents, length) - char *contents; + const char *contents; int length; { register Lisp_Object val; val = make_uninit_string (length); - bcopy (contents, XSTRING (val)->data, length); - SET_STRING_BYTES (XSTRING (val), -1); + bcopy (contents, SDATA (val), length); + STRING_SET_UNIBYTE (val); return val; } @@ -1786,12 +1794,12 @@ make_unibyte_string (contents, length) Lisp_Object make_multibyte_string (contents, nchars, nbytes) - char *contents; + const char *contents; int nchars, nbytes; { register Lisp_Object val; val = make_uninit_multibyte_string (nchars, nbytes); - bcopy (contents, XSTRING (val)->data, nbytes); + bcopy (contents, SDATA (val), nbytes); return val; } @@ -1806,9 +1814,9 @@ make_string_from_bytes (contents, nchars, nbytes) { register Lisp_Object val; val = make_uninit_multibyte_string (nchars, nbytes); - bcopy (contents, XSTRING (val)->data, nbytes); - if (STRING_BYTES (XSTRING (val)) == XSTRING (val)->size) - SET_STRING_BYTES (XSTRING (val), -1); + bcopy (contents, SDATA (val), nbytes); + if (SBYTES (val) == SCHARS (val)) + STRING_SET_UNIBYTE (val); return val; } @@ -1825,9 +1833,9 @@ make_specified_string (contents, nchars, nbytes, multibyte) { register Lisp_Object val; val = make_uninit_multibyte_string (nchars, nbytes); - bcopy (contents, XSTRING (val)->data, nbytes); + bcopy (contents, SDATA (val), nbytes); if (!multibyte) - SET_STRING_BYTES (XSTRING (val), -1); + STRING_SET_UNIBYTE (val); return val; } @@ -1837,7 +1845,7 @@ make_specified_string (contents, nchars, nbytes, multibyte) Lisp_Object build_string (str) - char *str; + const char *str; { return make_string (str, strlen (str)); } @@ -1852,7 +1860,7 @@ make_uninit_string (length) { Lisp_Object val; val = make_uninit_multibyte_string (length, length); - SET_STRING_BYTES (XSTRING (val), -1); + STRING_SET_UNIBYTE (val); return val; } @@ -2545,7 +2553,7 @@ Its value and function definition are void, and its property list is nil. */) } p = XSYMBOL (val); - p->name = XSTRING (name); + p->xname = name; p->plist = Qnil; p->value = Qunbound; p->function = Qunbound; @@ -2693,10 +2701,10 @@ make_event_array (nargs, args) result = Fmake_string (make_number (nargs), make_number (0)); for (i = 0; i < nargs; i++) { - XSTRING (result)->data[i] = XINT (args[i]); + SSET (result, i, XINT (args[i])); /* Move the meta bit to the right place for a string char. */ if (XINT (args[i]) & CHAR_META) - XSTRING (result)->data[i] |= 0x80; + SSET (result, i, SREF (result, i) | 0x80); } return result; @@ -2711,6 +2719,17 @@ make_event_array (nargs, args) #if GC_MARK_STACK || defined GC_MALLOC_CHECK +/* Conservative C stack marking requires a method to identify possibly + live Lisp objects given a pointer value. We do this by keeping + track of blocks of Lisp data that are allocated in a red-black tree + (see also the comment of mem_node which is the type of nodes in + that tree). Function lisp_malloc adds information for an allocated + block to the red-black tree with calls to mem_insert, and function + lisp_free removes it with mem_delete. Functions live_string_p etc + call mem_find to lookup information about a given pointer in the + tree, and use that to determine if the pointer points to a Lisp + object or not. */ + /* Initialize this part of alloc.c. */ static void @@ -3574,7 +3593,7 @@ If you are a system-programmer, or can get the help of a local wizard\n\ who is, please take a look at the function mark_stack in alloc.c, and\n\ verify that the methods used are appropriate for your system.\n\ \n\ -Please mail the result to .\n\ +Please mail the result to .\n\ " #define SETJMP_WILL_NOT_WORK "\ @@ -3586,7 +3605,7 @@ solution for your system.\n\ \n\ Please take a look at the function mark_stack in alloc.c, and\n\ try to find a way to make it work on your system.\n\ -Please mail the result to .\n\ +Please mail the result to .\n\ " @@ -3723,6 +3742,7 @@ dump_zombies () static void mark_stack () { + int i; jmp_buf j; volatile int stack_grows_down_p = (char *) &j > (char *) stack_base; void *end; @@ -3758,17 +3778,11 @@ mark_stack () /* This assumes that the stack is a contiguous region in memory. If that's not the case, something has to be done here to iterate over the stack segments. */ -#if GC_LISP_OBJECT_ALIGNMENT == 1 - mark_memory (stack_base, end); - mark_memory ((char *) stack_base + 1, end); - mark_memory ((char *) stack_base + 2, end); - mark_memory ((char *) stack_base + 3, end); -#elif GC_LISP_OBJECT_ALIGNMENT == 2 - mark_memory (stack_base, end); - mark_memory ((char *) stack_base + 2, end); -#else - mark_memory (stack_base, end); +#ifndef GC_LISP_OBJECT_ALIGNMENT +#define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object) #endif + for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT) + mark_memory ((char *) stack_base + i, end); #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS check_gcpros (); @@ -3816,8 +3830,11 @@ pure_alloc (size, type) if (pure_bytes_used + nbytes > pure_size) { - beg = purebeg = (char *) xmalloc (PURESIZE); - pure_size = PURESIZE; + /* Don't allocate a large amount here, + because it might get mmap'd and then its address + might not be usable. */ + beg = purebeg = (char *) xmalloc (10000); + pure_size = 10000; pure_bytes_used_before_overflow += pure_bytes_used; pure_bytes_used = 0; } @@ -3828,14 +3845,14 @@ pure_alloc (size, type) } -/* Signal an error if PURESIZE is too small. */ +/* Print a warning if PURESIZE is too small. */ void check_pure_size () { if (pure_bytes_used_before_overflow) - error ("Pure Lisp storage overflow (approx. %d bytes needed)", - (int) (pure_bytes_used + pure_bytes_used_before_overflow)); + message ("Pure Lisp storage overflow (approx. %d bytes needed)", + (int) (pure_bytes_used + pure_bytes_used_before_overflow)); } @@ -3938,8 +3955,8 @@ Does not copy symbols. Copies strings without text properties. */) else if (FLOATP (obj)) return make_pure_float (XFLOAT_DATA (obj)); else if (STRINGP (obj)) - return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size, - STRING_BYTES (XSTRING (obj)), + return make_pure_string (SDATA (obj), SCHARS (obj), + SBYTES (obj), STRING_MULTIBYTE (obj)); else if (COMPILEDP (obj) || VECTORP (obj)) { @@ -4011,8 +4028,10 @@ struct backtrace int inhibit_garbage_collection () { - int count = specpdl_ptr - specpdl; - specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM)); + int count = SPECPDL_INDEX (); + int nbits = min (VALBITS, BITS_PER_INT); + + specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1)); return count; } @@ -4037,7 +4056,7 @@ Garbage collection happens automatically if you cons more than register int i; int message_p; Lisp_Object total[8]; - int count = BINDING_STACK_SIZE (); + int count = SPECPDL_INDEX (); /* Can't GC if pure storage overflowed because we can't determine if something is a pure object or not. */ @@ -4096,6 +4115,24 @@ Garbage collection happens automatically if you cons more than nextb->undo_list = truncate_undo_list (nextb->undo_list, undo_limit, undo_strong_limit); + + /* Shrink buffer gaps, but skip indirect and dead buffers. */ + if (nextb->base_buffer == 0 && !NILP (nextb->name)) + { + /* If a buffer's gap size is more than 10% of the buffer + size, or larger than 2000 bytes, then shrink it + accordingly. Keep a minimum size of 20 bytes. */ + int size = min (2000, max (20, (nextb->text->z_byte / 10))); + + if (nextb->text->gap_size > size) + { + struct buffer *save_current = current_buffer; + current_buffer = nextb; + make_gap (-(nextb->text->gap_size - size)); + current_buffer = save_current; + } + } + nextb = nextb->next; } } @@ -4390,6 +4427,12 @@ mark_image_cache (f) Lisp_Object *last_marked[LAST_MARKED_SIZE]; int last_marked_index; +/* For debugging--call abort when we cdr down this many + links of a list, in mark_object. In debugging, + the call to abort will hit a breakpoint. + Normally this is zero and the check never goes off. */ +int mark_object_loop_halt; + void mark_object (argptr) Lisp_Object *argptr; @@ -4400,6 +4443,7 @@ mark_object (argptr) void *po; struct mem_node *m; #endif + int cdr_count = 0; loop: obj = *objptr; @@ -4610,6 +4654,10 @@ mark_object (argptr) h->size |= ARRAY_MARK_FLAG; /* Mark contents. */ + /* Do not mark next_free or next_weak. + Being in the next_weak chain + should not keep the hash table alive. + No need to mark `count' since it is an integer. */ mark_object (&h->test); mark_object (&h->weak); mark_object (&h->rehash_size); @@ -4657,9 +4705,9 @@ mark_object (argptr) mark_object (&ptr->function); mark_object (&ptr->plist); - if (!PURE_POINTER_P (ptr->name)) - MARK_STRING (ptr->name); - MARK_INTERVAL_TREE (ptr->name->intervals); + if (!PURE_POINTER_P (XSTRING (ptr->xname))) + MARK_STRING (XSTRING (ptr->xname)); + MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname)); /* Note that we do not mark the obarray of the symbol. It is safe not to do so because nothing accesses that @@ -4749,10 +4797,14 @@ mark_object (argptr) if (EQ (ptr->cdr, Qnil)) { objptr = &ptr->car; + cdr_count = 0; goto loop; } mark_object (&ptr->car); objptr = &ptr->cdr; + cdr_count++; + if (cdr_count == mark_object_loop_halt) + abort (); goto loop; } @@ -4859,6 +4911,7 @@ mark_kboards () mark_object (&kb->Vsystem_key_alist); mark_object (&kb->system_key_syms); mark_object (&kb->Vdefault_minibuffer_frame); + mark_object (&kb->echo_string); } } @@ -5129,7 +5182,7 @@ gc_sweep () /* Check if the symbol was created during loadup. In such a case it might be pointed to by pure bytecode which we don't trace, so we conservatively assume that it is live. */ - int pure_p = PURE_POINTER_P (sym->name); + int pure_p = PURE_POINTER_P (XSTRING (sym->xname)); if (!XMARKBIT (sym->plist) && !pure_p) { @@ -5144,7 +5197,7 @@ gc_sweep () { ++num_used; if (!pure_p) - UNMARK_STRING (sym->name); + UNMARK_STRING (XSTRING (sym->xname)); XUNMARK (sym->plist); } } @@ -5507,11 +5560,17 @@ which includes both saved text and other data. */); Qpost_gc_hook = intern ("post-gc-hook"); staticpro (&Qpost_gc_hook); + DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data, + doc: /* Precomputed `signal' argument for memory-full error. */); /* 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); + Vmemory_signal_data + = list2 (Qerror, + build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs")); + + DEFVAR_LISP ("memory-full", &Vmemory_full, + doc: /* Non-nil means we are handling a memory-full error. */); + Vmemory_full = Qnil; staticpro (&Qgc_cons_threshold); Qgc_cons_threshold = intern ("gc-cons-threshold");