X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/71cf5fa051283be4de2aea9eb078493add766e1e..8030369ccb5c871d3ce11b96c220f318bc741ed8:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 4ea7470fe8..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); @@ -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; @@ -3585,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 "\ @@ -3597,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\ " @@ -3734,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; @@ -3769,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 (); @@ -3842,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)); } @@ -3952,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)) { @@ -4025,7 +4028,7 @@ struct backtrace int inhibit_garbage_collection () { - int count = specpdl_ptr - specpdl; + int count = SPECPDL_INDEX (); int nbits = min (VALBITS, BITS_PER_INT); specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1)); @@ -4053,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. */ @@ -4424,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; @@ -4434,6 +4443,7 @@ mark_object (argptr) void *po; struct mem_node *m; #endif + int cdr_count = 0; loop: obj = *objptr; @@ -4644,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); @@ -4691,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 @@ -4783,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; } @@ -4893,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); } } @@ -5163,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) { @@ -5178,7 +5197,7 @@ gc_sweep () { ++num_used; if (!pure_p) - UNMARK_STRING (sym->name); + UNMARK_STRING (XSTRING (sym->xname)); XUNMARK (sym->plist); } } @@ -5541,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");