/* 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, 2011
+ 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
#endif /* not DOUG_LEA_MALLOC */
-#if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
+#if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
+#ifdef HAVE_GTK_AND_PTHREAD
/* When GTK uses the file chooser dialog, different backends can be loaded
dynamically. One such a backend is the Gnome VFS backend that gets loaded
} \
while (0)
-#else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
+#else /* ! defined HAVE_GTK_AND_PTHREAD */
#define BLOCK_INPUT_ALLOC BLOCK_INPUT
#define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
-#endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
-
-/* Value of _bytes_used, when spare_memory was freed. */
-
-static __malloc_size_t bytes_used_when_full;
+#endif /* ! defined HAVE_GTK_AND_PTHREAD */
+#endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
#define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
#define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
-#define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
-#define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
-#define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
+#define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
+#define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
+#define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
-/* Value is the number of bytes/chars of S, a pointer to a struct
- Lisp_String. This must be used instead of STRING_BYTES (S) or
- S->size during GC, because S->size contains the mark bit for
+/* Value is the number of bytes of S, a pointer to a struct Lisp_String.
+ Be careful during GC, because S->size contains the mark bit for
strings. */
#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 char *spare_memory[7];
+#ifndef SYSTEM_MALLOC
/* Amount of spare memory to keep in large reserve block. */
#define SPARE_MEMORY (1 << 14)
+#endif
/* Number of extra blocks malloc should get when it needs more core. */
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
remapping on more recent systems because this is less important
nowadays than in the days of small memories and timesharing. */
+#ifndef VIRT_ADDR_VARIES
+static
+#endif
EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
#define PUREBEG (char *) pure
&& ((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
/* Buffer in which we save a copy of the C stack at each GC. */
+#if MAX_SAVE_STACK > 0
static char *stack_copy;
-static int stack_copy_size;
+static size_t stack_copy_size;
+#endif
/* Non-zero means ignore malloc warnings. Set during initialization.
Currently not used. */
static int ignore_warnings;
-Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
+static Lisp_Object Qgc_cons_threshold;
+Lisp_Object Qchar_table_extra_slots;
/* 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 */
+static Lisp_Object Qpost_gc_hook;
static void mark_buffer (Lisp_Object);
static void mark_terminals (void);
-extern void mark_kboards (void);
-extern void mark_ttys (void);
-extern void mark_backtrace (void);
static void gc_sweep (void);
static void mark_glyph_matrix (struct glyph_matrix *);
static void mark_face_cache (struct face_cache *);
-#ifdef HAVE_WINDOW_SYSTEM
-extern void mark_fringe_data (void);
-#endif /* HAVE_WINDOW_SYSTEM */
-
+#if !defined REL_ALLOC || defined SYSTEM_MALLOC
+static void refill_memory_reserve (void);
+#endif
static struct Lisp_String *allocate_string (void);
static void compact_small_strings (void);
static void free_large_strings (void);
static void sweep_strings (void);
-
-extern int message_enable_multibyte;
+static void free_misc (Lisp_Object);
/* When scanning the C stack for live Lisp objects, Emacs keeps track
of what memory allocated via lisp_malloc is intended for what
intern ("emergency"));
pending_malloc_warning = 0;
}
-
-
-#ifdef DOUG_LEA_MALLOC
-# define BYTES_USED (mallinfo ().uordblks)
-#else
-# define BYTES_USED _bytes_used
-#endif
\f
/* Called if we can't allocate relocatable space for a buffer. */
/* Like malloc, but wraps allocated block with header and trailer. */
-POINTER_TYPE *
-overrun_check_malloc (size)
- size_t size;
+static POINTER_TYPE *
+overrun_check_malloc (size_t size)
{
register unsigned char *val;
size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
/* Like realloc, but checks old block for overrun, and wraps new block
with header and trailer. */
-POINTER_TYPE *
-overrun_check_realloc (block, size)
- POINTER_TYPE *block;
- size_t size;
+static POINTER_TYPE *
+overrun_check_realloc (POINTER_TYPE *block, size_t size)
{
- register unsigned char *val = (unsigned char *)block;
+ register unsigned char *val = (unsigned char *) block;
size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
if (val
/* Like free, but checks block for overrun. */
-void
-overrun_check_free (block)
- POINTER_TYPE *block;
+static void
+overrun_check_free (POINTER_TYPE *block)
{
- unsigned char *val = (unsigned char *)block;
+ unsigned char *val = (unsigned char *) block;
++check_depth;
if (val
nothing else. */
#define BLOCK_PADDING 0
#define BLOCK_BYTES \
- (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
+ (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
/* Internal data structures and constants. */
struct buffer *b
= (struct buffer *) lisp_malloc (sizeof (struct buffer),
MEM_TYPE_BUFFER);
- b->size = sizeof (struct buffer) / sizeof (EMACS_INT);
- XSETPVECTYPE (b, PVEC_BUFFER);
+ XSETPVECTYPESIZE (b, PVEC_BUFFER,
+ ((sizeof (struct buffer) + sizeof (EMACS_INT) - 1)
+ / sizeof (EMACS_INT)));
return b;
}
static void * (*old_realloc_hook) (void *, size_t, const void*);
static void (*old_free_hook) (void*, const void*);
+#ifdef DOUG_LEA_MALLOC
+# define BYTES_USED (mallinfo ().uordblks)
+#else
+# define BYTES_USED _bytes_used
+#endif
+
static __malloc_size_t bytes_used_when_reconsidered;
+/* Value of _bytes_used, when spare_memory was freed. */
+
+static __malloc_size_t bytes_used_when_full;
+
/* This function is used as the hook for free to call. */
static void
/* List of free intervals. */
-INTERVAL interval_free_list;
+static INTERVAL interval_free_list;
/* Total number of interval blocks now in use. */
#define SDATA_NBYTES(S) (S)->nbytes
#define SDATA_DATA(S) (S)->data
+#define SDATA_SELECTOR(member) member
#else /* not GC_CHECK_STRING_BYTES */
union
{
- /* When STRING in non-null. */
+ /* When STRING is non-null. */
unsigned char data[1];
/* When STRING is null. */
EMACS_INT nbytes;
} u;
-
#define SDATA_NBYTES(S) (S)->u.nbytes
#define SDATA_DATA(S) (S)->u.data
+#define SDATA_SELECTOR(member) u.member
#endif /* not GC_CHECK_STRING_BYTES */
+
+#define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
};
a pointer to the `u.data' member of its sdata structure; the
structure starts at a constant offset in front of that. */
-#ifdef GC_CHECK_STRING_BYTES
-
-#define SDATA_OF_STRING(S) \
- ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
- - sizeof (EMACS_INT)))
-
-#else /* not GC_CHECK_STRING_BYTES */
-
-#define SDATA_OF_STRING(S) \
- ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
-
-#endif /* not GC_CHECK_STRING_BYTES */
+#define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
#ifdef GC_CHECK_STRING_OVERRUN
presence of this cookie during GC. */
#define GC_STRING_OVERRUN_COOKIE_SIZE 4
-static char string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
- { 0xde, 0xad, 0xbe, 0xef };
+static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
+ { '\xde', '\xad', '\xbe', '\xef' };
#else
#define GC_STRING_OVERRUN_COOKIE_SIZE 0
#ifdef GC_CHECK_STRING_BYTES
#define SDATA_SIZE(NBYTES) \
- ((sizeof (struct Lisp_String *) \
+ ((SDATA_DATA_OFFSET \
+ (NBYTES) + 1 \
- + sizeof (EMACS_INT) \
+ sizeof (EMACS_INT) - 1) \
& ~(sizeof (EMACS_INT) - 1))
#else /* not GC_CHECK_STRING_BYTES */
-#define SDATA_SIZE(NBYTES) \
- ((sizeof (struct Lisp_String *) \
- + (NBYTES) + 1 \
- + sizeof (EMACS_INT) - 1) \
+/* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
+ less than the size of that member. The 'max' is not needed when
+ SDATA_DATA_OFFSET is a multiple of sizeof (EMACS_INT), because then the
+ alignment code reserves enough space. */
+
+#define SDATA_SIZE(NBYTES) \
+ ((SDATA_DATA_OFFSET \
+ + (SDATA_DATA_OFFSET % sizeof (EMACS_INT) == 0 \
+ ? NBYTES \
+ : max (NBYTES, sizeof (EMACS_INT) - 1)) \
+ + 1 \
+ + sizeof (EMACS_INT) - 1) \
& ~(sizeof (EMACS_INT) - 1))
#endif /* not GC_CHECK_STRING_BYTES */
static int check_string_bytes_count;
-static void check_string_bytes (int);
-static void check_sblock (struct sblock *);
-
#define CHECK_STRING_BYTES(S) STRING_BYTES (S)
/* Check validity of Lisp strings' string_bytes member in B. */
static void
-check_sblock (b)
- struct sblock *b;
+check_sblock (struct sblock *b)
{
struct sdata *from, *end, *from_end;
recently allocated strings. Used for hunting a bug. */
static void
-check_string_bytes (all_p)
- int all_p;
+check_string_bytes (int all_p)
{
if (all_p)
{
This may catch buffer overrun from a previous string. */
static void
-check_string_free_list ()
+check_string_free_list (void)
{
struct Lisp_String *s;
if (nbytes > LARGE_STRING_BYTES)
{
- size_t size = sizeof *b - sizeof (struct sdata) + needed;
+ size_t size = offsetof (struct sblock, first_data) + needed;
#ifdef DOUG_LEA_MALLOC
/* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
s->size_byte = nbytes;
s->data[nbytes] = '\0';
#ifdef GC_CHECK_STRING_OVERRUN
- memcpy (data + needed, string_overrun_cookie, GC_STRING_OVERRUN_COOKIE_SIZE);
+ memcpy ((char *) data + needed, string_overrun_cookie,
+ GC_STRING_OVERRUN_COOKIE_SIZE);
#endif
/* If S had already data assigned, mark that as free by setting its
/* Copy, and update the string's `data' pointer. */
if (from != to)
{
- xassert (tb != b || to <= from);
+ xassert (tb != b || to < from);
memmove (to, from, nbytes + GC_STRING_EXTRA);
to->string->data = SDATA_DATA (to);
}
slot `size' of the struct Lisp_Bool_Vector. */
val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
- /* Get rid of any bits that would cause confusion. */
- XVECTOR (val)->size = 0; /* No Lisp_Object to trace in there. */
- /* Use XVECTOR (val) rather than `p' because p->size is not TRT. */
- XSETPVECTYPE (XVECTOR (val), PVEC_BOOL_VECTOR);
+ /* No Lisp_Object to trace in there. */
+ XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0);
p = XBOOL_VECTOR (val);
p->size = XFASTINT (length);
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;
}
/* Current float_block. */
-struct float_block *float_block;
+static struct float_block *float_block;
/* Index of first unused Lisp_Float in the current float_block. */
-int float_block_index;
+static int float_block_index;
/* Total number of float blocks now in use. */
-int n_float_blocks;
+static int n_float_blocks;
/* Free-list of Lisp_Floats. */
-struct Lisp_Float *float_free_list;
+static struct Lisp_Float *float_free_list;
/* Initialize float allocation. */
/* Current cons_block. */
-struct cons_block *cons_block;
+static struct cons_block *cons_block;
/* Index of first unused Lisp_Cons in the current block. */
-int cons_block_index;
+static int cons_block_index;
/* Free-list of Lisp_Cons structures. */
-struct Lisp_Cons *cons_free_list;
+static struct Lisp_Cons *cons_free_list;
/* Total number of cons blocks now in use. */
return val;
}
+#ifdef GC_CHECK_CONS_LIST
/* Get an error now if there's any junk in the cons free list. */
void
check_cons_list (void)
{
-#ifdef GC_CHECK_CONS_LIST
struct Lisp_Cons *tail = cons_free_list;
while (tail)
tail = tail->u.chain;
-#endif
}
+#endif
/* Make a list of 1, 2, 3, 4 or 5 specified objects. */
doc: /* Return a newly created list with specified arguments as elements.
Any number of arguments, even zero arguments, are allowed.
usage: (list &rest OBJECTS) */)
- (int nargs, register Lisp_Object *args)
+ (size_t nargs, register Lisp_Object *args)
{
register Lisp_Object val;
val = Qnil;
/* This gets triggered by code which I haven't bothered to fix. --Stef */
/* eassert (!handling_signal); */
- nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
+ nbytes = (offsetof (struct Lisp_Vector, contents)
+ + len * sizeof p->contents[0]);
p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
#ifdef DOUG_LEA_MALLOC
consing_since_gc += nbytes;
vector_cells_consed += len;
- p->next = all_vectors;
+ p->header.next.vector = all_vectors;
all_vectors = p;
MALLOC_UNBLOCK_INPUT;
allocate_vector (EMACS_INT nslots)
{
struct Lisp_Vector *v = allocate_vectorlike (nslots);
- v->size = nslots;
+ v->header.size = nslots;
return v;
}
EMACS_INT i;
/* Only the first lisplen slots will be traced normally by the GC. */
- v->size = lisplen;
for (i = 0; i < lisplen; ++i)
v->contents[i] = Qnil;
- XSETPVECTYPE (v, tag); /* Add the appropriate tag. */
+ XSETPVECTYPESIZE (v, tag, lisplen);
return v;
}
{
Lisp_Object vector;
register EMACS_INT sizei;
- register EMACS_INT index;
+ register EMACS_INT i;
register struct Lisp_Vector *p;
CHECK_NATNUM (length);
sizei = XFASTINT (length);
p = allocate_vector (sizei);
- for (index = 0; index < sizei; index++)
- p->contents[index] = init;
+ for (i = 0; i < sizei; i++)
+ p->contents[i] = init;
XSETVECTOR (vector, p);
return vector;
doc: /* Return a newly created vector with specified arguments as elements.
Any number of arguments, even zero arguments, are allowed.
usage: (vector &rest OBJECTS) */)
- (register int nargs, Lisp_Object *args)
+ (register size_t nargs, Lisp_Object *args)
{
register Lisp_Object len, val;
- register int index;
+ register size_t i;
register struct Lisp_Vector *p;
XSETFASTINT (len, nargs);
val = Fmake_vector (len, Qnil);
p = XVECTOR (val);
- for (index = 0; index < nargs; index++)
- p->contents[index] = args[index];
+ for (i = 0; i < nargs; i++)
+ p->contents[i] = args[i];
return val;
}
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,
-stack size, (optional) doc string, and (optional) interactive spec.
+The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
+vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
+and (optional) INTERACTIVE-SPEC.
The first four arguments are required; at most six have any
significance.
+The ARGLIST can be either like the one of `lambda', in which case the arguments
+will be dynamically bound before executing the byte code, or it can be an
+integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
+minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
+of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
+argument to catch the left-over arguments. If such an integer is used, the
+arguments will not be dynamically bound but will be instead pushed on the
+stack before executing the byte-code.
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
- (register int nargs, Lisp_Object *args)
+ (register size_t nargs, Lisp_Object *args)
{
register Lisp_Object len, val;
- register int index;
+ register size_t i;
register struct Lisp_Vector *p;
XSETFASTINT (len, nargs);
args[1] = Fstring_as_unibyte (args[1]);
p = XVECTOR (val);
- for (index = 0; index < nargs; index++)
+ for (i = 0; i < nargs; i++)
{
if (!NILP (Vpurify_flag))
- args[index] = Fpurecopy (args[index]);
- p->contents[index] = args[index];
+ args[i] = Fpurecopy (args[i]);
+ p->contents[i] = args[i];
}
XSETPVECTYPE (p, PVEC_COMPILED);
XSETCOMPILED (val, p);
p->gcmarkbit = 0;
p->interned = SYMBOL_UNINTERNED;
p->constant = 0;
+ p->declared_special = 0;
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
return val;
/* Free a Lisp_Misc object */
-void
+static void
free_misc (Lisp_Object misc)
{
XMISCTYPE (misc) = Lisp_Misc_Free;
/* Record the space now used. When it decreases substantially,
we can refill the memory reserve. */
-#ifndef SYSTEM_MALLOC
+#if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
bytes_used_when_full = BYTES_USED;
#endif
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 */
check_gcpros (void)
{
struct gcpro *p;
- int i;
+ size_t i;
for (p = gcprolist; p; p = p->next)
for (i = 0; i < p->nvars; ++i)
mark_stack (void)
{
int i;
- /* jmp_buf may not be aligned enough on darwin-ppc64 */
- union aligned_jmpbuf {
- Lisp_Object o;
- jmp_buf j;
- } j;
- volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
void *end;
#ifdef HAVE___BUILTIN_UNWIND_INIT
__builtin_unwind_init ();
end = &end;
#else /* not HAVE___BUILTIN_UNWIND_INIT */
+#ifndef GC_SAVE_REGISTERS_ON_STACK
+ /* jmp_buf may not be aligned enough on darwin-ppc64 */
+ union aligned_jmpbuf {
+ Lisp_Object o;
+ jmp_buf j;
+ } j;
+ volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
+#endif
/* 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
check_pure_size (void)
{
if (pure_bytes_used_before_overflow)
- message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
- (int) (pure_bytes_used + pure_bytes_used_before_overflow));
+ message (("emacs:0:Pure Lisp storage overflow (approx. %"pI"d"
+ " bytes needed)"),
+ pure_bytes_used + pure_bytes_used_before_overflow);
}
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);
{
Lisp_Object new;
struct Lisp_Vector *p;
- size_t size = sizeof *p + (len - 1) * sizeof (Lisp_Object);
+ size_t size = (offsetof (struct Lisp_Vector, contents)
+ + len * sizeof (Lisp_Object));
p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
XSETVECTOR (new, p);
- XVECTOR (new)->size = len;
+ XVECTOR (new)->header.size = len;
return new;
}
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 (COMPILEDP (obj) || VECTORP (obj))
register EMACS_INT i;
EMACS_INT size;
- size = XVECTOR (obj)->size;
+ size = ASIZE (obj);
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
vec = XVECTOR (make_pure_vector (size));
(void)
{
register struct specbinding *bind;
- struct catchtag *catch;
- struct handler *handler;
char stack_top_variable;
- register int i;
+ register size_t i;
int message_p;
Lisp_Object total[8];
int count = SPECPDL_INDEX ();
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
}
}
- nextb = nextb->next;
+ nextb = nextb->header.next.buffer;
}
}
#if MAX_SAVE_STACK > 0
if (NILP (Vpurify_flag))
{
- i = &stack_top_variable - stack_bottom;
- if (i < 0) i = -i;
- if (i < MAX_SAVE_STACK)
+ char *stack;
+ size_t stack_size;
+ if (&stack_top_variable < stack_bottom)
+ {
+ stack = &stack_top_variable;
+ stack_size = stack_bottom - &stack_top_variable;
+ }
+ else
+ {
+ stack = stack_bottom;
+ stack_size = &stack_top_variable - stack_bottom;
+ }
+ if (stack_size <= MAX_SAVE_STACK)
{
- if (stack_copy == 0)
- stack_copy = (char *) xmalloc (stack_copy_size = i);
- else if (stack_copy_size < i)
- stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i));
- if (stack_copy)
+ if (stack_copy_size < stack_size)
{
- if ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0)
- memcpy (stack_copy, stack_bottom, i);
- else
- memcpy (stack_copy, &stack_top_variable, i);
+ stack_copy = (char *) xrealloc (stack_copy, stack_size);
+ stack_copy_size = stack_size;
}
+ memcpy (stack_copy, stack, stack_size);
}
}
#endif /* MAX_SAVE_STACK > 0 */
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;
+ nextb = nextb->header.next.buffer;
}
}
if (FLOATP (Vgc_cons_percentage))
{ /* Set gc_cons_combined_threshold. */
- EMACS_INT total = 0;
-
- total += total_conses * sizeof (struct Lisp_Cons);
- total += total_symbols * sizeof (struct Lisp_Symbol);
- total += total_markers * sizeof (union Lisp_Misc);
- total += total_string_size;
- total += total_vector_size * sizeof (Lisp_Object);
- total += total_floats * sizeof (struct Lisp_Float);
- total += total_intervals * sizeof (struct interval);
- total += total_strings * sizeof (struct Lisp_String);
-
- gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
+ EMACS_INT tot = 0;
+
+ tot += total_conses * sizeof (struct Lisp_Cons);
+ tot += total_symbols * sizeof (struct Lisp_Symbol);
+ tot += total_markers * sizeof (union Lisp_Misc);
+ tot += total_string_size;
+ tot += total_vector_size * sizeof (Lisp_Object);
+ tot += total_floats * sizeof (struct Lisp_Float);
+ tot += total_intervals * sizeof (struct interval);
+ tot += total_strings * sizeof (struct Lisp_String);
+
+ gc_relative_threshold = tot * XFLOAT_DATA (Vgc_cons_percentage);
}
else
gc_relative_threshold = 0;
if (!NILP (Vpost_gc_hook))
{
- int count = inhibit_garbage_collection ();
+ int gc_count = inhibit_garbage_collection ();
safe_run_hooks (Qpost_gc_hook);
- unbind_to (count, Qnil);
+ unbind_to (gc_count, Qnil);
}
/* Accumulate statistics. */
#define LAST_MARKED_SIZE 500
static Lisp_Object last_marked[LAST_MARKED_SIZE];
-int last_marked_index;
+static int last_marked_index;
/* For debugging--call abort when we cdr down this many
links of a list, in mark_object. In debugging,
the call to abort will hit a breakpoint.
Normally this is zero and the check never goes off. */
-static int mark_object_loop_halt;
+static size_t mark_object_loop_halt;
static void
mark_vectorlike (struct Lisp_Vector *ptr)
{
- register EMACS_UINT size = ptr->size;
+ register EMACS_UINT size = ptr->header.size;
register EMACS_UINT i;
eassert (!VECTOR_MARKED_P (ptr));
static void
mark_char_table (struct Lisp_Vector *ptr)
{
- register EMACS_UINT size = ptr->size & PSEUDOVECTOR_SIZE_MASK;
+ register EMACS_UINT size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
register EMACS_UINT i;
eassert (!VECTOR_MARKED_P (ptr));
void *po;
struct mem_node *m;
#endif
- int cdr_count = 0;
+ size_t cdr_count = 0;
loop:
#else /* not GC_CHECK_MARKED_OBJECTS */
-#define CHECK_ALLOCATED() (void) 0
#define CHECK_LIVE(LIVEP) (void) 0
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
if (po != &buffer_defaults && po != &buffer_local_symbols)
{
struct buffer *b;
- for (b = all_buffers; b && b != po; b = b->next)
+ for (b = all_buffers; b && b != po; b = b->header.next.buffer)
;
if (b == NULL)
abort ();
recursion there. */
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
- register EMACS_UINT size = ptr->size;
+ register EMACS_UINT size = ptr->header.size;
register EMACS_UINT i;
CHECK_LIVE (live_vector_p);
/* 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);
if (!VECTOR_MARKED_P (buffer))
{
if (prev)
- prev->next = buffer->next;
+ prev->header.next = buffer->header.next;
else
- all_buffers = buffer->next;
- next = buffer->next;
+ all_buffers = buffer->header.next.buffer;
+ next = buffer->header.next.buffer;
lisp_free (buffer);
buffer = next;
}
{
VECTOR_UNMARK (buffer);
UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
- prev = buffer, buffer = buffer->next;
+ prev = buffer, buffer = buffer->header.next.buffer;
}
}
if (!VECTOR_MARKED_P (vector))
{
if (prev)
- prev->next = vector->next;
+ prev->header.next = vector->header.next;
else
- all_vectors = vector->next;
- next = vector->next;
+ all_vectors = vector->header.next.vector;
+ next = vector->header.next.vector;
lisp_free (vector);
n_vectors--;
vector = next;
else
{
VECTOR_UNMARK (vector);
- if (vector->size & PSEUDOVECTOR_FLAG)
- total_vector_size += (PSEUDOVECTOR_SIZE_MASK & vector->size);
+ if (vector->header.size & PSEUDOVECTOR_FLAG)
+ total_vector_size += PSEUDOVECTOR_SIZE_MASK & vector->header.size;
else
- total_vector_size += vector->size;
- prev = vector, vector = vector->next;
+ total_vector_size += vector->header.size;
+ prev = vector, vector = vector->header.next.vector;
}
}
{
Lisp_Object end;
- XSETINT (end, (EMACS_INT) sbrk (0) / 1024);
+ XSETINT (end, (EMACS_INT) (char *) sbrk (0) / 1024);
return end;
}
return Flist (8, consed);
}
+#ifdef ENABLE_CHECKING
int suppress_checking;
void
file, line, msg);
abort ();
}
+#endif
\f
/* Initialization */
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 (&Sgc_status);
#endif
}
-
-/* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
- (do not change this comment) */
HCoop / bpt / emacs.git / blobdiff