/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988, 1992 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1988, 1993 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 1, or (at your option)
+the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
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 "lisp.h"
#ifndef standalone
#include "buffer.h"
#include "window.h"
-#ifdef MULTI_FRAME
#include "frame.h"
-#endif /* MULTI_FRAME */
+#include "blockinput.h"
#endif
#include "syssignal.h"
XSET (val, Lisp_Cons, (char *) address + size); \
if ((char *) XCONS (val) != (char *) address + size) \
{ \
- free (address); \
+ xfree (address); \
memory_full (); \
} \
} while (0)
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;
error ("Memory exhausted");
}
-/* like malloc and realloc but check for no memory left */
+/* like malloc routines but check for no memory and block interrupt input. */
long *
xmalloc (size)
{
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. */
+
#ifdef USE_TEXT_PROPERTIES
#define INTERVAL_BLOCK_SIZE \
((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
if (interval_block_index == INTERVAL_BLOCK_SIZE)
{
register struct interval_block *newi
- = (struct interval_block *) malloc (sizeof (struct interval_block));
-
- if (!newi)
- memory_full ();
+ = (struct interval_block *) xmalloc (sizeof (struct interval_block));
VALIDATE_LISP_STORAGE (newi, sizeof *newi);
newi->next = interval_block;
/* Mark the pointers of one interval. */
static void
-mark_interval (i)
+mark_interval (i, dummy)
register INTERVAL i;
+ Lisp_Object dummy;
{
if (XMARKBIT (i->plist))
abort ();
if (XMARKBIT (tree->plist))
return;
- traverse_intervals (tree, 1, &mark_interval);
+ traverse_intervals (tree, 1, 0, mark_interval, Qnil);
}
#define MARK_INTERVAL_TREE(i) \
{ if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); }
-#define UNMARK_BALANCE_INTERVALS(i) \
-{ \
- if (! NULL_INTERVAL_P (i)) \
- { \
- XUNMARK ((Lisp_Object) (i->parent)); \
- i = balance_intervals (i); \
- } \
+/* The oddity in the call to XUNMARK is necessary because XUNMARK
+ expands to an assignment to its argument, and most C compilers don't
+ support casts on the left operand of `='. */
+#define UNMARK_BALANCE_INTERVALS(i) \
+{ \
+ if (! NULL_INTERVAL_P (i)) \
+ { \
+ XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
+ (i) = balance_intervals (i); \
+ } \
}
#else /* no interval use */
#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
{
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;
{
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;
length = wrong_type_argument (Qnatnump, length);
sizei = XINT (length);
- p = (struct Lisp_Vector *) malloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object));
- if (p == 0)
- memory_full ();
+ p = (struct Lisp_Vector *) xmalloc (sizeof (struct Lisp_Vector) + (sizei - 1) * sizeof (Lisp_Object));
VALIDATE_LISP_STORAGE (p, 0);
XSET (vector, Lisp_Vector, p);
{
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;
{
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;
/* 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;
/* 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;
}
/* Return a newly created vector or string with specified arguments as
- elements. If all the arguments are characters, make a string;
- otherwise, make a vector. Any number of arguments, even zero
- arguments, are allowed. */
+ elements. If all the arguments are characters that can fit
+ in a string of events, make a string; otherwise, make a vector.
+
+ Any number of arguments, even zero arguments, are allowed. */
Lisp_Object
-make_array (nargs, args)
+make_event_array (nargs, args)
register int nargs;
Lisp_Object *args;
{
int i;
for (i = 0; i < nargs; i++)
+ /* The things that fit in a string
+ are characters that are in 0...127,
+ after discarding the meta bit and all the bits above it. */
if (XTYPE (args[i]) != Lisp_Int
- || (unsigned) XINT (args[i]) >= 0400)
+ || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
return Fvector (nargs, args);
/* Since the loop exited, we know that all the things in it are
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));
+/* Pure storage management. */
- p = (GLYPH *) XSTRING (val)->data;
- for (i = 0; i < nargs; i++)
- {
- CHECK_NUMBER (args[i], i);
- p[i] = XFASTINT (args[i]);
- }
- return val;
-}
-
-DEFUN ("rope-elt", Frope_elt, Srope_elt, 2, 2, 0,
- "Return an element of rope R at index N.\n\
-A rope is a string in which each pair of bytes is considered an element.\n\
-See variable `buffer-display-table' for the uses of ropes.")
- (r, n)
-{
- CHECK_STRING (r, 0);
- CHECK_NUMBER (n, 1);
- if ((XSTRING (r)->size / sizeof (GLYPH)) <= XINT (n) || XINT (n) < 0)
- args_out_of_range (r, n);
- return ((GLYPH *) XSTRING (r)->data)[XFASTINT (n)];
-}
-\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;
{
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
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 (gc_cons_threshold < 10000)
gc_cons_threshold = 10000;
- if (omessage)
+ if (omessage || minibuf_level > 0)
message1 (omessage);
else if (!noninteractive)
message1 ("Garbage collecting...done");
}
#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
{
register struct frame *ptr = XFRAME (obj);
register int size = ptr->size;
- register int i;
if (size & ARRAY_MARK_FLAG) break; /* Already marked */
ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
mark_object (&ptr->selected_window);
mark_object (&ptr->minibuffer_window);
mark_object (&ptr->param_alist);
+ mark_object (&ptr->scroll_bars);
+ mark_object (&ptr->condemned_scroll_bars);
+ mark_object (&ptr->menu_bar_items);
+ mark_object (&ptr->face_alist);
}
break;
-#endif /* not MULTI_FRAME */
+#endif /* MULTI_FRAME */
case Lisp_Symbol:
{
if (XMARKBIT (ptr->plist)) break;
XMARK (ptr->plist);
mark_object ((Lisp_Object *) &ptr->value);
+ if ((unsigned int) ptr <= 4)
+ abort ();
mark_object (&ptr->function);
+ if ((unsigned int) ptr <= 4)
+ abort ();
mark_object (&ptr->plist);
+ if ((unsigned int) ptr <= 4)
+ abort ();
XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
mark_object (&ptr->name);
+ if ((unsigned int) ptr <= 4)
+ abort ();
ptr = ptr->next;
if (ptr)
{
- ptrx = ptr; /* Use pf ptrx avoids compiler bug on Sun */
+ ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */
XSETSYMBOL (obj, ptrx);
goto loop;
}
case Lisp_Cons:
case Lisp_Buffer_Local_Value:
case Lisp_Some_Buffer_Local_Value:
+ case Lisp_Overlay:
{
register struct Lisp_Cons *ptr = XCONS (obj);
if (XMARKBIT (ptr->car)) break;
XUNMARK (obj);
goto loop;
}
+ if (ptr == 0)
+ abort ();
mark_object (&ptr->car);
+ if (ptr == 0)
+ abort ();
objptr = &ptr->cdr;
obj = ptr->cdr;
goto loop;
mark_buffer (buf)
Lisp_Object buf;
{
- Lisp_Object tem;
register struct buffer *buffer = XBUFFER (buf);
register Lisp_Object *ptr;
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 ()
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
else
large_string_blocks = sb->next;
next = sb->next;
- free (sb);
+ xfree (sb);
sb = next;
}
else
}
}
\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 ()
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;
DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, "",
"Return the address of the last byte Emacs has allocated, divided by 1024.\n\
This may be helpful in debugging Emacs's memory usage.\n\
-If called interactively, print the result in the minibuffer.")
+We divide the value by 1024 to make sure it fits in a Lisp integer.")
()
{
Lisp_Object end;
- XSET (end, Lisp_Int, (int) sbrk (0));
-
- if (! NILP (Finteractive_p))
- message ("Memory limit at %dk.", XINT (end));
+ XSET (end, Lisp_Int, (int) sbrk (0) / 1024);
return end;
}
defsubr (&Smake_list);
defsubr (&Smake_vector);
defsubr (&Smake_string);
- defsubr (&Smake_rope);
- defsubr (&Srope_elt);
defsubr (&Smake_symbol);
defsubr (&Smake_marker);
defsubr (&Spurecopy);
HCoop / bpt / emacs.git / blobdiff