X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/daa3760289bd389e8c174c8d24b375cd875cd911..95385625ed590b286be55ea3b47790e2cd25e993:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index c0d92e3380..1d55fc50d0 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -1,11 +1,11 @@ /* Storage allocation and gc for GNU Emacs Lisp interpreter. - Copyright (C) 1985, 1986, 1988, 1992 Free Software Foundation, Inc. + Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc. This file is part of GNU Emacs. GNU Emacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 1, or (at your option) +the Free Software Foundation; either version 2, or (at your option) any later version. GNU Emacs is distributed in the hope that it will be useful, @@ -17,16 +17,17 @@ 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. */ +#include -#include "config.h" +#include #include "lisp.h" +#include "intervals.h" #include "puresize.h" #ifndef standalone #include "buffer.h" #include "window.h" -#ifdef MULTI_SCREEN -#include "screen.h" -#endif /* MULTI_SCREEN */ +#include "frame.h" +#include "blockinput.h" #endif #include "syssignal.h" @@ -41,10 +42,10 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ do \ { \ Lisp_Object val; \ - XSET (val, Lisp_Cons, (char *) address + size); \ + XSETCONS (val, (char *) address + size); \ if ((char *) XCONS (val) != (char *) address + size) \ { \ - free (address); \ + xfree (address); \ memory_full (); \ } \ } while (0) @@ -68,15 +69,15 @@ extern #endif /* VIRT_ADDR_VARIES */ int malloc_sbrk_unused; -/* Two thresholds controlling how much undo information to keep. */ -int undo_threshold; -int undo_high_threshold; +/* Two limits controlling how much undo information to keep. */ +int undo_limit; +int undo_strong_limit; /* Non-nil means defun should do purecopy on the function definition */ Lisp_Object Vpurify_flag; #ifndef HAVE_SHM -int pure[PURESIZE / sizeof (int)] = {0,}; /* Force it into data space! */ +EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {0,}; /* Force it into data space! */ #define PUREBEG (char *) pure #else #define pure PURE_SEG_BITS /* Use shared memory segment */ @@ -88,7 +89,7 @@ int pure[PURESIZE / sizeof (int)] = {0,}; /* Force it into data space! */ you should be able to change that without too much recompilation. So map_in_data initializes pure_size, and the dependencies work out. */ -int pure_size; +EMACS_INT pure_size; #endif /* not HAVE_SHM */ /* Index in pure at which next pure object will be allocated. */ @@ -97,6 +98,9 @@ int pureptr; /* If nonzero, this is a warning delivered by malloc and not yet displayed. */ char *pending_malloc_warning; +/* Pre-computed signal argument for use when memory is exhausted. */ +Lisp_Object memory_signal_data; + /* Maximum amount of C stack to save when a GC happens. */ #ifndef MAX_SAVE_STACK @@ -110,7 +114,13 @@ int stack_copy_size; /* Non-zero means ignore malloc warnings. Set during initialization. */ int ignore_warnings; + +static void mark_object (), mark_buffer (); +static void clear_marks (), gc_sweep (); +static void compact_strings (); +/* Versions of malloc and realloc that print warnings as memory gets full. */ + Lisp_Object malloc_warning_1 (str) Lisp_Object str; @@ -141,10 +151,13 @@ display_malloc_warning () /* Called if malloc returns zero */ memory_full () { - error ("Memory exhausted"); + /* 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); } -/* like malloc and realloc but check for no memory left */ +/* like malloc routines but check for no memory and block interrupt input. */ long * xmalloc (size) @@ -152,7 +165,9 @@ xmalloc (size) { register long *val; + BLOCK_INPUT; val = (long *) malloc (size); + UNBLOCK_INPUT; if (!val && size) memory_full (); return val; @@ -165,17 +180,222 @@ xrealloc (block, size) { register long *val; + BLOCK_INPUT; /* We must call malloc explicitly when BLOCK is 0, since some reallocs don't do this. */ if (! block) val = (long *) malloc (size); else val = (long *) realloc (block, size); + UNBLOCK_INPUT; if (!val && size) memory_full (); return val; } + +void +xfree (block) + long *block; +{ + BLOCK_INPUT; + free (block); + UNBLOCK_INPUT; +} + + +/* Arranging to disable input signals while we're in malloc. + + This only works with GNU malloc. To help out systems which can't + use GNU malloc, all the calls to malloc, realloc, and free + elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT + pairs; unfortunately, we have no idea what C library functions + might call malloc, so we can't really protect them unless you're + using GNU malloc. Fortunately, most of the major operating can use + GNU malloc. */ + +#ifndef SYSTEM_MALLOC +extern void * (*__malloc_hook) (); +static void * (*old_malloc_hook) (); +extern void * (*__realloc_hook) (); +static void * (*old_realloc_hook) (); +extern void (*__free_hook) (); +static void (*old_free_hook) (); + +static void +emacs_blocked_free (ptr) + void *ptr; +{ + BLOCK_INPUT; + __free_hook = old_free_hook; + free (ptr); + __free_hook = emacs_blocked_free; + UNBLOCK_INPUT; +} + +static void * +emacs_blocked_malloc (size) + unsigned size; +{ + void *value; + + BLOCK_INPUT; + __malloc_hook = old_malloc_hook; + value = (void *) malloc (size); + __malloc_hook = emacs_blocked_malloc; + UNBLOCK_INPUT; + + return value; +} + +static void * +emacs_blocked_realloc (ptr, size) + void *ptr; + unsigned size; +{ + void *value; + + BLOCK_INPUT; + __realloc_hook = old_realloc_hook; + value = (void *) realloc (ptr, size); + __realloc_hook = emacs_blocked_realloc; + UNBLOCK_INPUT; + + return value; +} + +void +uninterrupt_malloc () +{ + old_free_hook = __free_hook; + __free_hook = emacs_blocked_free; + + old_malloc_hook = __malloc_hook; + __malloc_hook = emacs_blocked_malloc; + + old_realloc_hook = __realloc_hook; + __realloc_hook = emacs_blocked_realloc; +} +#endif + +/* Interval allocation. */ + +#ifdef USE_TEXT_PROPERTIES +#define INTERVAL_BLOCK_SIZE \ + ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval)) + +struct interval_block + { + struct interval_block *next; + struct interval intervals[INTERVAL_BLOCK_SIZE]; + }; + +struct interval_block *interval_block; +static int interval_block_index; + +INTERVAL interval_free_list; + +static void +init_intervals () +{ + interval_block + = (struct interval_block *) malloc (sizeof (struct interval_block)); + interval_block->next = 0; + bzero (interval_block->intervals, sizeof interval_block->intervals); + interval_block_index = 0; + interval_free_list = 0; +} + +#define INIT_INTERVALS init_intervals () + +INTERVAL +make_interval () +{ + INTERVAL val; + + if (interval_free_list) + { + val = interval_free_list; + interval_free_list = interval_free_list->parent; + } + else + { + if (interval_block_index == INTERVAL_BLOCK_SIZE) + { + register struct interval_block *newi + = (struct interval_block *) xmalloc (sizeof (struct interval_block)); + + VALIDATE_LISP_STORAGE (newi, sizeof *newi); + newi->next = interval_block; + interval_block = newi; + interval_block_index = 0; + } + val = &interval_block->intervals[interval_block_index++]; + } + consing_since_gc += sizeof (struct interval); + RESET_INTERVAL (val); + return val; +} + +static int total_free_intervals, total_intervals; + +/* Mark the pointers of one interval. */ + +static void +mark_interval (i, dummy) + register INTERVAL i; + Lisp_Object dummy; +{ + if (XMARKBIT (i->plist)) + abort (); + mark_object (&i->plist); + XMARK (i->plist); +} + +static void +mark_interval_tree (tree) + register INTERVAL tree; +{ + /* No need to test if this tree has been marked already; this + function is always called through the MARK_INTERVAL_TREE macro, + which takes care of that. */ + + /* XMARK expands to an assignment; the LHS of an assignment can't be + a cast. */ + XMARK (* (Lisp_Object *) &tree->parent); + + traverse_intervals (tree, 1, 0, mark_interval, Qnil); +} + +#define MARK_INTERVAL_TREE(i) \ + do { \ + if (!NULL_INTERVAL_P (i) \ + && ! XMARKBIT ((Lisp_Object) i->parent)) \ + mark_interval_tree (i); \ + } while (0) + +/* The oddity in the call to XUNMARK is necessary because XUNMARK + expands to an assignment to its argument, and most C compilers don't + support casts on the left operand of `='. */ +#define UNMARK_BALANCE_INTERVALS(i) \ +{ \ + if (! NULL_INTERVAL_P (i)) \ + { \ + XUNMARK (* (Lisp_Object *) (&(i)->parent)); \ + (i) = balance_intervals (i); \ + } \ +} + +#else /* no interval use */ + +#define INIT_INTERVALS + +#define UNMARK_BALANCE_INTERVALS(i) +#define MARK_INTERVAL_TREE(i) + +#endif /* no interval use */ +/* Floating point allocation. */ + #ifdef LISP_FLOAT_TYPE /* Allocation of float cells, just like conses */ /* We store float cells inside of float_blocks, allocating a new @@ -215,7 +435,7 @@ init_float () free_float (ptr) struct Lisp_Float *ptr; { - XFASTINT (ptr->type) = (int) float_free_list; + *(struct Lisp_Float **)&ptr->type = float_free_list; float_free_list = ptr; } @@ -227,24 +447,23 @@ make_float (float_value) if (float_free_list) { - XSET (val, Lisp_Float, float_free_list); - float_free_list = (struct Lisp_Float *) XFASTINT (float_free_list->type); + XSETFLOAT (val, float_free_list); + float_free_list = *(struct Lisp_Float **)&float_free_list->type; } else { if (float_block_index == FLOAT_BLOCK_SIZE) { - register struct float_block *new = (struct float_block *) malloc (sizeof (struct float_block)); - if (!new) memory_full (); + register struct float_block *new = (struct float_block *) xmalloc (sizeof (struct float_block)); VALIDATE_LISP_STORAGE (new, sizeof *new); new->next = float_block; float_block = new; float_block_index = 0; } - XSET (val, Lisp_Float, &float_block->floats[float_block_index++]); + XSETFLOAT (val, &float_block->floats[float_block_index++]); } XFLOAT (val)->data = float_value; - XFLOAT (val)->type = 0; /* bug chasing -wsr */ + XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */ consing_since_gc += sizeof (struct Lisp_Float); return val; } @@ -289,7 +508,7 @@ init_cons () free_cons (ptr) struct Lisp_Cons *ptr; { - XFASTINT (ptr->car) = (int) cons_free_list; + *(struct Lisp_Cons **)&ptr->car = cons_free_list; cons_free_list = ptr; } @@ -302,21 +521,20 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, if (cons_free_list) { - XSET (val, Lisp_Cons, cons_free_list); - cons_free_list = (struct Lisp_Cons *) XFASTINT (cons_free_list->car); + XSETCONS (val, cons_free_list); + cons_free_list = *(struct Lisp_Cons **)&cons_free_list->car; } else { if (cons_block_index == CONS_BLOCK_SIZE) { - register struct cons_block *new = (struct cons_block *) malloc (sizeof (struct cons_block)); - if (!new) memory_full (); + register struct cons_block *new = (struct cons_block *) xmalloc (sizeof (struct cons_block)); VALIDATE_LISP_STORAGE (new, sizeof *new); new->next = cons_block; cons_block = new; cons_block_index = 0; } - XSET (val, Lisp_Cons, &cons_block->conses[cons_block_index++]); + XSETCONS (val, &cons_block->conses[cons_block_index++]); } XCONS (val)->car = car; XCONS (val)->cdr = cdr; @@ -333,7 +551,7 @@ Any number of arguments, even zero arguments, are allowed.") { register Lisp_Object len, val, val_tail; - XFASTINT (len) = nargs; + XSETFASTINT (len, nargs); val = Fmake_list (len, Qnil); val_tail = val; while (!NILP (val_tail)) @@ -352,9 +570,8 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, register Lisp_Object val; register int size; - if (XTYPE (length) != Lisp_Int || XINT (length) < 0) - length = wrong_type_argument (Qnatnump, length); - size = XINT (length); + CHECK_NATNUM (length, 0); + size = XFASTINT (length); val = Qnil; while (size-- > 0) @@ -366,35 +583,43 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, struct Lisp_Vector *all_vectors; +struct Lisp_Vector * +allocate_vectorlike (len) + EMACS_INT len; +{ + struct Lisp_Vector *p; + + p = (struct Lisp_Vector *)xmalloc (sizeof (struct Lisp_Vector) + + (len - 1) * sizeof (Lisp_Object)); + VALIDATE_LISP_STORAGE (p, 0); + consing_since_gc += (sizeof (struct Lisp_Vector) + + (len - 1) * sizeof (Lisp_Object)); + + p->next = all_vectors; + all_vectors = p; + return p; +} + DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0, "Return a newly created vector of length LENGTH, with each element being INIT.\n\ See also the function `vector'.") (length, init) register Lisp_Object length, init; { - register int sizei, index; - register Lisp_Object vector; + Lisp_Object vector; + register EMACS_INT sizei; + register int index; register struct Lisp_Vector *p; - if (XTYPE (length) != Lisp_Int || XINT (length) < 0) - length = wrong_type_argument (Qnatnump, length); - sizei = XINT (length); - - p = (struct Lisp_Vector *) malloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object)); - if (p == 0) - memory_full (); - VALIDATE_LISP_STORAGE (p, 0); - - XSET (vector, Lisp_Vector, p); - consing_since_gc += sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object); + CHECK_NATNUM (length, 0); + sizei = XFASTINT (length); + p = allocate_vectorlike (sizei); p->size = sizei; - p->next = all_vectors; - all_vectors = p; - for (index = 0; index < sizei; index++) p->contents[index] = init; + XSETVECTOR (vector, p); return vector; } @@ -409,7 +634,7 @@ Any number of arguments, even zero arguments, are allowed.") register int index; register struct Lisp_Vector *p; - XFASTINT (len) = nargs; + XSETFASTINT (len, nargs); val = Fmake_vector (len, Qnil); p = XVECTOR (val); for (index = 0; index < nargs; index++) @@ -431,7 +656,7 @@ significance.") register int index; register struct Lisp_Vector *p; - XFASTINT (len) = nargs; + XSETFASTINT (len, nargs); if (!NILP (Vpurify_flag)) val = make_pure_vector (len); else @@ -443,7 +668,7 @@ significance.") args[index] = Fpurecopy (args[index]); p->contents[index] = args[index]; } - XSETTYPE (val, Lisp_Compiled); + XSETCOMPILED (val, val); return val; } @@ -491,22 +716,20 @@ Its value and function definition are void, and its property list is nil.") if (symbol_free_list) { - XSET (val, Lisp_Symbol, symbol_free_list); - symbol_free_list - = (struct Lisp_Symbol *) XFASTINT (symbol_free_list->value); + XSETSYMBOL (val, symbol_free_list); + symbol_free_list = *(struct Lisp_Symbol **)&symbol_free_list->value; } else { if (symbol_block_index == SYMBOL_BLOCK_SIZE) { - struct symbol_block *new = (struct symbol_block *) malloc (sizeof (struct symbol_block)); - if (!new) memory_full (); + struct symbol_block *new = (struct symbol_block *) xmalloc (sizeof (struct symbol_block)); VALIDATE_LISP_STORAGE (new, sizeof *new); new->next = symbol_block; symbol_block = new; symbol_block_index = 0; } - XSET (val, Lisp_Symbol, &symbol_block->symbols[symbol_block_index++]); + XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]); } p = XSYMBOL (val); p->name = XSTRING (str); @@ -518,22 +741,22 @@ Its value and function definition are void, and its property list is nil.") return val; } -/* Allocation of markers. +/* Allocation of markers and other objects that share that structure. Works like allocation of conses. */ #define MARKER_BLOCK_SIZE \ - ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker)) + ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc)) struct marker_block { struct marker_block *next; - struct Lisp_Marker markers[MARKER_BLOCK_SIZE]; + union Lisp_Misc markers[MARKER_BLOCK_SIZE]; }; struct marker_block *marker_block; int marker_block_index; -struct Lisp_Marker *marker_free_list; +union Lisp_Misc *marker_free_list; void init_marker () @@ -545,44 +768,47 @@ init_marker () marker_free_list = 0; } -DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, - "Return a newly allocated marker which does not point at any place.") - () +/* Return a newly allocated Lisp_Misc object, with no substructure. */ +Lisp_Object +allocate_misc () { - register Lisp_Object val; - register struct Lisp_Marker *p; - - /* Detact the bug that seems to have caused this to be called from - a signal handler. */ - SIGMASKTYPE mask; - mask = sigblock (SIGEMPTYMASK); - if (mask != 0) - abort (); + Lisp_Object val; if (marker_free_list) { - XSET (val, Lisp_Marker, marker_free_list); - marker_free_list - = (struct Lisp_Marker *) XFASTINT (marker_free_list->chain); + XSETMISC (val, marker_free_list); + marker_free_list = marker_free_list->u_free.chain; } else { if (marker_block_index == MARKER_BLOCK_SIZE) { - struct marker_block *new = (struct marker_block *) malloc (sizeof (struct marker_block)); - if (!new) memory_full (); + struct marker_block *new + = (struct marker_block *) xmalloc (sizeof (struct marker_block)); VALIDATE_LISP_STORAGE (new, sizeof *new); new->next = marker_block; marker_block = new; marker_block_index = 0; } - XSET (val, Lisp_Marker, &marker_block->markers[marker_block_index++]); + XSETMISC (val, &marker_block->markers[marker_block_index++]); } + consing_since_gc += sizeof (union Lisp_Misc); + return val; +} + +DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, + "Return a newly allocated marker which does not point at any place.") + () +{ + register Lisp_Object val; + register struct Lisp_Marker *p; + + val = allocate_misc (); + XMISC (val)->type = Lisp_Misc_Marker; p = XMARKER (val); p->buffer = 0; p->bufpos = 0; p->chain = Qnil; - consing_since_gc += sizeof (struct Lisp_Marker); return val; } @@ -619,7 +845,7 @@ struct string_block_head struct string_block { struct string_block *next, *prev; - int pos; + EMACS_INT pos; char chars[STRING_BLOCK_SIZE]; }; @@ -640,11 +866,11 @@ struct string_block *large_string_blocks; #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \ & ~(PAD - 1)) -#define PAD (sizeof (int)) +#define PAD (sizeof (EMACS_INT)) #if 0 #define STRING_FULLSIZE(SIZE) \ -(((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1)) +(((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1)) #endif void @@ -668,10 +894,9 @@ Both LENGTH and INIT must be numbers.") register Lisp_Object val; register unsigned char *p, *end, c; - if (XTYPE (length) != Lisp_Int || XINT (length) < 0) - length = wrong_type_argument (Qnatnump, length); + CHECK_NATNUM (length, 0); CHECK_NUMBER (init, 1); - val = make_uninit_string (XINT (length)); + val = make_uninit_string (XFASTINT (length)); c = XINT (init); p = XSTRING (val)->data; end = p + XSTRING (val)->size; @@ -711,30 +936,30 @@ make_uninit_string (length) if (fullsize <= STRING_BLOCK_SIZE - current_string_block->pos) /* This string can fit in the current string block */ { - XSET (val, Lisp_String, - (struct Lisp_String *) (current_string_block->chars + current_string_block->pos)); + XSETSTRING (val, + ((struct Lisp_String *) + (current_string_block->chars + current_string_block->pos))); current_string_block->pos += fullsize; } else if (fullsize > STRING_BLOCK_OUTSIZE) /* This string gets its own string block */ { register struct string_block *new - = (struct string_block *) malloc (sizeof (struct string_block_head) + fullsize); + = (struct string_block *) xmalloc (sizeof (struct string_block_head) + fullsize); VALIDATE_LISP_STORAGE (new, 0); - if (!new) memory_full (); consing_since_gc += sizeof (struct string_block_head) + fullsize; new->pos = fullsize; new->next = large_string_blocks; large_string_blocks = new; - XSET (val, Lisp_String, - (struct Lisp_String *) ((struct string_block_head *)new + 1)); + XSETSTRING (val, + ((struct Lisp_String *) + ((struct string_block_head *)new + 1))); } else /* Make a new current string block and start it off with this string */ { register struct string_block *new - = (struct string_block *) malloc (sizeof (struct string_block)); - if (!new) memory_full (); + = (struct string_block *) xmalloc (sizeof (struct string_block)); VALIDATE_LISP_STORAGE (new, sizeof *new); consing_since_gc += sizeof (struct string_block); current_string_block->next = new; @@ -742,93 +967,58 @@ make_uninit_string (length) new->next = 0; current_string_block = new; new->pos = fullsize; - XSET (val, Lisp_String, - (struct Lisp_String *) current_string_block->chars); + XSETSTRING (val, + (struct Lisp_String *) current_string_block->chars); } XSTRING (val)->size = length; XSTRING (val)->data[length] = 0; + INITIALIZE_INTERVAL (XSTRING (val), NULL_INTERVAL); return val; } /* Return a newly created vector or string with specified arguments as - elements. If all the arguments are characters, make a string; - otherwise, make a vector. Any number of arguments, even zero - arguments, are allowed. */ + elements. If all the arguments are characters that can fit + in a string of events, make a string; otherwise, make a vector. + + Any number of arguments, even zero arguments, are allowed. */ Lisp_Object -make_array (nargs, args) +make_event_array (nargs, args) register int nargs; Lisp_Object *args; { int i; for (i = 0; i < nargs; i++) - if (XTYPE (args[i]) != Lisp_Int - || (unsigned) XINT (args[i]) >= 0400) + /* The things that fit in a string + are characters that are in 0...127, + after discarding the meta bit and all the bits above it. */ + if (!INTEGERP (args[i]) + || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200) return Fvector (nargs, args); /* Since the loop exited, we know that all the things in it are characters, so we can make a string. */ { - Lisp_Object result = Fmake_string (nargs, make_number (0)); + Lisp_Object result; + result = Fmake_string (nargs, make_number (0)); for (i = 0; i < nargs; i++) - XSTRING (result)->data[i] = XINT (args[i]); + { + XSTRING (result)->data[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; + } return result; } } -/* Note: the user cannot manipulate ropes portably by referring - to the chars of the string, because combining two chars to make a GLYPH - depends on endianness. */ - -DEFUN ("make-rope", Fmake_rope, Smake_rope, 0, MANY, 0, - "Return a newly created rope containing the arguments of this function.\n\ -A rope is a string, except that its contents will be treated as an\n\ -array of glyphs, where a glyph is an integer type that may be larger\n\ -than a character. Emacs is normally configured to use 8-bit glyphs,\n\ -so ropes are normally no different from strings. But Emacs may be\n\ -configured to use 16-bit glyphs, to allow the use of larger fonts.\n\ -\n\ -Each argument (which must be an integer) specifies one glyph, whatever\n\ -size glyphs may be.\n\ -\n\ -See variable `buffer-display-table' for the uses of ropes.") - (nargs, args) - register int nargs; - Lisp_Object *args; -{ - register int i; - register Lisp_Object val; - register GLYPH *p; - - val = make_uninit_string (nargs * sizeof (GLYPH)); - - p = (GLYPH *) XSTRING (val)->data; - for (i = 0; i < nargs; i++) - { - CHECK_NUMBER (args[i], i); - p[i] = XFASTINT (args[i]); - } - return val; -} +/* Pure storage management. */ -DEFUN ("rope-elt", Frope_elt, Srope_elt, 2, 2, 0, - "Return an element of rope R at index N.\n\ -A rope is a string in which each pair of bytes is considered an element.\n\ -See variable `buffer-display-table' for the uses of ropes.") - (r, n) -{ - CHECK_STRING (r, 0); - CHECK_NUMBER (n, 1); - if ((XSTRING (r)->size / sizeof (GLYPH)) <= XINT (n) || XINT (n) < 0) - args_out_of_range (r, n); - return ((GLYPH *) XSTRING (r)->data)[XFASTINT (n)]; -} - /* Must get an error if pure storage is full, since if it cannot hold a large string it may be able to hold conses that point to that string; @@ -840,16 +1030,22 @@ make_pure_string (data, length) int length; { register Lisp_Object new; - register int size = sizeof (int) + length + 1; + register int size = sizeof (EMACS_INT) + INTERVAL_PTR_SIZE + length + 1; if (pureptr + size > PURESIZE) error ("Pure Lisp storage exhausted"); - XSET (new, Lisp_String, PUREBEG + pureptr); + XSETSTRING (new, PUREBEG + pureptr); XSTRING (new)->size = length; bcopy (data, XSTRING (new)->data, length); XSTRING (new)->data[length] = 0; - pureptr += (size + sizeof (int) - 1) - / sizeof (int) * sizeof (int); + + /* 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); return new; } @@ -861,7 +1057,7 @@ pure_cons (car, cdr) if (pureptr + sizeof (struct Lisp_Cons) > PURESIZE) error ("Pure Lisp storage exhausted"); - XSET (new, Lisp_Cons, PUREBEG + pureptr); + XSETCONS (new, PUREBEG + pureptr); pureptr += sizeof (struct Lisp_Cons); XCONS (new)->car = Fpurecopy (car); XCONS (new)->cdr = Fpurecopy (cdr); @@ -876,12 +1072,33 @@ make_pure_float (num) { register Lisp_Object new; + /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof + (double) boundary. Some architectures (like the sparc) require + this, and I suspect that floats are rare enough that it's no + tragedy for those that do. */ + { + int alignment; + char *p = PUREBEG + pureptr; + +#ifdef __GNUC__ +#if __GNUC__ >= 2 + alignment = __alignof (struct Lisp_Float); +#else + alignment = sizeof (struct Lisp_Float); +#endif +#else + alignment = sizeof (struct Lisp_Float); +#endif + p = (char *) (((unsigned long) p + alignment - 1) & - alignment); + pureptr = p - PUREBEG; + } + if (pureptr + sizeof (struct Lisp_Float) > PURESIZE) error ("Pure Lisp storage exhausted"); - XSET (new, Lisp_Float, PUREBEG + pureptr); + XSETFLOAT (new, PUREBEG + pureptr); pureptr += sizeof (struct Lisp_Float); XFLOAT (new)->data = num; - XFLOAT (new)->type = 0; /* bug chasing -wsr */ + XSETFASTINT (XFLOAT (new)->type, 0); /* bug chasing -wsr */ return new; } @@ -889,15 +1106,15 @@ make_pure_float (num) Lisp_Object make_pure_vector (len) - int len; + EMACS_INT len; { register Lisp_Object new; - register int size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object); + register EMACS_INT size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object); if (pureptr + size > PURESIZE) error ("Pure Lisp storage exhausted"); - XSET (new, Lisp_Vector, PUREBEG + pureptr); + XSETVECTOR (new, PUREBEG + pureptr); pureptr += size; XVECTOR (new)->size = len; return new; @@ -910,9 +1127,6 @@ Does not copy symbols.") (obj) register Lisp_Object obj; { - register Lisp_Object new, tem; - register int i; - if (NILP (Vpurify_flag)) return obj; @@ -920,40 +1134,33 @@ Does not copy symbols.") && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure) return obj; -#ifdef SWITCH_ENUM_BUG - switch ((int) XTYPE (obj)) -#else - switch (XTYPE (obj)) -#endif - { - case Lisp_Marker: - error ("Attempt to copy a marker to pure storage"); - - case Lisp_Cons: - return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr); - + if (CONSP (obj)) + return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr); #ifdef LISP_FLOAT_TYPE - case Lisp_Float: - return make_pure_float (XFLOAT (obj)->data); + else if (FLOATP (obj)) + return make_pure_float (XFLOAT (obj)->data); #endif /* LISP_FLOAT_TYPE */ - - case Lisp_String: - return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size); - - case Lisp_Compiled: - case Lisp_Vector: - new = make_pure_vector (XVECTOR (obj)->size); - for (i = 0; i < XVECTOR (obj)->size; i++) - { - tem = XVECTOR (obj)->contents[i]; - XVECTOR (new)->contents[i] = Fpurecopy (tem); - } - XSETTYPE (new, XTYPE (obj)); - return new; - - default: + else if (STRINGP (obj)) + return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size); + else if (COMPILEDP (obj) || VECTORP (obj)) + { + register struct Lisp_Vector *vec; + register int i, size; + + size = XVECTOR (obj)->size; + vec = XVECTOR (make_pure_vector (size)); + for (i = 0; i < size; i++) + vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]); + if (COMPILEDP (obj)) + XSETCOMPILED (obj, vec); + else + XSETVECTOR (obj, vec); return obj; } + else if (MARKERP (obj)) + error ("Attempt to copy a marker to pure storage"); + else + return obj; } /* Recording what needs to be marked for gc. */ @@ -994,39 +1201,15 @@ struct backtrace /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */ char evalargs; }; - -/* Two flags that are set during GC in the `size' component - of a string or vector. On some machines, these flags - are defined by the m- file to be different bits. */ - -/* On vector, means it has been marked. - On string size field or a reference to a string, - means not the last reference in the chain. */ - -#ifndef ARRAY_MARK_FLAG -#define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT) -#endif /* no ARRAY_MARK_FLAG */ - -/* Any slot that is a Lisp_Object can point to a string - and thus can be put on a string's reference-chain - and thus may need to have its ARRAY_MARK_FLAG set. - This includes the slots whose markbits are used to mark - the containing objects. */ - -#if ARRAY_MARK_FLAG == MARKBIT -you lose -#endif +/* 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 */ -static void mark_object (), mark_buffer (); -static void clear_marks (), gc_sweep (); -static void compact_strings (); - 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\ @@ -1044,6 +1227,7 @@ Garbage collection happens automatically if you cons more than\n\ register struct backtrace *backlist; register Lisp_Object tem; char *omessage = echo_area_glyphs; + int omessage_length = echo_area_glyphs_length; char stack_top_variable; register int i; @@ -1056,12 +1240,12 @@ Garbage collection happens automatically if you cons more than\n\ if (i < MAX_SAVE_STACK) { if (stack_copy == 0) - stack_copy = (char *) malloc (stack_copy_size = i); + stack_copy = (char *) xmalloc (stack_copy_size = i); else if (stack_copy_size < i) - stack_copy = (char *) realloc (stack_copy, (stack_copy_size = i)); + stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i)); if (stack_copy) { - if ((int) (&stack_top_variable - stack_bottom) > 0) + if ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0) bcopy (stack_bottom, stack_copy, i); else bcopy (&stack_top_variable, stack_copy, i); @@ -1090,8 +1274,8 @@ Garbage collection happens automatically if you cons more than\n\ So don't call truncate_undo_list if undo_list is Qt. */ if (! EQ (nextb->undo_list, Qt)) nextb->undo_list - = truncate_undo_list (nextb->undo_list, undo_threshold, - undo_high_threshold); + = truncate_undo_list (nextb->undo_list, undo_limit, + undo_strong_limit); nextb = nextb->next; } } @@ -1185,8 +1369,8 @@ Garbage collection happens automatically if you cons more than\n\ if (gc_cons_threshold < 10000) gc_cons_threshold = 10000; - if (omessage) - message1 (omessage); + if (omessage || minibuf_level > 0) + message2 (omessage, omessage_length); else if (!noninteractive) message1 ("Garbage collecting...done"); @@ -1250,7 +1434,8 @@ clear_marks () { register int i; for (i = 0; i < lim; i++) - XUNMARK (sblk->markers[i].chain); + if (sblk->markers[i].type == Lisp_Misc_Marker) + XUNMARK (sblk->markers[i].u_marker.chain); lim = MARKER_BLOCK_SIZE; } } @@ -1267,30 +1452,39 @@ clear_marks () } #endif -/* Mark reference to a Lisp_Object. If the object referred to - has not been seen yet, recursively mark all the references contained in it. +/* Mark reference to a Lisp_Object. + If the object referred to has not been seen yet, recursively mark + all the references contained in it. - If the object referenced is a short string, the referrencing slot + If the object referenced is a short string, the referencing slot is threaded into a chain of such slots, pointed to from the `size' field of the string. The actual string size lives in the last slot in the chain. We recognize the end because it is < (unsigned) STRING_BLOCK_SIZE. */ +#define LAST_MARKED_SIZE 500 +Lisp_Object *last_marked[LAST_MARKED_SIZE]; +int last_marked_index; + static void mark_object (objptr) Lisp_Object *objptr; { register Lisp_Object obj; + loop: obj = *objptr; + loop2: XUNMARK (obj); - loop: - if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE) && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure) return; + last_marked[last_marked_index++] = objptr; + if (last_marked_index == LAST_MARKED_SIZE) + last_marked_index = 0; + #ifdef SWITCH_ENUM_BUG switch ((int) XGCTYPE (obj)) #else @@ -1301,6 +1495,7 @@ mark_object (objptr) { register struct Lisp_String *ptr = XSTRING (obj); + MARK_INTERVAL_TREE (ptr->intervals); if (ptr->size & MARKBIT) /* A large string. Just set ARRAY_MARK_FLAG. */ ptr->size |= ARRAY_MARK_FLAG; @@ -1314,109 +1509,191 @@ mark_object (objptr) if (XMARKBIT (*objptr)) { - XFASTINT (*objptr) = ptr->size; + XSETFASTINT (*objptr, ptr->size); XMARK (*objptr); } else - XFASTINT (*objptr) = ptr->size; - if ((int)objptr & 1) abort (); - ptr->size = (int) objptr & ~MARKBIT; - if ((int) objptr & MARKBIT) + XSETFASTINT (*objptr, ptr->size); + if ((EMACS_INT) objptr & 1) abort (); + ptr->size = (EMACS_INT) objptr & ~MARKBIT; + if ((EMACS_INT) objptr & MARKBIT) ptr->size ++; } } break; - case Lisp_Vector: - case Lisp_Window: - case Lisp_Process: - case Lisp_Window_Configuration: - case Lisp_Compiled: - { - register struct Lisp_Vector *ptr = XVECTOR (obj); - register int size = ptr->size; - register int i; - - if (size & ARRAY_MARK_FLAG) break; /* Already marked */ - ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ - for (i = 0; i < size; i++) /* and then mark its elements */ - mark_object (&ptr->contents[i]); - } - break; - -#ifdef MULTI_SCREEN - case Lisp_Screen: - { - register struct screen *ptr = XSCREEN (obj); - register int size = ptr->size; - register int i; - - if (size & ARRAY_MARK_FLAG) break; /* Already marked */ - ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ - - mark_object (&ptr->name); - mark_object (&ptr->focus_screen); - mark_object (&ptr->width); - mark_object (&ptr->height); - mark_object (&ptr->selected_window); - mark_object (&ptr->minibuffer_window); - mark_object (&ptr->param_alist); - } - break; -#endif /* MULTI_SCREEN */ - -#if 0 - case Lisp_Temp_Vector: - { - register struct Lisp_Vector *ptr = XVECTOR (obj); - register int size = ptr->size; - register int i; - - for (i = 0; i < size; i++) /* and then mark its elements */ - mark_object (&ptr->contents[i]); - } + case Lisp_Vectorlike: + if (GC_SUBRP (obj)) + break; + else if (GC_COMPILEDP (obj)) + /* We could treat this just like a vector, but it is better + to save the COMPILED_CONSTANTS element for last and avoid recursion + there. */ + { + register struct Lisp_Vector *ptr = XVECTOR (obj); + register EMACS_INT size = ptr->size; + /* See comment above under Lisp_Vector. */ + struct Lisp_Vector *volatile ptr1 = ptr; + register int i; + + if (size & ARRAY_MARK_FLAG) + break; /* Already marked */ + ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ + size &= PSEUDOVECTOR_SIZE_MASK; + for (i = 0; i < size; i++) /* and then mark its elements */ + { + if (i != COMPILED_CONSTANTS) + mark_object (&ptr1->contents[i]); + } + /* This cast should be unnecessary, but some Mips compiler complains + (MIPS-ABI + SysVR4, DC/OSx, etc). */ + 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. */ + register struct frame *volatile ptr = XFRAME (obj); + register EMACS_INT size = ptr->size; + + if (size & ARRAY_MARK_FLAG) break; /* Already marked */ + ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ + + mark_object (&ptr->name); + mark_object (&ptr->focus_frame); + mark_object (&ptr->selected_window); + mark_object (&ptr->minibuffer_window); + mark_object (&ptr->param_alist); + mark_object (&ptr->scroll_bars); + mark_object (&ptr->condemned_scroll_bars); + mark_object (&ptr->menu_bar_items); + mark_object (&ptr->face_alist); + mark_object (&ptr->menu_bar_vector); + mark_object (&ptr->buffer_predicate); + } + else +#endif /* MULTI_FRAME */ + { + register struct Lisp_Vector *ptr = XVECTOR (obj); + register EMACS_INT size = ptr->size; + /* The reason we use ptr1 is to avoid an apparent hardware bug + that happens occasionally on the FSF's HP 300s. + The bug is that a2 gets clobbered by recursive calls to mark_object. + The clobberage seems to happen during function entry, + perhaps in the moveml instruction. + Yes, this is a crock, but we have to do it. */ + struct Lisp_Vector *volatile ptr1 = ptr; + register int i; + + if (size & ARRAY_MARK_FLAG) break; /* Already marked */ + ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ + if (size & PSEUDOVECTOR_FLAG) + size &= PSEUDOVECTOR_SIZE_MASK; + for (i = 0; i < size; i++) /* and then mark its elements */ + mark_object (&ptr1->contents[i]); + } break; -#endif /* 0 */ case Lisp_Symbol: { - register struct Lisp_Symbol *ptr = XSYMBOL (obj); + /* See comment above under Lisp_Vector for why this is volatile. */ + register struct Lisp_Symbol *volatile ptr = XSYMBOL (obj); struct Lisp_Symbol *ptrx; if (XMARKBIT (ptr->plist)) break; XMARK (ptr->plist); - XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String); - mark_object (&ptr->name); mark_object ((Lisp_Object *) &ptr->value); mark_object (&ptr->function); mark_object (&ptr->plist); + XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String); + mark_object (&ptr->name); ptr = ptr->next; if (ptr) { - ptrx = ptr; /* Use pf ptrx avoids compiler bug on Sun */ + /* For the benefit of the last_marked log. */ + objptr = (Lisp_Object *)&XSYMBOL (obj)->next; + ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */ XSETSYMBOL (obj, ptrx); - goto loop; + /* We can't goto loop here because *objptr doesn't contain an + actual Lisp_Object with valid datatype field. */ + goto loop2; } } break; - case Lisp_Marker: - XMARK (XMARKER (obj)->chain); - /* DO NOT mark thru the marker's chain. - The buffer's markers chain does not preserve markers from gc; - instead, markers are removed from the chain when they are freed by gc. */ + case Lisp_Misc: + switch (XMISC (obj)->type) + { + case Lisp_Misc_Marker: + XMARK (XMARKER (obj)->chain); + /* DO NOT mark thru the marker's chain. + The buffer's markers chain does not preserve markers from gc; + instead, markers are removed from the chain when freed by gc. */ + break; + + case Lisp_Misc_Buffer_Local_Value: + case Lisp_Misc_Some_Buffer_Local_Value: + { + register struct Lisp_Buffer_Local_Value *ptr + = XBUFFER_LOCAL_VALUE (obj); + if (XMARKBIT (ptr->car)) break; + XMARK (ptr->car); + /* If the cdr is nil, avoid recursion for the car. */ + if (EQ (ptr->cdr, Qnil)) + { + objptr = &ptr->car; + goto loop; + } + mark_object (&ptr->car); + /* See comment above under Lisp_Vector for why not use ptr here. */ + objptr = &XBUFFER_LOCAL_VALUE (obj)->cdr; + goto loop; + } + + case Lisp_Misc_Intfwd: + case Lisp_Misc_Boolfwd: + case Lisp_Misc_Objfwd: + case Lisp_Misc_Buffer_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 + are protected with staticpro. */ + break; + + case Lisp_Misc_Overlay: + { + struct Lisp_Overlay *ptr = XOVERLAY (obj); + if (!XMARKBIT (ptr->plist)) + { + XMARK (ptr->plist); + mark_object (&ptr->start); + mark_object (&ptr->end); + objptr = &ptr->plist; + goto loop; + } + } + break; + + default: + abort (); + } break; case Lisp_Cons: - case Lisp_Buffer_Local_Value: - case Lisp_Some_Buffer_Local_Value: { register struct Lisp_Cons *ptr = XCONS (obj); if (XMARKBIT (ptr->car)) break; XMARK (ptr->car); + /* If the cdr is nil, avoid recursion for the car. */ + if (EQ (ptr->cdr, Qnil)) + { + objptr = &ptr->car; + goto loop; + } mark_object (&ptr->car); - objptr = &ptr->cdr; - obj = ptr->cdr; + /* See comment above under Lisp_Vector for why not use ptr here. */ + objptr = &XCONS (obj)->cdr; goto loop; } @@ -1432,17 +1709,6 @@ mark_object (objptr) break; case Lisp_Int: - case Lisp_Void: - case Lisp_Subr: - case Lisp_Intfwd: - case Lisp_Boolfwd: - case Lisp_Objfwd: - case Lisp_Buffer_Objfwd: - case Lisp_Internal_Stream: - /* 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 - are protected with staticpro. */ break; default: @@ -1456,7 +1722,6 @@ static void mark_buffer (buf) Lisp_Object buf; { - Lisp_Object tem; register struct buffer *buffer = XBUFFER (buf); register Lisp_Object *ptr; @@ -1464,6 +1729,8 @@ mark_buffer (buf) mark_object (&buffer->name); XMARK (buffer->name); + MARK_INTERVAL_TREE (buffer->intervals); + #if 0 mark_object (buffer->syntax_table); @@ -1471,18 +1738,14 @@ mark_buffer (buf) Since the strings may be relocated, we must mark them in their actual slots. So gc_sweep must convert each slot back to an ordinary C pointer. */ - XSET (*(Lisp_Object *)&buffer->upcase_table, - Lisp_String, buffer->upcase_table); + XSETSTRING (*(Lisp_Object *)&buffer->upcase_table, buffer->upcase_table); mark_object ((Lisp_Object *)&buffer->upcase_table); - XSET (*(Lisp_Object *)&buffer->downcase_table, - Lisp_String, buffer->downcase_table); + XSETSTRING (*(Lisp_Object *)&buffer->downcase_table, buffer->downcase_table); mark_object ((Lisp_Object *)&buffer->downcase_table); - XSET (*(Lisp_Object *)&buffer->sort_table, - Lisp_String, buffer->sort_table); + XSETSTRING (*(Lisp_Object *)&buffer->sort_table, buffer->sort_table); mark_object ((Lisp_Object *)&buffer->sort_table); - XSET (*(Lisp_Object *)&buffer->folding_sort_table, - Lisp_String, buffer->folding_sort_table); + XSETSTRING (*(Lisp_Object *)&buffer->folding_sort_table, buffer->folding_sort_table); mark_object ((Lisp_Object *)&buffer->folding_sort_table); #endif @@ -1492,7 +1755,7 @@ mark_buffer (buf) mark_object (ptr); } -/* Find all structures not marked, and free them. */ +/* Sweep: find all structures not marked, and free them. */ static void gc_sweep () @@ -1514,8 +1777,8 @@ gc_sweep () for (i = 0; i < lim; i++) if (!XMARKBIT (cblk->conses[i].car)) { - XFASTINT (cblk->conses[i].car) = (int) cons_free_list; num_free++; + *(struct Lisp_Cons **)&cblk->conses[i].car = cons_free_list; cons_free_list = &cblk->conses[i]; } else @@ -1544,8 +1807,8 @@ gc_sweep () for (i = 0; i < lim; i++) if (!XMARKBIT (fblk->floats[i].type)) { - XFASTINT (fblk->floats[i].type) = (int) float_free_list; num_free++; + *(struct Lisp_Float **)&fblk->floats[i].type = float_free_list; float_free_list = &fblk->floats[i]; } else @@ -1560,6 +1823,40 @@ gc_sweep () } #endif /* LISP_FLOAT_TYPE */ +#ifdef USE_TEXT_PROPERTIES + /* Put all unmarked intervals on free list */ + { + register struct interval_block *iblk; + 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) + { + register int i; + + for (i = 0; i < lim; i++) + { + if (! XMARKBIT (iblk->intervals[i].plist)) + { + iblk->intervals[i].parent = interval_free_list; + interval_free_list = &iblk->intervals[i]; + num_free++; + } + else + { + num_used++; + XUNMARK (iblk->intervals[i].plist); + } + } + lim = INTERVAL_BLOCK_SIZE; + } + total_intervals = num_used; + total_free_intervals = num_free; + } +#endif /* USE_TEXT_PROPERTIES */ + /* Put all unmarked symbols on free list */ { register struct symbol_block *sblk; @@ -1574,7 +1871,7 @@ gc_sweep () for (i = 0; i < lim; i++) if (!XMARKBIT (sblk->symbols[i].plist)) { - XFASTINT (sblk->symbols[i].value) = (int) symbol_free_list; + *(struct Lisp_Symbol **)&sblk->symbols[i].value = symbol_free_list; symbol_free_list = &sblk->symbols[i]; num_free++; } @@ -1593,10 +1890,10 @@ gc_sweep () #ifndef standalone /* Put all unmarked markers on free list. - Dechain each one first from the buffer it points into. */ + Dechain each one first from the buffer it points into, + but only if it's a real marker. */ { register struct marker_block *mblk; - struct Lisp_Marker *tem1; register int lim = marker_block_index; register int num_free = 0, num_used = 0; @@ -1606,21 +1903,48 @@ gc_sweep () { register int i; for (i = 0; i < lim; i++) - if (!XMARKBIT (mblk->markers[i].chain)) - { - Lisp_Object tem; - tem1 = &mblk->markers[i]; /* tem1 avoids Sun compiler bug */ - XSET (tem, Lisp_Marker, tem1); - unchain_marker (tem); - XFASTINT (mblk->markers[i].chain) = (int) marker_free_list; - marker_free_list = &mblk->markers[i]; - num_free++; - } - else - { - num_used++; - XUNMARK (mblk->markers[i].chain); - } + { + Lisp_Object *markword; + switch (mblk->markers[i].type) + { + case Lisp_Misc_Marker: + markword = &mblk->markers[i].u_marker.chain; + break; + case Lisp_Misc_Buffer_Local_Value: + case Lisp_Misc_Some_Buffer_Local_Value: + markword = &mblk->markers[i].u_buffer_local_value.car; + break; + case Lisp_Misc_Overlay: + markword = &mblk->markers[i].u_overlay.plist; + break; + default: + markword = 0; + break; + } + if (markword && !XMARKBIT (*markword)) + { + Lisp_Object tem; + if (mblk->markers[i].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, + but this might catch bugs faster. */ + mblk->markers[i].type = Lisp_Misc_Free; + mblk->markers[i].u_free.chain = marker_free_list; + marker_free_list = &mblk->markers[i]; + num_free++; + } + else + { + num_used++; + if (markword) + XUNMARK (*markword); + } + } lim = MARKER_BLOCK_SIZE; } @@ -1640,12 +1964,13 @@ gc_sweep () else all_buffers = buffer->next; next = buffer->next; - free (buffer); + xfree (buffer); buffer = next; } else { XUNMARK (buffer->name); + UNMARK_BALANCE_INTERVALS (buffer->intervals); #if 0 /* Each `struct Lisp_String *' was turned into a Lisp_Object @@ -1680,7 +2005,7 @@ gc_sweep () else all_vectors = vector->next; next = vector->next; - free (vector); + xfree (vector); vector = next; } else @@ -1694,30 +2019,34 @@ gc_sweep () /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */ { register struct string_block *sb = large_string_blocks, *prev = 0, *next; + struct Lisp_String *s; while (sb) - if (!(((struct Lisp_String *)(&sb->chars[0]))->size & ARRAY_MARK_FLAG)) - { - if (prev) - prev->next = sb->next; - else - large_string_blocks = sb->next; - next = sb->next; - free (sb); - sb = next; - } - else - { - ((struct Lisp_String *)(&sb->chars[0]))->size - &= ~ARRAY_MARK_FLAG & ~MARKBIT; - total_string_size += ((struct Lisp_String *)(&sb->chars[0]))->size; - prev = sb, sb = sb->next; - } + { + s = (struct Lisp_String *) &sb->chars[0]; + if (s->size & ARRAY_MARK_FLAG) + { + ((struct Lisp_String *)(&sb->chars[0]))->size + &= ~ARRAY_MARK_FLAG & ~MARKBIT; + UNMARK_BALANCE_INTERVALS (s->intervals); + total_string_size += ((struct Lisp_String *)(&sb->chars[0]))->size; + prev = sb, sb = sb->next; + } + else + { + if (prev) + prev->next = sb->next; + else + large_string_blocks = sb->next; + next = sb->next; + xfree (sb); + sb = next; + } + } } } -/* Compactify strings, relocate references to them, and - free any string blocks that become empty. */ +/* Compactify strings, relocate references, and free empty string blocks. */ static void compact_strings () @@ -1744,18 +2073,18 @@ compact_strings () = (struct Lisp_String *) &from_sb->chars[pos]; register struct Lisp_String *newaddr; - register int size = nextstr->size; + register EMACS_INT size = nextstr->size; /* NEXTSTR is the old address of the next string. Just skip it if it isn't marked. */ - if ((unsigned) size > STRING_BLOCK_SIZE) + if ((EMACS_UINT) size > STRING_BLOCK_SIZE) { /* It is marked, so its size field is really a chain of refs. Find the end of the chain, where the actual size lives. */ - while ((unsigned) size > STRING_BLOCK_SIZE) + while ((EMACS_UINT) size > STRING_BLOCK_SIZE) { if (size & 1) size ^= MARKBIT | 1; - size = *(int *)size & ~MARKBIT; + size = *(EMACS_INT *)size & ~MARKBIT; } total_string_size += size; @@ -1781,13 +2110,14 @@ compact_strings () /* Copy the string itself to the new place. */ if (nextstr != newaddr) - bcopy (nextstr, newaddr, size + 1 + sizeof (int)); + bcopy (nextstr, newaddr, size + 1 + sizeof (EMACS_INT) + + INTERVAL_PTR_SIZE); /* Go through NEXTSTR's chain of references and make each slot in the chain point to the new address of this string. */ size = newaddr->size; - while ((unsigned) size > STRING_BLOCK_SIZE) + while ((EMACS_UINT) size > STRING_BLOCK_SIZE) { register Lisp_Object *objptr; if (size & 1) size ^= MARKBIT | 1; @@ -1796,14 +2126,25 @@ compact_strings () size = XFASTINT (*objptr) & ~MARKBIT; if (XMARKBIT (*objptr)) { - XSET (*objptr, Lisp_String, newaddr); + XSETSTRING (*objptr, newaddr); XMARK (*objptr); } else - XSET (*objptr, Lisp_String, newaddr); + XSETSTRING (*objptr, newaddr); } /* Store the actual size in the size field. */ newaddr->size = size; + +#ifdef USE_TEXT_PROPERTIES + /* Now that the string has been relocated, rebalance its + interval tree, and update the tree's parent pointer. */ + if (! NULL_INTERVAL_P (newaddr->intervals)) + { + UNMARK_BALANCE_INTERVALS (newaddr->intervals); + XSETSTRING (* (Lisp_Object *) &newaddr->intervals->parent, + newaddr); + } +#endif /* USE_TEXT_PROPERTIES */ } pos += STRING_FULLSIZE (size); } @@ -1818,7 +2159,7 @@ compact_strings () while (from_sb) { to_sb = from_sb->next; - free (from_sb); + xfree (from_sb); from_sb = to_sb; } @@ -1833,13 +2174,29 @@ compact_strings () { if (from_sb->next = to_sb->next) from_sb->next->prev = from_sb; - free (to_sb); + xfree (to_sb); } else from_sb = to_sb; } } +/* Debugging aids. */ + +DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0, + "Return the address of the last byte Emacs has allocated, divided by 1024.\n\ +This may be helpful in debugging Emacs's memory usage.\n\ +We divide the value by 1024 to make sure it fits in a Lisp integer.") + () +{ + Lisp_Object end; + + XSETINT (end, (EMACS_INT) sbrk (0) / 1024); + + return end; +} + + /* Initialization */ init_alloc_once () @@ -1858,6 +2215,8 @@ init_alloc_once () #ifdef LISP_FLOAT_TYPE init_float (); #endif /* LISP_FLOAT_TYPE */ + INIT_INTERVALS; + ignore_warnings = 0; gcprolist = 0; staticidx = 0; @@ -1900,20 +2259,26 @@ prevent garbage collection during a part of the program."); "Non-nil means loading Lisp code in order to dump an executable.\n\ This means that certain objects should be allocated in shared (pure) space."); - DEFVAR_INT ("undo-threshold", &undo_threshold, + DEFVAR_INT ("undo-limit", &undo_limit, "Keep no more undo information once it exceeds this size.\n\ -This threshold is applied when garbage collection happens.\n\ +This limit is applied when garbage collection happens.\n\ The size is counted as the number of bytes occupied,\n\ which includes both saved text and other data."); - undo_threshold = 20000; + undo_limit = 20000; - DEFVAR_INT ("undo-high-threshold", &undo_high_threshold, + DEFVAR_INT ("undo-strong-limit", &undo_strong_limit, "Don't keep more than this much size of undo information.\n\ A command which pushes past this size is itself forgotten.\n\ -This threshold is applied when garbage collection happens.\n\ +This limit is applied when garbage collection happens.\n\ The size is counted as the number of bytes occupied,\n\ which includes both saved text and other data."); - undo_high_threshold = 30000; + undo_strong_limit = 30000; + + /* 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)); + staticpro (&memory_signal_data); defsubr (&Scons); defsubr (&Slist); @@ -1922,10 +2287,9 @@ which includes both saved text and other data."); defsubr (&Smake_list); defsubr (&Smake_vector); defsubr (&Smake_string); - defsubr (&Smake_rope); - defsubr (&Srope_elt); defsubr (&Smake_symbol); defsubr (&Smake_marker); defsubr (&Spurecopy); defsubr (&Sgarbage_collect); + defsubr (&Smemory_limit); }