/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988, 1992, 1993 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc.
This file is part of GNU Emacs.
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"
#include "buffer.h"
#include "window.h"
#include "frame.h"
+#include "blockinput.h"
#endif
#include "syssignal.h"
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)
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
/* 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;
+ 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. */
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;
mark_interval_tree (tree)
register INTERVAL tree;
{
- if (XMARKBIT (tree->plist))
- return;
+ /* 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) \
- { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); }
+#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 assigment to its argument, and most C compilers don't
+ 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) \
{ \
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 (!NILP (val_tail))
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;
+ XSETFASTINT (len, nargs);
if (!NILP (Vpurify_flag))
val = make_pure_vector (len);
else
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;
+ 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;
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
- || (XUINT (args[i]) & ~CHAR_META) >= 0200)
+ 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]);
int length;
{
register Lisp_Object new;
- register int size = sizeof (int) + INTERVAL_PTR_SIZE + 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);
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 (NILP (Vpurify_flag))
return obj;
&& (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. */
/* 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! */
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;
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);
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;
}
}
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
{
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;
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:
- {
- 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 ();
- mark_object (&ptr->contents[i]);
- }
- }
- break;
-
- 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 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;
- }
-
+ 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
- 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_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;
+ 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;
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;
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 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;
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;
+ /* 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:
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
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
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
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
= (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, "",
+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;
- XSET (end, Lisp_Int, (int) sbrk (0) / 1024);
+ XSETINT (end, (EMACS_INT) sbrk (0) / 1024);
return end;
}
which includes both saved text and other data.");
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 (&Svector);
HCoop / bpt / emacs.git / blobdiff