/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988 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,
along with GNU Emacs; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
+#include <signal.h>
-#include "config.h"
+#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
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)
#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 */
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. */
/* 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
/* 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;
/* 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)
{
register long *val;
+ BLOCK_INPUT;
val = (long *) malloc (size);
+ UNBLOCK_INPUT;
if (!val && size) memory_full ();
return val;
{
register long *val;
- val = (long *) realloc (block, size);
+ 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;
+}
+
\f
+/* 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
+\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 *) 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 */
+\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
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;
}
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;
}
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;
}
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;
{
register Lisp_Object len, val, val_tail;
- XFASTINT (len) = nargs;
+ XSETFASTINT (len, nargs);
val = Fmake_list (len, Qnil);
val_tail = val;
- while (!NULL (val_tail))
+ while (!NILP (val_tail))
{
XCONS (val_tail)->car = *args++;
val_tail = XCONS (val_tail)->cdr;
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)
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;
}
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++)
register int index;
register struct Lisp_Vector *p;
- XFASTINT (len) = nargs;
- if (!NULL (Vpurify_flag))
+ XSETFASTINT (len, nargs);
+ if (!NILP (Vpurify_flag))
val = make_pure_vector (len);
else
val = Fmake_vector (len, Qnil);
p = XVECTOR (val);
for (index = 0; index < nargs; index++)
{
- if (!NULL (Vpurify_flag))
+ if (!NILP (Vpurify_flag))
args[index] = Fpurecopy (args[index]);
p->contents[index] = args[index];
}
- XSETTYPE (val, Lisp_Compiled);
+ XSETCOMPILED (val, val);
return val;
}
\f
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);
return val;
}
\f
-/* 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 ()
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. */
- int mask = sigsetmask (-1);
- sigsetmask (mask);
- 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;
}
\f
struct string_block
{
struct string_block *next, *prev;
- int pos;
+ EMACS_INT pos;
char chars[STRING_BLOCK_SIZE];
};
#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
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;
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;
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;
}
}
\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 (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;
}
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);
{
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;
}
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;
(obj)
register Lisp_Object obj;
{
- register Lisp_Object new, tem;
- register int i;
-
- if (NULL (Vpurify_flag))
+ if (NILP (Vpurify_flag))
return obj;
if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
&& (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;
}
\f
/* Recording what needs to be marked for gc. */
struct gcpro *gcprolist;
-#define NSTATICS 256
+#define NSTATICS 512
Lisp_Object *staticvec[NSTATICS] = {0};
/* 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
\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\
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;
/* Save a copy of the contents of the stack, for debugging. */
#if MAX_SAVE_STACK > 0
- if (NULL (Vpurify_flag))
+ if (NILP (Vpurify_flag))
{
i = &stack_top_variable - stack_bottom;
if (i < 0) i = -i;
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);
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;
}
}
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");
{
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;
}
}
}
#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
+ 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
{
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;
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;
}
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:
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);
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
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 ()
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
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
}
#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;
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++;
}
#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;
{
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;
}
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
else
all_vectors = vector->next;
next = vector->next;
- free (vector);
+ xfree (vector);
vector = next;
}
else
/* 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;
+ }
+ }
}
}
\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 ()
= (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;
/* 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;
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);
}
while (from_sb)
{
to_sb = from_sb->next;
- free (from_sb);
+ xfree (from_sb);
from_sb = to_sb;
}
{
if (from_sb->next = to_sb->next)
from_sb->next->prev = from_sb;
- free (to_sb);
+ xfree (to_sb);
}
else
from_sb = to_sb;
}
}
\f
+/* 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;
+}
+
+\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;
+
+ /* 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);
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