/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988, 1992 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1988, 1992, 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,
#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"
#endif
#include "syssignal.h"
#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;
/* 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 ();
\f
+/* Versions of malloc and realloc that print warnings as memory gets full. */
+
Lisp_Object
malloc_warning_1 (str)
Lisp_Object str;
return val;
}
\f
+/* 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 *) malloc (sizeof (struct interval_block));
+
+ if (!newi)
+ memory_full ();
+
+ 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 assigment 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 */
+\f
+/* 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
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 ();
-
if (marker_free_list)
{
XSET (val, Lisp_Marker, marker_free_list);
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. */
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
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;
}
}
\f
-/* 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)];
-}
-\f
/* 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;
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");
{
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);
you lose
#endif
\f
+/* 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\
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;
}
}
}
#endif
\f
-/* 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
is threaded into a chain of such slots, pointed to from
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;
&& (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
{
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;
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);
}
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:
{
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)
{
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:
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;
+ }
mark_object (&ptr->car);
objptr = &ptr->cdr;
obj = ptr->cdr;
mark_buffer (buf)
Lisp_Object buf;
{
- Lisp_Object tem;
register struct buffer *buffer = XBUFFER (buf);
register Lisp_Object *ptr;
mark_object (&buffer->name);
XMARK (buffer->name);
+ MARK_INTERVAL_TREE (buffer->intervals);
+
#if 0
mark_object (buffer->syntax_table);
mark_object (ptr);
}
\f
-/* Find all structures not marked, and free them. */
+/* Sweep: find all structures not marked, and free them. */
static void
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;
else
{
XUNMARK (buffer->name);
+ UNMARK_BALANCE_INTERVALS (buffer->intervals);
#if 0
/* Each `struct Lisp_String *' was turned into a Lisp_Object
}
}
\f
-/* 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 ()
/* 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
}
}
\f
+/* 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;
+}
+
+\f
/* Initialization */
init_alloc_once ()
#ifdef LISP_FLOAT_TYPE
init_float ();
#endif /* LISP_FLOAT_TYPE */
+ INIT_INTERVALS;
+
ignore_warnings = 0;
gcprolist = 0;
staticidx = 0;
"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);
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);
}
HCoop / bpt / emacs.git / blobdiff