X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/56d2031be55a6e52919f39afdca611b1efdda177..97f3b3d6e9f5524a01443f9352737013be4fc6ae:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 6cff322182..e6edea42c9 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 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,18 +17,21 @@ 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 "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" + #define max(A,B) ((A) > (B) ? (A) : (B)) /* Macro to verify that storage intended for Lisp objects is not @@ -42,7 +45,7 @@ do \ XSET (val, Lisp_Cons, (char *) address + size); \ if ((char *) XCONS (val) != (char *) address + size) \ { \ - free (address); \ + xfree (address); \ memory_full (); \ } \ } while (0) @@ -66,9 +69,9 @@ 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; @@ -108,7 +111,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; @@ -142,7 +151,7 @@ memory_full () error ("Memory exhausted"); } -/* 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) @@ -150,7 +159,9 @@ xmalloc (size) { register long *val; + BLOCK_INPUT; val = (long *) malloc (size); + UNBLOCK_INPUT; if (!val && size) memory_full (); return val; @@ -163,17 +174,213 @@ 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); - ese + 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; +{ + if (XMARKBIT (tree->plist)) + return; + + traverse_intervals (tree, 1, 0, mark_interval, Qnil); +} + +#define MARK_INTERVAL_TREE(i) \ + { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); } + +/* 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 @@ -232,8 +439,7 @@ make_float (float_value) { 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; @@ -307,8 +513,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, { 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; @@ -378,9 +583,7 @@ See also the function `vector'.") 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 (); + p = (struct Lisp_Vector *) xmalloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object)); VALIDATE_LISP_STORAGE (p, 0); XSET (vector, Lisp_Vector, p); @@ -497,8 +700,7 @@ Its value and function definition are void, and its property list is nil.") { if (symbol_block_index == SYMBOL_BLOCK_SIZE) { - struct symbol_block *new = (struct symbol_block *) 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; @@ -549,12 +751,6 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, { 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. */ - int mask = sigsetmask (-1); - sigsetmask (mask); - if (mask != 0) - abort (); if (marker_free_list) { @@ -566,8 +762,7 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, { 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; @@ -716,9 +911,8 @@ make_uninit_string (length) /* 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; @@ -730,8 +924,7 @@ make_uninit_string (length) /* 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; @@ -745,25 +938,30 @@ make_uninit_string (length) 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++) + /* 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 (XTYPE (args[i]) != Lisp_Int - || (unsigned) XINT (args[i]) >= 0400) + || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200) return Fvector (nargs, args); /* Since the loop exited, we know that all the things in it are @@ -772,60 +970,19 @@ make_array (nargs, args) Lisp_Object 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)); +/* Pure storage management. */ - p = (GLYPH *) XSTRING (val)->data; - for (i = 0; i < nargs; i++) - { - CHECK_NUMBER (args[i], i); - p[i] = XFASTINT (args[i]); - } - return val; -} - -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; @@ -837,7 +994,7 @@ make_pure_string (data, length) int length; { register Lisp_Object new; - register int size = sizeof (int) + length + 1; + register int size = sizeof (int) + INTERVAL_PTR_SIZE + length + 1; if (pureptr + size > PURESIZE) error ("Pure Lisp storage exhausted"); @@ -873,6 +1030,27 @@ 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); @@ -957,7 +1135,7 @@ Does not copy symbols.") struct gcpro *gcprolist; -#define NSTATICS 256 +#define NSTATICS 512 Lisp_Object *staticvec[NSTATICS] = {0}; @@ -1014,16 +1192,14 @@ struct backtrace 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\ @@ -1053,9 +1229,9 @@ 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) @@ -1074,15 +1250,21 @@ Garbage collection happens automatically if you cons more than\n\ tem = Fnthcdr (make_number (30), Vcommand_history); if (CONSP (tem)) XCONS (tem)->cdr = Qnil; + /* Likewise for undo information. */ { register struct buffer *nextb = all_buffers; while (nextb) { - nextb->undo_list - = truncate_undo_list (nextb->undo_list, undo_threshold, - undo_high_threshold); + /* If a buffer's undo list is Qt, that means that undo is + turned off in that buffer. Calling truncate_undo_list on + Qt tends to return NULL, which effectively turns undo back on. + 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_limit, + undo_strong_limit); nextb = nextb->next; } } @@ -1176,7 +1358,7 @@ Garbage collection happens automatically if you cons more than\n\ if (gc_cons_threshold < 10000) gc_cons_threshold = 10000; - if (omessage) + if (omessage || minibuf_level > 0) message1 (omessage); else if (!noninteractive) message1 ("Garbage collecting...done"); @@ -1258,15 +1440,20 @@ 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; @@ -1282,6 +1469,10 @@ mark_object (objptr) && (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 @@ -1292,6 +1483,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; @@ -1322,52 +1514,70 @@ mark_object (objptr) 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; + 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 */ for (i = 0; i < size; i++) /* and then mark its elements */ - mark_object (&ptr->contents[i]); + { + if (ptr != ptr1) + abort (); + mark_object (&ptr->contents[i]); + } } break; -#ifdef MULTI_SCREEN - case Lisp_Screen: + case Lisp_Compiled: + /* 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 screen *ptr = XSCREEN (obj); + register struct Lisp_Vector *ptr = XVECTOR (obj); register int size = ptr->size; + 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 */ + for (i = 0; i < size; i++) /* and then mark its elements */ + { + if (ptr != ptr1) + abort (); + if (i != COMPILED_CONSTANTS) + mark_object (&ptr->contents[i]); + } + objptr = &ptr->contents[COMPILED_CONSTANTS]; + obj = *objptr; + goto loop; + } + +#ifdef MULTI_FRAME + case Lisp_Frame: + { + register struct frame *ptr = XFRAME (obj); + register 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_screen); + mark_object (&ptr->focus_frame); mark_object (&ptr->width); mark_object (&ptr->height); 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); } 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]); - } - break; -#endif /* 0 */ +#endif /* MULTI_FRAME */ case Lisp_Symbol: { @@ -1376,15 +1586,23 @@ mark_object (objptr) 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); + if ((unsigned int) ptr <= 4) + abort (); mark_object (&ptr->function); + if ((unsigned int) ptr <= 4) + abort (); mark_object (&ptr->plist); + if ((unsigned int) ptr <= 4) + abort (); + XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String); + mark_object (&ptr->name); + if ((unsigned int) ptr <= 4) + abort (); ptr = ptr->next; if (ptr) { - ptrx = ptr; /* Use pf ptrx avoids compiler bug on Sun */ + ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */ XSETSYMBOL (obj, ptrx); goto loop; } @@ -1395,17 +1613,30 @@ mark_object (objptr) 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. */ + instead, markers are removed from the chain when freed by gc. */ break; case Lisp_Cons: case Lisp_Buffer_Local_Value: case Lisp_Some_Buffer_Local_Value: + case Lisp_Overlay: { 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; + obj = ptr->car; + XUNMARK (obj); + goto loop; + } + if (ptr == 0) + abort (); mark_object (&ptr->car); + if (ptr == 0) + abort (); objptr = &ptr->cdr; obj = ptr->cdr; goto loop; @@ -1447,7 +1678,6 @@ static void mark_buffer (buf) Lisp_Object buf; { - Lisp_Object tem; register struct buffer *buffer = XBUFFER (buf); register Lisp_Object *ptr; @@ -1455,6 +1685,8 @@ mark_buffer (buf) mark_object (&buffer->name); XMARK (buffer->name); + MARK_INTERVAL_TREE (buffer->intervals); + #if 0 mark_object (buffer->syntax_table); @@ -1483,7 +1715,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 () @@ -1551,6 +1783,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; @@ -1631,12 +1897,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 @@ -1671,7 +1938,7 @@ gc_sweep () else all_vectors = vector->next; next = vector->next; - free (vector); + xfree (vector); vector = next; } else @@ -1694,7 +1961,7 @@ gc_sweep () else large_string_blocks = sb->next; next = sb->next; - free (sb); + xfree (sb); sb = next; } else @@ -1707,8 +1974,7 @@ gc_sweep () } } -/* 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 () @@ -1772,7 +2038,8 @@ 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 (int) + + INTERVAL_PTR_SIZE); /* Go through NEXTSTR's chain of references and make each slot in the chain point to @@ -1809,7 +2076,7 @@ compact_strings () while (from_sb) { to_sb = from_sb->next; - free (from_sb); + xfree (from_sb); from_sb = to_sb; } @@ -1824,13 +2091,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, "", + "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; + + XSET (end, Lisp_Int, (int) sbrk (0) / 1024); + + return end; +} + + /* Initialization */ init_alloc_once () @@ -1849,6 +2132,8 @@ init_alloc_once () #ifdef LISP_FLOAT_TYPE init_float (); #endif /* LISP_FLOAT_TYPE */ + INIT_INTERVALS; + ignore_warnings = 0; gcprolist = 0; staticidx = 0; @@ -1891,20 +2176,20 @@ 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; defsubr (&Scons); defsubr (&Slist); @@ -1913,10 +2198,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); }