X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/20d2471455526acfd5fe96681ea31f0eac88fae4..97f3b3d6e9f5524a01443f9352737013be4fc6ae:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index dcdbd65d85..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,6 +17,7 @@ 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" @@ -25,9 +26,8 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #ifndef standalone #include "buffer.h" #include "window.h" -#ifdef MULTI_FRAME #include "frame.h" -#endif /* MULTI_FRAME */ +#include "blockinput.h" #endif #include "syssignal.h" @@ -45,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) @@ -116,6 +116,8 @@ 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; @@ -149,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) @@ -157,7 +159,9 @@ xmalloc (size) { register long *val; + BLOCK_INPUT; val = (long *) malloc (size); + UNBLOCK_INPUT; if (!val && size) memory_full (); return val; @@ -170,17 +174,105 @@ 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)) @@ -224,10 +316,7 @@ make_interval () if (interval_block_index == INTERVAL_BLOCK_SIZE) { register struct interval_block *newi - = (struct interval_block *) malloc (sizeof (struct interval_block)); - - if (!newi) - memory_full (); + = (struct interval_block *) xmalloc (sizeof (struct interval_block)); VALIDATE_LISP_STORAGE (newi, sizeof *newi); newi->next = interval_block; @@ -246,8 +335,9 @@ static int total_free_intervals, total_intervals; /* Mark the pointers of one interval. */ static void -mark_interval (i) +mark_interval (i, dummy) register INTERVAL i; + Lisp_Object dummy; { if (XMARKBIT (i->plist)) abort (); @@ -262,19 +352,22 @@ mark_interval_tree (tree) if (XMARKBIT (tree->plist)) return; - traverse_intervals (tree, 1, &mark_interval); + traverse_intervals (tree, 1, 0, mark_interval, Qnil); } #define MARK_INTERVAL_TREE(i) \ { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); } -#define UNMARK_BALANCE_INTERVALS(i) \ -{ \ - if (! NULL_INTERVAL_P (i)) \ - { \ - XUNMARK ((Lisp_Object) (i->parent)); \ - i = balance_intervals (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 */ @@ -286,6 +379,8 @@ mark_interval_tree (tree) #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 @@ -344,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; @@ -419,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; @@ -490,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); @@ -609,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; @@ -672,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; @@ -822,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; @@ -836,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; @@ -857,20 +944,24 @@ make_uninit_string (length) } /* 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 @@ -879,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; @@ -980,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); @@ -1121,6 +1192,8 @@ 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 @@ -1156,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) @@ -1285,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"); @@ -1367,10 +1440,11 @@ 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 @@ -1486,7 +1560,6 @@ mark_object (objptr) { register struct frame *ptr = XFRAME (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 */ @@ -1498,9 +1571,13 @@ mark_object (objptr) 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 /* not MULTI_FRAME */ +#endif /* MULTI_FRAME */ case Lisp_Symbol: { @@ -1510,14 +1587,22 @@ mark_object (objptr) if (XMARKBIT (ptr->plist)) break; XMARK (ptr->plist); 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; } @@ -1534,6 +1619,7 @@ mark_object (objptr) 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; @@ -1546,7 +1632,11 @@ mark_object (objptr) XUNMARK (obj); goto loop; } + if (ptr == 0) + abort (); mark_object (&ptr->car); + if (ptr == 0) + abort (); objptr = &ptr->cdr; obj = ptr->cdr; goto loop; @@ -1588,7 +1678,6 @@ static void mark_buffer (buf) Lisp_Object buf; { - Lisp_Object tem; register struct buffer *buffer = XBUFFER (buf); register Lisp_Object *ptr; @@ -1626,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 () @@ -1808,7 +1897,7 @@ gc_sweep () else all_buffers = buffer->next; next = buffer->next; - free (buffer); + xfree (buffer); buffer = next; } else @@ -1849,7 +1938,7 @@ gc_sweep () else all_vectors = vector->next; next = vector->next; - free (vector); + xfree (vector); vector = next; } else @@ -1872,7 +1961,7 @@ gc_sweep () else large_string_blocks = sb->next; next = sb->next; - free (sb); + xfree (sb); sb = next; } else @@ -1885,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 () @@ -1988,7 +2076,7 @@ compact_strings () while (from_sb) { to_sb = from_sb->next; - free (from_sb); + xfree (from_sb); from_sb = to_sb; } @@ -2003,7 +2091,7 @@ 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; @@ -2015,15 +2103,12 @@ compact_strings () 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\ -If called interactively, print the result in the minibuffer.") +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)); - - if (! NILP (Finteractive_p)) - message ("Memory limit at %dk.", XINT (end)); + XSET (end, Lisp_Int, (int) sbrk (0) / 1024); return end; } @@ -2113,8 +2198,6 @@ 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);