/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
- 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
Free Software Foundation, Inc.
This file is part of GNU Emacs.
#undef GC_MALLOC_CHECK
#endif
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#else
+#ifndef HAVE_UNISTD_H
extern POINTER_TYPE *sbrk ();
#endif
-#ifdef HAVE_FCNTL_H
#include <fcntl.h>
-#endif
-#ifndef O_WRONLY
-#define O_WRONLY 1
-#endif
#ifdef WINDOWSNT
-#include <fcntl.h>
#include "w32.h"
#endif
static __malloc_size_t bytes_used_when_full;
-static __malloc_size_t bytes_used_when_reconsidered;
-
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
#define GC_STRING_BYTES(S) (STRING_BYTES (S))
#define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
+/* Global variables. */
+struct emacs_globals globals;
+
/* Number of bytes of consing done since the last gc. */
int consing_since_gc;
-/* Count the amount of consing of various sorts of space. */
-
-EMACS_INT cons_cells_consed;
-EMACS_INT floats_consed;
-EMACS_INT vector_cells_consed;
-EMACS_INT symbols_consed;
-EMACS_INT string_chars_consed;
-EMACS_INT misc_objects_consed;
-EMACS_INT intervals_consed;
-EMACS_INT strings_consed;
-
-/* Minimum number of bytes of consing since GC before next GC. */
-
-EMACS_INT gc_cons_threshold;
-
/* Similar minimum, computed from Vgc_cons_percentage. */
EMACS_INT gc_relative_threshold;
-static Lisp_Object Vgc_cons_percentage;
-
/* Minimum number of bytes of consing since GC before next GC,
when memory is full. */
int abort_on_gc;
-/* Nonzero means display messages at beginning and end of GC. */
-
-int garbage_collection_messages;
-
/* Number of live and free conses etc. */
static int total_conses, total_markers, total_symbols, total_vector_size;
static int malloc_hysteresis;
-/* Non-nil means defun should do purecopy on the function definition. */
-
-Lisp_Object Vpurify_flag;
-
-/* Non-nil means we are handling a memory-full error. */
-
-Lisp_Object Vmemory_full;
-
/* Initialize it to a nonzero value to force it into data space
(rather than bss space). That way unexec will remap it into text
space (pure), on some systems. We have not implemented the
&& ((PNTR_COMPARISON_TYPE) (P) \
>= (PNTR_COMPARISON_TYPE) purebeg))
-/* Total number of bytes allocated in pure storage. */
-
-EMACS_INT pure_bytes_used;
-
/* Index in pure at which next pure Lisp object will be allocated.. */
static EMACS_INT pure_bytes_used_lisp;
const char *pending_malloc_warning;
-/* Pre-computed signal argument for use when memory is exhausted. */
-
-Lisp_Object Vmemory_signal_data;
-
/* Maximum amount of C stack to save when a GC happens. */
#ifndef MAX_SAVE_STACK
/* Hook run after GC has finished. */
-Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
-
-Lisp_Object Vgc_elapsed; /* accumulated elapsed time in GC */
-EMACS_INT gcs_done; /* accumulated GCs */
+Lisp_Object Qpost_gc_hook;
static void mark_buffer (Lisp_Object);
static void mark_terminals (void);
static POINTER_TYPE *lisp_align_malloc (size_t, enum mem_type);
static POINTER_TYPE *lisp_malloc (size_t, enum mem_type);
-void refill_memory_reserve (void);
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
static void * (*old_realloc_hook) (void *, size_t, const void*);
static void (*old_free_hook) (void*, const void*);
+static __malloc_size_t bytes_used_when_reconsidered;
+
/* This function is used as the hook for free to call. */
static void
register Lisp_Object val;
EMACS_INT nchars, multibyte_nbytes;
- parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
+ parse_str_as_multibyte ((const unsigned char *) contents, nbytes,
+ &nchars, &multibyte_nbytes);
if (nbytes == nchars || nbytes != multibyte_nbytes)
/* CONTENTS contains no multibyte sequences or contains an invalid
multibyte sequence. We must make unibyte string. */
register Lisp_Object val;
val = make_uninit_string (length);
memcpy (SDATA (val), contents, length);
- STRING_SET_UNIBYTE (val);
return val;
}
if (nchars < 0)
{
if (multibyte)
- nchars = multibyte_chars_in_text (contents, nbytes);
+ nchars = multibyte_chars_in_text ((const unsigned char *) contents,
+ nbytes);
else
nchars = nbytes;
}
}
-/* Return a new `function vector' containing KIND as the first element,
- followed by NUM_NIL_SLOTS nil elements, and further elements copied from
- the vector PARAMS of length NUM_PARAMS (so the total length of the
- resulting vector is 1 + NUM_NIL_SLOTS + NUM_PARAMS).
-
- If NUM_PARAMS is zero, then PARAMS may be NULL.
-
- A `function vector', a.k.a. `funvec', is a funcallable vector in Emacs Lisp.
- See the function `funvec' for more detail. */
-
-Lisp_Object
-make_funvec (Lisp_Object kind, int num_nil_slots, int num_params,
- Lisp_Object *params)
-{
- int param_index;
- Lisp_Object funvec;
-
- funvec = Fmake_vector (make_number (1 + num_nil_slots + num_params), Qnil);
-
- ASET (funvec, 0, kind);
-
- for (param_index = 0; param_index < num_params; param_index++)
- ASET (funvec, 1 + num_nil_slots + param_index, params[param_index]);
-
- XSETPVECTYPE (XVECTOR (funvec), PVEC_FUNVEC);
- XSETFUNVEC (funvec, XVECTOR (funvec));
-
- return funvec;
-}
-
-
DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
doc: /* Return a newly created vector with specified arguments as elements.
Any number of arguments, even zero arguments, are allowed.
}
-DEFUN ("funvec", Ffunvec, Sfunvec, 1, MANY, 0,
- doc: /* Return a newly created `function vector' of type KIND.
-A `function vector', a.k.a. `funvec', is a funcallable vector in Emacs Lisp.
-KIND indicates the kind of funvec, and determines its behavior when called.
-The meaning of the remaining arguments depends on KIND. Currently
-implemented values of KIND, and their meaning, are:
-
- A list -- A byte-compiled function. See `make-byte-code' for the usual
- way to create byte-compiled functions.
-
- `curry' -- A curried function. Remaining arguments are a function to
- call, and arguments to prepend to user arguments at the
- time of the call; see the `curry' function.
-
-usage: (funvec KIND &rest PARAMS) */)
- (int nargs, Lisp_Object *args)
-{
- return make_funvec (args[0], 0, nargs - 1, args + 1);
-}
-
-
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
doc: /* Create a byte-code object with specified arguments as elements.
The arguments should be the arglist, bytecode-string, constant vector,
register int index;
register struct Lisp_Vector *p;
- /* Make sure the arg-list is really a list, as that's what's used to
- distinguish a byte-compiled object from other funvecs. */
- CHECK_LIST (args[0]);
-
XSETFASTINT (len, nargs);
if (!NILP (Vpurify_flag))
val = make_pure_vector ((EMACS_INT) nargs);
args[index] = Fpurecopy (args[index]);
p->contents[index] = args[index];
}
- XSETPVECTYPE (p, PVEC_FUNVEC);
- XSETFUNVEC (val, p);
+ XSETPVECTYPE (p, PVEC_COMPILED);
+ XSETCOMPILED (val, p);
return val;
}
must not have been killed. */
return (m->type == MEM_TYPE_BUFFER
&& p == m->start
- && !NILP (((struct buffer *) p)->name));
+ && !NILP (((struct buffer *) p)->BUFFER_INTERNAL_FIELD (name)));
}
#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
static INLINE void
mark_maybe_object (Lisp_Object obj)
{
- void *po = (void *) XPNTR (obj);
- struct mem_node *m = mem_find (po);
+ void *po;
+ struct mem_node *m;
+
+ if (INTEGERP (obj))
+ return;
+
+ po = (void *) XPNTR (obj);
+ m = mem_find (po);
if (m != MEM_NIL)
{
can prove that. */
static void
-test_setjmp ()
+test_setjmp (void)
{
char buf[10];
register int x;
/* Abort if anything GCPRO'd doesn't survive the GC. */
static void
-check_gcpros ()
+check_gcpros (void)
{
struct gcpro *p;
int i;
#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
static void
-dump_zombies ()
+dump_zombies (void)
{
int i;
have to be true! It must be verified for each system, possibly
by taking a look at the source code of setjmp.
+ If __builtin_unwind_init is available (defined by GCC >= 2.8) we
+ can use it as a machine independent method to store all registers
+ to the stack. In this case the macros described in the previous
+ two paragraphs are not used.
+
Stack Layout
Architectures differ in the way their processor stack is organized.
volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
void *end;
+#ifdef HAVE___BUILTIN_UNWIND_INIT
+ /* Force callee-saved registers and register windows onto the stack.
+ This is the preferred method if available, obviating the need for
+ machine dependent methods. */
+ __builtin_unwind_init ();
+ end = &end;
+#else /* not HAVE___BUILTIN_UNWIND_INIT */
/* This trick flushes the register windows so that all the state of
the process is contained in the stack. */
/* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
setjmp (j.j);
end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
#endif /* not GC_SAVE_REGISTERS_ON_STACK */
+#endif /* not HAVE___BUILTIN_UNWIND_INIT */
/* This assumes that the stack is a contiguous region in memory. If
that's not the case, something has to be done here to iterate
struct Lisp_String *s;
s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
- s->data = find_string_data_in_pure (data, nbytes);
+ s->data = (unsigned char *) find_string_data_in_pure (data, nbytes);
if (s->data == NULL)
{
s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
else if (FLOATP (obj))
obj = make_pure_float (XFLOAT_DATA (obj));
else if (STRINGP (obj))
- obj = make_pure_string (SDATA (obj), SCHARS (obj),
+ obj = make_pure_string (SSDATA (obj), SCHARS (obj),
SBYTES (obj),
STRING_MULTIBYTE (obj));
- else if (FUNVECP (obj) || VECTORP (obj))
+ else if (COMPILEDP (obj) || VECTORP (obj))
{
register struct Lisp_Vector *vec;
register EMACS_INT i;
vec = XVECTOR (make_pure_vector (size));
for (i = 0; i < size; i++)
vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
- if (FUNVECP (obj))
+ if (COMPILEDP (obj))
{
- XSETPVECTYPE (vec, PVEC_FUNVEC);
- XSETFUNVEC (obj, vec);
+ XSETPVECTYPE (vec, PVEC_COMPILED);
+ XSETCOMPILED (obj, vec);
}
else
XSETVECTOR (obj, vec);
(void)
{
register struct specbinding *bind;
- struct catchtag *catch;
- struct handler *handler;
char stack_top_variable;
register int i;
int message_p;
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 (! NILP (nextb->name) && ! EQ (nextb->undo_list, Qt))
+ if (! NILP (nextb->BUFFER_INTERNAL_FIELD (name)) && ! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
truncate_undo_list (nextb);
/* Shrink buffer gaps, but skip indirect and dead buffers. */
- if (nextb->base_buffer == 0 && !NILP (nextb->name)
+ if (nextb->base_buffer == 0 && !NILP (nextb->BUFFER_INTERNAL_FIELD (name))
&& ! nextb->text->inhibit_shrinking)
{
/* If a buffer's gap size is more than 10% of the buffer
for (i = 0; i < tail->nvars; i++)
mark_object (tail->var[i]);
}
-#endif
-
mark_byte_stack ();
+ {
+ struct catchtag *catch;
+ struct handler *handler;
+
for (catch = catchlist; catch; catch = catch->next)
{
mark_object (catch->tag);
mark_object (handler->handler);
mark_object (handler->var);
}
+ }
mark_backtrace ();
+#endif
#ifdef HAVE_WINDOW_SYSTEM
mark_fringe_data ();
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))
+ if (! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
{
Lisp_Object tail, prev;
- tail = nextb->undo_list;
+ tail = nextb->BUFFER_INTERNAL_FIELD (undo_list);
prev = Qnil;
while (CONSP (tail))
{
&& !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
{
if (NILP (prev))
- nextb->undo_list = tail = XCDR (tail);
+ nextb->BUFFER_INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
else
{
tail = XCDR (tail);
}
/* Now that we have stripped the elements that need not be in the
undo_list any more, we can finally mark the list. */
- mark_object (nextb->undo_list);
+ mark_object (nextb->BUFFER_INTERNAL_FIELD (undo_list));
nextb = nextb->next;
}
{
Lisp_Object val = ptr->contents[i];
- if (INTEGERP (val) || SYMBOLP (val) && XSYMBOL (val)->gcmarkbit)
+ if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->gcmarkbit))
continue;
if (SUB_CHAR_TABLE_P (val))
{
}
else if (SUBRP (obj))
break;
- else if (FUNVECP (obj) && FUNVEC_COMPILED_P (obj))
+ else if (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. */
/* buffer-local Lisp variables start at `undo_list',
tho only the ones from `name' on are GC'd normally. */
- for (ptr = &buffer->name;
+ for (ptr = &buffer->BUFFER_INTERNAL_FIELD (name);
(char *)ptr < (char *)buffer + sizeof (struct buffer);
ptr++)
mark_object (*ptr);
for (t = terminal_list; t; t = t->next_terminal)
{
eassert (t->name != NULL);
- if (!VECTOR_MARKED_P (t))
- {
#ifdef HAVE_WINDOW_SYSTEM
- mark_image_cache (t->image_cache);
+ /* If a terminal object is reachable from a stacpro'ed object,
+ it might have been marked already. Make sure the image cache
+ gets marked. */
+ mark_image_cache (t->image_cache);
#endif /* HAVE_WINDOW_SYSTEM */
- mark_vectorlike ((struct Lisp_Vector *)t);
- }
+ if (!VECTOR_MARKED_P (t))
+ mark_vectorlike ((struct Lisp_Vector *)t);
}
}
void
syms_of_alloc (void)
{
- DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
+ DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
doc: /* *Number of bytes of consing between garbage collections.
Garbage collection can happen automatically once this many bytes have been
allocated since the last garbage collection. All data types count.
prevent garbage collection during a part of the program.
See also `gc-cons-percentage'. */);
- DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage,
+ DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage,
doc: /* *Portion of the heap used for allocation.
Garbage collection can happen automatically once this portion of the heap
has been allocated since the last garbage collection.
If this portion is smaller than `gc-cons-threshold', this is ignored. */);
Vgc_cons_percentage = make_float (0.1);
- DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
+ DEFVAR_INT ("pure-bytes-used", pure_bytes_used,
doc: /* Number of bytes of sharable Lisp data allocated so far. */);
- DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
+ DEFVAR_INT ("cons-cells-consed", cons_cells_consed,
doc: /* Number of cons cells that have been consed so far. */);
- DEFVAR_INT ("floats-consed", &floats_consed,
+ DEFVAR_INT ("floats-consed", floats_consed,
doc: /* Number of floats that have been consed so far. */);
- DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
+ DEFVAR_INT ("vector-cells-consed", vector_cells_consed,
doc: /* Number of vector cells that have been consed so far. */);
- DEFVAR_INT ("symbols-consed", &symbols_consed,
+ DEFVAR_INT ("symbols-consed", symbols_consed,
doc: /* Number of symbols that have been consed so far. */);
- DEFVAR_INT ("string-chars-consed", &string_chars_consed,
+ DEFVAR_INT ("string-chars-consed", string_chars_consed,
doc: /* Number of string characters that have been consed so far. */);
- DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
+ DEFVAR_INT ("misc-objects-consed", misc_objects_consed,
doc: /* Number of miscellaneous objects that have been consed so far. */);
- DEFVAR_INT ("intervals-consed", &intervals_consed,
+ DEFVAR_INT ("intervals-consed", intervals_consed,
doc: /* Number of intervals that have been consed so far. */);
- DEFVAR_INT ("strings-consed", &strings_consed,
+ DEFVAR_INT ("strings-consed", strings_consed,
doc: /* Number of strings that have been consed so far. */);
- DEFVAR_LISP ("purify-flag", &Vpurify_flag,
+ DEFVAR_LISP ("purify-flag", Vpurify_flag,
doc: /* Non-nil means loading Lisp code in order to dump an executable.
This means that certain objects should be allocated in shared (pure) space.
It can also be set to a hash-table, in which case this table is used to
do hash-consing of the objects allocated to pure space. */);
- DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
+ DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages,
doc: /* Non-nil means display messages at start and end of garbage collection. */);
garbage_collection_messages = 0;
- DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook,
+ DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook,
doc: /* Hook run after garbage collection has finished. */);
Vpost_gc_hook = Qnil;
Qpost_gc_hook = intern_c_string ("post-gc-hook");
staticpro (&Qpost_gc_hook);
- DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
+ DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data,
doc: /* Precomputed `signal' argument for memory-full error. */);
/* 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. */
= pure_cons (Qerror,
pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil));
- DEFVAR_LISP ("memory-full", &Vmemory_full,
+ DEFVAR_LISP ("memory-full", Vmemory_full,
doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
Vmemory_full = Qnil;
staticpro (&Qchar_table_extra_slots);
Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
- DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
+ DEFVAR_LISP ("gc-elapsed", Vgc_elapsed,
doc: /* Accumulated time elapsed in garbage collections.
The time is in seconds as a floating point value. */);
- DEFVAR_INT ("gcs-done", &gcs_done,
+ DEFVAR_INT ("gcs-done", gcs_done,
doc: /* Accumulated number of garbage collections done. */);
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);
- defsubr (&Sfunvec);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
defsubr (&Sgc_status);
#endif
}
-
-/* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
- (do not change this comment) */
HCoop / bpt / emacs.git / blobdiff