along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
+
+#define LISP_INLINE EXTERN_INLINE
+
#include <stdio.h>
#include <limits.h> /* For CHAR_BIT. */
#include <setjmp.h>
-#include <signal.h>
+#ifdef ENABLE_CHECKING
+#include <signal.h> /* For SIGABRT. */
+#endif
#ifdef HAVE_PTHREAD
#include <pthread.h>
#endif
-/* This file is part of the core Lisp implementation, and thus must
- deal with the real data structures. If the Lisp implementation is
- replaced, this file likely will not be used. */
-
-#undef HIDE_LISP_IMPLEMENTATION
#include "lisp.h"
#include "process.h"
#include "intervals.h"
#include "keyboard.h"
#include "frame.h"
#include "blockinput.h"
-#include "syssignal.h"
#include "termhooks.h" /* For struct terminal. */
#include <setjmp.h>
#include <verify.h>
#include <fcntl.h>
+#ifdef USE_GTK
+# include "gtkutil.h"
+#endif
#ifdef WINDOWSNT
#include "w32.h"
#endif
#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 of S, a pointer to a struct Lisp_String.
- Be careful during GC, because S->size contains the mark bit for
- strings. */
+/* Default value of gc_cons_threshold (see below). */
-#define GC_STRING_BYTES(S) (STRING_BYTES (S))
+#define GC_DEFAULT_THRESHOLD (100000 * word_size)
/* Global variables. */
struct emacs_globals globals;
EMACS_INT memory_full_cons_threshold;
-/* Nonzero during GC. */
+/* True during GC. */
-int gc_in_progress;
+bool gc_in_progress;
-/* Nonzero means abort if try to GC.
+/* True means abort if try to GC.
This is for code which is written on the assumption that
no GC will happen, so as to verify that assumption. */
-int abort_on_gc;
+bool abort_on_gc;
/* Number of live and free conses etc. */
-static EMACS_INT total_conses, total_markers, total_symbols, total_vector_size;
+static EMACS_INT total_conses, total_markers, total_symbols, total_buffers;
static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
static EMACS_INT total_free_floats, total_floats;
static ptrdiff_t pure_bytes_used_before_overflow;
-/* Value is non-zero if P points into pure space. */
+/* True if P points into pure space. */
#define PURE_POINTER_P(P) \
((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
-/* Index in pure at which next pure Lisp object will be allocated.. */
+/* Index in pure at which next pure Lisp object will be allocated.. */
static ptrdiff_t pure_bytes_used_lisp;
static ptrdiff_t stack_copy_size;
#endif
-/* Non-zero means ignore malloc warnings. Set during initialization.
- Currently not used. */
-
-static int ignore_warnings;
-
+static Lisp_Object Qconses;
+static Lisp_Object Qsymbols;
+static Lisp_Object Qmiscs;
+static Lisp_Object Qstrings;
+static Lisp_Object Qvectors;
+static Lisp_Object Qfloats;
+static Lisp_Object Qintervals;
+static Lisp_Object Qbuffers;
+static Lisp_Object Qstring_bytes, Qvector_slots, Qheap;
static Lisp_Object Qgc_cons_threshold;
Lisp_Object Qchar_table_extra_slots;
static Lisp_Object make_pure_vector (ptrdiff_t);
static void mark_glyph_matrix (struct glyph_matrix *);
static void mark_face_cache (struct face_cache *);
+static void mark_buffer (struct buffer *);
#if !defined REL_ALLOC || defined SYSTEM_MALLOC
static void refill_memory_reserve (void);
and runtime slowdown. Minor but pointless. */
MEM_TYPE_VECTORLIKE,
/* Special type to denote vector blocks. */
- MEM_TYPE_VECTOR_BLOCK
+ MEM_TYPE_VECTOR_BLOCK,
+ /* Special type to denote reserved memory. */
+ MEM_TYPE_SPARE
};
static void *lisp_malloc (size_t, enum mem_type);
static struct Lisp_Vector *allocate_vectorlike (ptrdiff_t);
static void lisp_free (void *);
static void mark_stack (void);
-static int live_vector_p (struct mem_node *, void *);
-static int live_buffer_p (struct mem_node *, void *);
-static int live_string_p (struct mem_node *, void *);
-static int live_cons_p (struct mem_node *, void *);
-static int live_symbol_p (struct mem_node *, void *);
-static int live_float_p (struct mem_node *, void *);
-static int live_misc_p (struct mem_node *, void *);
+static bool live_vector_p (struct mem_node *, void *);
+static bool live_buffer_p (struct mem_node *, void *);
+static bool live_string_p (struct mem_node *, void *);
+static bool live_cons_p (struct mem_node *, void *);
+static bool live_symbol_p (struct mem_node *, void *);
+static bool live_float_p (struct mem_node *, void *);
+static bool live_misc_p (struct mem_node *, void *);
static void mark_maybe_object (Lisp_Object);
static void mark_memory (void *, void *);
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
/* Index of next unused slot in staticvec. */
-static int staticidx = 0;
+static int staticidx;
static void *pure_alloc (size_t, int);
hold a size_t value and (2) the header size is a multiple of the
alignment that Emacs needs for C types and for USE_LSB_TAG. */
#define XMALLOC_BASE_ALIGNMENT \
- offsetof ( \
- struct { \
- union { long double d; intmax_t i; void *p; } u; \
- char c; \
- }, \
- c)
+ alignof (union { long double d; intmax_t i; void *p; })
#if USE_LSB_TAG
# define XMALLOC_HEADER_ALIGNMENT \
- COMMON_MULTIPLE (1 << GCTYPEBITS, XMALLOC_BASE_ALIGNMENT)
+ COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
#else
# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
#endif
register unsigned char *val;
int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0;
if (SIZE_MAX - overhead < size)
- abort ();
+ emacs_abort ();
val = malloc (size + overhead);
if (val && check_depth == 1)
register unsigned char *val = (unsigned char *) block;
int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0;
if (SIZE_MAX - overhead < size)
- abort ();
+ emacs_abort ();
if (val
&& check_depth == 1
size_t osize = xmalloc_get_size (val);
if (memcmp (xmalloc_overrun_check_trailer, val + osize,
XMALLOC_OVERRUN_CHECK_SIZE))
- abort ();
+ emacs_abort ();
memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
size_t osize = xmalloc_get_size (val);
if (memcmp (xmalloc_overrun_check_trailer, val + osize,
XMALLOC_OVERRUN_CHECK_SIZE))
- abort ();
+ emacs_abort ();
#ifdef XMALLOC_CLEAR_FREE_MEMORY
val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
return Qnil;
}
+/* Return a newly allocated memory block of SIZE bytes, remembering
+ to free it when unwinding. */
+void *
+record_xmalloc (size_t size)
+{
+ void *p = xmalloc (size);
+ record_unwind_protect (safe_alloca_unwind, make_save_value (p, 0));
+ return p;
+}
+
/* Like malloc but used for allocating Lisp data. NBYTES is the
number of bytes to allocate, TYPE describes the intended use of the
#endif
#ifdef GC_MALLOC_CHECK
-static int dont_register_blocks;
+static bool dont_register_blocks;
#endif
static size_t bytes_used_when_reconsidered;
{
fprintf (stderr,
"Freeing `%p' which wasn't allocated with malloc\n", ptr);
- abort ();
+ emacs_abort ();
}
else
{
fprintf (stderr, "Region in use is %p...%p, %td bytes, type %d\n",
m->start, m->end, (char *) m->end - (char *) m->start,
m->type);
- abort ();
+ emacs_abort ();
}
if (!dont_register_blocks)
fprintf (stderr,
"Realloc of %p which wasn't allocated with malloc\n",
ptr);
- abort ();
+ emacs_abort ();
}
mem_delete (m);
if (m != MEM_NIL)
{
fprintf (stderr, "Realloc returns memory that is already in use\n");
- abort ();
+ emacs_abort ();
}
/* Can't handle zero size regions in the red-black tree. */
/* Index in interval_block above of the next unused interval
structure. */
-static int interval_block_index;
+static int interval_block_index = INTERVAL_BLOCK_SIZE;
/* Number of free and live intervals. */
static INTERVAL interval_free_list;
-
-/* Initialize interval allocation. */
-
-static void
-init_intervals (void)
-{
- interval_block = NULL;
- interval_block_index = INTERVAL_BLOCK_SIZE;
- interval_free_list = 0;
-}
-
-
/* Return a new interval. */
INTERVAL
newi->next = interval_block;
interval_block = newi;
interval_block_index = 0;
+ total_free_intervals += INTERVAL_BLOCK_SIZE;
}
val = &interval_block->intervals[interval_block_index++];
}
consing_since_gc += sizeof (struct interval);
intervals_consed++;
+ total_free_intervals--;
RESET_INTERVAL (val);
val->gcmarkbit = 0;
return val;
static void
mark_interval (register INTERVAL i, Lisp_Object dummy)
{
- eassert (!i->gcmarkbit); /* Intervals are never shared. */
+ /* Intervals should never be shared. So, if extra internal checking is
+ enabled, GC aborts if it seems to have visited an interval twice. */
+ eassert (!i->gcmarkbit);
i->gcmarkbit = 1;
mark_object (i->plist);
}
-
-/* Mark the interval tree rooted in TREE. Don't call this directly;
- use the macro MARK_INTERVAL_TREE instead. */
-
-static void
-mark_interval_tree (register INTERVAL tree)
-{
- /* No need to test if this tree has been marked already; this
- function is always called through the MARK_INTERVAL_TREE macro,
- which takes care of that. */
-
- traverse_intervals_noorder (tree, mark_interval, Qnil);
-}
-
-
/* Mark the interval tree rooted in I. */
-#define MARK_INTERVAL_TREE(i) \
- do { \
- if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
- mark_interval_tree (i); \
+#define MARK_INTERVAL_TREE(i) \
+ do { \
+ if (i && !i->gcmarkbit) \
+ traverse_intervals_noorder (i, mark_interval, Qnil); \
} while (0)
-
-#define UNMARK_BALANCE_INTERVALS(i) \
- do { \
- if (! NULL_INTERVAL_P (i)) \
- (i) = balance_intervals (i); \
- } while (0)
-\f
/***********************************************************************
String Allocation
***********************************************************************/
/* Number of bytes used by live strings. */
-static EMACS_INT total_string_size;
+static EMACS_INT total_string_bytes;
/* Given a pointer to a Lisp_String S which is on the free-list
string_free_list, return a pointer to its successor in the
STRING_BYTES_BOUND, nor can it be so long that the size_t
arithmetic in allocate_string_data would overflow while it is
calculating a value to be passed to malloc. */
-#define STRING_BYTES_MAX \
- min (STRING_BYTES_BOUND, \
- ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD \
- - GC_STRING_EXTRA \
- - offsetof (struct sblock, first_data) \
- - SDATA_DATA_OFFSET) \
- & ~(sizeof (EMACS_INT) - 1)))
+static ptrdiff_t const STRING_BYTES_MAX =
+ min (STRING_BYTES_BOUND,
+ ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD
+ - GC_STRING_EXTRA
+ - offsetof (struct sblock, first_data)
+ - SDATA_DATA_OFFSET)
+ & ~(sizeof (EMACS_INT) - 1)));
/* Initialize string allocation. Called from init_alloc_once. */
static void
init_strings (void)
{
- total_strings = total_free_strings = total_string_size = 0;
- oldest_sblock = current_sblock = large_sblocks = NULL;
- string_blocks = NULL;
- string_free_list = NULL;
empty_unibyte_string = make_pure_string ("", 0, 0, 0);
empty_multibyte_string = make_pure_string ("", 0, 0, 1);
}
static int check_string_bytes_count;
-#define CHECK_STRING_BYTES(S) STRING_BYTES (S)
-
-
-/* Like GC_STRING_BYTES, but with debugging check. */
+/* Like STRING_BYTES, but with debugging check. Can be
+ called during GC, so pay attention to the mark bit. */
ptrdiff_t
string_bytes (struct Lisp_String *s)
if (!PURE_POINTER_P (s)
&& s->data
&& nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
- abort ();
+ emacs_abort ();
return nbytes;
}
/* Check that the string size recorded in the string is the
same as the one recorded in the sdata structure. */
- if (from->string)
- CHECK_STRING_BYTES (from->string);
-
- if (from->string)
- nbytes = GC_STRING_BYTES (from->string);
- else
- nbytes = SDATA_NBYTES (from);
-
- nbytes = SDATA_SIZE (nbytes);
+ nbytes = SDATA_SIZE (from->string ? string_bytes (from->string)
+ : SDATA_NBYTES (from));
from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
}
}
/* Check validity of Lisp strings' string_bytes member. ALL_P
- non-zero means check all strings, otherwise check only most
+ means check all strings, otherwise check only most
recently allocated strings. Used for hunting a bug. */
static void
-check_string_bytes (int all_p)
+check_string_bytes (bool all_p)
{
if (all_p)
{
{
struct Lisp_String *s = b->first_data.string;
if (s)
- CHECK_STRING_BYTES (s);
+ string_bytes (s);
}
for (b = oldest_sblock; b; b = b->next)
check_sblock (current_sblock);
}
+#else /* not GC_CHECK_STRING_BYTES */
+
+#define check_string_bytes(all) ((void) 0)
+
#endif /* GC_CHECK_STRING_BYTES */
#ifdef GC_CHECK_STRING_FREE_LIST
while (s != NULL)
{
if ((uintptr_t) s < 1024)
- abort ();
+ emacs_abort ();
s = NEXT_FREE_LISP_STRING (s);
}
}
allocate_string_data (struct Lisp_String *s,
EMACS_INT nchars, EMACS_INT nbytes)
{
- struct sdata *data;
+ struct sdata *data, *old_data;
struct sblock *b;
- ptrdiff_t needed;
+ ptrdiff_t needed, old_nbytes;
if (STRING_BYTES_MAX < nbytes)
string_overflow ();
/* Determine the number of bytes needed to store NBYTES bytes
of string data. */
needed = SDATA_SIZE (nbytes);
+ if (s->data)
+ {
+ old_data = SDATA_OF_STRING (s);
+ old_nbytes = STRING_BYTES (s);
+ }
+ else
+ old_data = NULL;
MALLOC_BLOCK_INPUT;
memcpy ((char *) data + needed, string_overrun_cookie,
GC_STRING_OVERRUN_COOKIE_SIZE);
#endif
+
+ /* Note that Faset may call to this function when S has already data
+ assigned. In this case, mark data as free by setting it's string
+ back-pointer to null, and record the size of the data in it. */
+ if (old_data)
+ {
+ SDATA_NBYTES (old_data) = old_nbytes;
+ old_data->string = NULL;
+ }
+
consing_since_gc += needed;
}
string_free_list = NULL;
total_strings = total_free_strings = 0;
- total_string_size = 0;
+ total_string_bytes = 0;
/* Scan strings_blocks, free Lisp_Strings that aren't marked. */
for (b = string_blocks; b; b = next)
/* String is live; unmark it and its intervals. */
UNMARK_STRING (s);
- if (!NULL_INTERVAL_P (s->intervals))
- UNMARK_BALANCE_INTERVALS (s->intervals);
+ /* Do not use string_(set|get)_intervals here. */
+ s->intervals = balance_intervals (s->intervals);
++total_strings;
- total_string_size += STRING_BYTES (s);
+ total_string_bytes += STRING_BYTES (s);
}
else
{
how large that is. Reset the sdata's string
back-pointer so that we know it's free. */
#ifdef GC_CHECK_STRING_BYTES
- if (GC_STRING_BYTES (s) != SDATA_NBYTES (data))
- abort ();
+ if (string_bytes (s) != SDATA_NBYTES (data))
+ emacs_abort ();
#else
- data->u.nbytes = GC_STRING_BYTES (s);
+ data->u.nbytes = STRING_BYTES (s);
#endif
data->string = NULL;
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
ptrdiff_t nbytes;
+ struct Lisp_String *s = from->string;
#ifdef GC_CHECK_STRING_BYTES
/* Check that the string size recorded in the string is the
same as the one recorded in the sdata structure. */
- if (from->string
- && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
- abort ();
+ if (s && string_bytes (s) != SDATA_NBYTES (from))
+ emacs_abort ();
#endif /* GC_CHECK_STRING_BYTES */
- if (from->string)
- nbytes = GC_STRING_BYTES (from->string);
- else
- nbytes = SDATA_NBYTES (from);
-
- if (nbytes > LARGE_STRING_BYTES)
- abort ();
+ nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from);
+ eassert (nbytes <= LARGE_STRING_BYTES);
nbytes = SDATA_SIZE (nbytes);
from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
if (memcmp (string_overrun_cookie,
(char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
GC_STRING_OVERRUN_COOKIE_SIZE))
- abort ();
+ emacs_abort ();
#endif
- /* FROM->string non-null means it's alive. Copy its data. */
- if (from->string)
+ /* Non-NULL S means it's alive. Copy its data. */
+ if (s)
{
/* If TB is full, proceed with the next sblock. */
to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
ptrdiff_t length_in_chars;
EMACS_INT length_in_elts;
int bits_per_value;
+ int extra_bool_elts = ((bool_header_size - header_size + word_size - 1)
+ / word_size);
CHECK_NATNUM (length);
length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
- /* We must allocate one more elements than LENGTH_IN_ELTS for the
- slot `size' of the struct Lisp_Bool_Vector. */
- val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
+ val = Fmake_vector (make_number (length_in_elts + extra_bool_elts), Qnil);
/* No Lisp_Object to trace in there. */
XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0);
/* Clear any extraneous bits in the last byte. */
p->data[length_in_chars - 1]
- &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
+ &= (1 << ((XFASTINT (length) - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1)) - 1;
}
return val;
Lisp_Object
make_specified_string (const char *contents,
- ptrdiff_t nchars, ptrdiff_t nbytes, int multibyte)
+ ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
{
- register Lisp_Object val;
+ Lisp_Object val;
if (nchars < 0)
{
struct Lisp_String *s;
if (nchars < 0)
- abort ();
+ emacs_abort ();
if (!nbytes)
return empty_multibyte_string;
s = allocate_string ();
- s->intervals = NULL_INTERVAL;
+ s->intervals = NULL;
allocate_string_data (s, nchars, nbytes);
XSETSTRING (string, s);
string_chars_consed += nbytes;
/* Index of first unused Lisp_Float in the current float_block. */
-static int float_block_index;
+static int float_block_index = FLOAT_BLOCK_SIZE;
/* Free-list of Lisp_Floats. */
static struct Lisp_Float *float_free_list;
-
-/* Initialize float allocation. */
-
-static void
-init_float (void)
-{
- float_block = NULL;
- float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
- float_free_list = 0;
-}
-
-
/* Return a new float object with value FLOAT_VALUE. */
Lisp_Object
memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
float_block = new;
float_block_index = 0;
+ total_free_floats += FLOAT_BLOCK_SIZE;
}
XSETFLOAT (val, &float_block->floats[float_block_index]);
float_block_index++;
eassert (!FLOAT_MARKED_P (XFLOAT (val)));
consing_since_gc += sizeof (struct Lisp_Float);
floats_consed++;
+ total_free_floats--;
return val;
}
/* Index of first unused Lisp_Cons in the current block. */
-static int cons_block_index;
+static int cons_block_index = CONS_BLOCK_SIZE;
/* Free-list of Lisp_Cons structures. */
static struct Lisp_Cons *cons_free_list;
-
-/* Initialize cons allocation. */
-
-static void
-init_cons (void)
-{
- cons_block = NULL;
- cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block. */
- cons_free_list = 0;
-}
-
-
/* Explicitly free a cons cell by putting it on the free-list. */
void
ptr->car = Vdead;
#endif
cons_free_list = ptr;
+ consing_since_gc -= sizeof *ptr;
+ total_free_conses++;
}
DEFUN ("cons", Fcons, Scons, 2, 2, 0,
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
+ total_free_conses += CONS_BLOCK_SIZE;
}
XSETCONS (val, &cons_block->conses[cons_block_index]);
cons_block_index++;
XSETCDR (val, cdr);
eassert (!CONS_MARKED_P (XCONS (val)));
consing_since_gc += sizeof (struct Lisp_Cons);
+ total_free_conses--;
cons_cells_consed++;
return val;
}
Fcons (arg5, Qnil)))));
}
+/* Make a list of COUNT Lisp_Objects, where ARG is the
+ first one. Allocate conses from pure space if TYPE
+ is CONSTYPE_PURE, or allocate as usual if type is CONSTYPE_HEAP. */
+
+Lisp_Object
+listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...)
+{
+ va_list ap;
+ ptrdiff_t i;
+ Lisp_Object val, *objp;
+
+ /* Change to SAFE_ALLOCA if you hit this eassert. */
+ eassert (count <= MAX_ALLOCA / word_size);
+
+ objp = alloca (count * word_size);
+ objp[0] = arg;
+ va_start (ap, arg);
+ for (i = 1; i < count; i++)
+ objp[i] = va_arg (ap, Lisp_Object);
+ va_end (ap);
+
+ for (val = Qnil, i = count - 1; i >= 0; i--)
+ {
+ if (type == CONSTYPE_PURE)
+ val = pure_cons (objp[i], val);
+ else if (type == CONSTYPE_HEAP)
+ val = Fcons (objp[i], val);
+ else
+ emacs_abort ();
+ }
+ return val;
+}
DEFUN ("list", Flist, Slist, 0, MANY, 0,
doc: /* Return a newly created list with specified arguments as elements.
#define VECTOR_BLOCK_SIZE 4096
-/* Handy constants for vectorlike objects. */
+/* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
enum
{
- header_size = offsetof (struct Lisp_Vector, contents),
- word_size = sizeof (Lisp_Object),
- roundup_size = COMMON_MULTIPLE (sizeof (Lisp_Object),
- USE_LSB_TAG ? 1 << GCTYPEBITS : 1)
+ roundup_size = COMMON_MULTIPLE (word_size, USE_LSB_TAG ? GCALIGNMENT : 1)
};
/* ROUNDUP_SIZE must be a power of 2. */
/* Size of the largest vector allocated from block. */
#define VBLOCK_BYTES_MAX \
- vroundup ((VECTOR_BLOCK_BYTES / 2) - sizeof (Lisp_Object))
+ vroundup ((VECTOR_BLOCK_BYTES / 2) - word_size)
/* We maintain one free list for each possible block-allocated
vector size, and this is the number of free lists we have. */
eassert ((index) < VECTOR_MAX_FREE_LIST_INDEX); \
(v)->header.next.vector = vector_free_lists[index]; \
vector_free_lists[index] = (v); \
+ total_free_vector_slots += (nbytes) / word_size; \
} while (0)
struct vector_block
/* The only vector with 0 slots, allocated from pure space. */
-static struct Lisp_Vector *zero_vector;
+Lisp_Object zero_vector;
+
+/* Number of live vectors. */
+
+static EMACS_INT total_vectors;
+
+/* Total size of live and free vectors, in Lisp_Object units. */
+
+static EMACS_INT total_vector_slots, total_free_vector_slots;
/* Get a new vector block. */
static void
init_vectors (void)
{
- zero_vector = pure_alloc (header_size, Lisp_Vectorlike);
- zero_vector->header.size = 0;
+ zero_vector = make_pure_vector (0);
}
/* Allocate vector from a vector block. */
vector = vector_free_lists[index];
vector_free_lists[index] = vector->header.next.vector;
vector->header.next.nbytes = nbytes;
+ total_free_vector_slots -= nbytes / word_size;
return vector;
}
vector = vector_free_lists[index];
vector_free_lists[index] = vector->header.next.vector;
vector->header.next.nbytes = nbytes;
+ total_free_vector_slots -= nbytes / word_size;
/* Excess bytes are used for the smaller vector,
which should be set on an appropriate free list. */
return vector;
}
-/* Return how many Lisp_Objects can be stored in V. */
-
-#define VECTOR_SIZE(v) ((v)->header.size & PSEUDOVECTOR_FLAG ? \
- (PSEUDOVECTOR_SIZE_MASK & (v)->header.size) : \
- (v)->header.size)
-
/* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
#define VECTOR_IN_BLOCK(vector, block) \
struct vector_block *block = vector_blocks, **bprev = &vector_blocks;
struct Lisp_Vector *vector, *next, **vprev = &large_vectors;
- total_vector_size = 0;
+ total_vectors = total_vector_slots = total_free_vector_slots = 0;
memset (vector_free_lists, 0, sizeof (vector_free_lists));
/* Looking through vector blocks. */
for (block = vector_blocks; block; block = *bprev)
{
- int free_this_block = 0;
+ bool free_this_block = 0;
for (vector = (struct Lisp_Vector *) block->data;
VECTOR_IN_BLOCK (vector, block); vector = next)
if (VECTOR_MARKED_P (vector))
{
VECTOR_UNMARK (vector);
- total_vector_size += VECTOR_SIZE (vector);
+ total_vectors++;
+ total_vector_slots += vector->header.next.nbytes / word_size;
next = ADVANCE (vector, vector->header.next.nbytes);
}
else
if (VECTOR_MARKED_P (vector))
{
VECTOR_UNMARK (vector);
- total_vector_size += VECTOR_SIZE (vector);
+ total_vectors++;
+ if (vector->header.size & PSEUDOVECTOR_FLAG)
+ {
+ struct Lisp_Bool_Vector *b = (struct Lisp_Bool_Vector *) vector;
+
+ /* All non-bool pseudovectors are small enough to be allocated
+ from vector blocks. This code should be redesigned if some
+ pseudovector type grows beyond VBLOCK_BYTES_MAX. */
+ eassert (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_BOOL_VECTOR));
+
+ total_vector_slots
+ += (bool_header_size
+ + ((b->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
+ / BOOL_VECTOR_BITS_PER_CHAR)) / word_size;
+ }
+ else
+ total_vector_slots
+ += header_size / word_size + vector->header.size;
vprev = &vector->header.next.vector;
}
else
/* eassert (!handling_signal); */
if (len == 0)
- p = zero_vector;
+ p = XVECTOR (zero_vector);
else
{
size_t nbytes = header_size + len * word_size;
XSETPVECTYPESIZE (b, PVEC_BUFFER, (offsetof (struct buffer, own_text)
- header_size) / word_size);
- /* Note that the fields of B are not initialized. */
+ /* Put B on the chain of all buffers including killed ones. */
+ b->header.next.buffer = all_buffers;
+ all_buffers = b;
+ /* Note that the rest fields of B are not initialized. */
return b;
}
{
struct Lisp_Symbol s;
#if USE_LSB_TAG
- unsigned char c[(sizeof (struct Lisp_Symbol) + (1 << GCTYPEBITS) - 1)
- & -(1 << GCTYPEBITS)];
+ unsigned char c[(sizeof (struct Lisp_Symbol) + GCALIGNMENT - 1)
+ & -GCALIGNMENT];
#endif
};
structure in it. */
static struct symbol_block *symbol_block;
-static int symbol_block_index;
+static int symbol_block_index = SYMBOL_BLOCK_SIZE;
/* List of free symbols. */
static struct Lisp_Symbol *symbol_free_list;
-
-/* Initialize symbol allocation. */
-
-static void
-init_symbol (void)
-{
- symbol_block = NULL;
- symbol_block_index = SYMBOL_BLOCK_SIZE;
- symbol_free_list = 0;
-}
-
-
DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
doc: /* Return a newly allocated uninterned symbol whose name is NAME.
Its value and function definition are void, and its property list is nil. */)
new->next = symbol_block;
symbol_block = new;
symbol_block_index = 0;
+ total_free_symbols += SYMBOL_BLOCK_SIZE;
}
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index].s);
symbol_block_index++;
MALLOC_UNBLOCK_INPUT;
p = XSYMBOL (val);
- p->xname = name;
- p->plist = Qnil;
+ set_symbol_name (val, name);
+ set_symbol_plist (val, Qnil);
p->redirect = SYMBOL_PLAINVAL;
SET_SYMBOL_VAL (p, Qunbound);
- p->function = Qunbound;
- p->next = NULL;
+ set_symbol_function (val, Qunbound);
+ set_symbol_next (val, NULL);
p->gcmarkbit = 0;
p->interned = SYMBOL_UNINTERNED;
p->constant = 0;
p->declared_special = 0;
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
+ total_free_symbols--;
return val;
}
{
union Lisp_Misc m;
#if USE_LSB_TAG
- unsigned char c[(sizeof (union Lisp_Misc) + (1 << GCTYPEBITS) - 1)
- & -(1 << GCTYPEBITS)];
+ unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1)
+ & -GCALIGNMENT];
#endif
};
};
static struct marker_block *marker_block;
-static int marker_block_index;
+static int marker_block_index = MARKER_BLOCK_SIZE;
static union Lisp_Misc *marker_free_list;
-static void
-init_marker (void)
-{
- marker_block = NULL;
- marker_block_index = MARKER_BLOCK_SIZE;
- marker_free_list = 0;
-}
+/* Return a newly allocated Lisp_Misc object of specified TYPE. */
-/* Return a newly allocated Lisp_Misc object, with no substructure. */
-
-Lisp_Object
-allocate_misc (void)
+static Lisp_Object
+allocate_misc (enum Lisp_Misc_Type type)
{
Lisp_Object val;
--total_free_markers;
consing_since_gc += sizeof (union Lisp_Misc);
misc_objects_consed++;
+ XMISCTYPE (val) = type;
XMISCANY (val)->gcmarkbit = 0;
return val;
}
XMISCTYPE (misc) = Lisp_Misc_Free;
XMISC (misc)->u_free.chain = marker_free_list;
marker_free_list = XMISC (misc);
-
+ consing_since_gc -= sizeof (union Lisp_Misc);
total_free_markers++;
}
register Lisp_Object val;
register struct Lisp_Save_Value *p;
- val = allocate_misc ();
- XMISCTYPE (val) = Lisp_Misc_Save_Value;
+ val = allocate_misc (Lisp_Misc_Save_Value);
p = XSAVE_VALUE (val);
p->pointer = pointer;
p->integer = integer;
return val;
}
+/* Return a Lisp_Misc_Overlay object with specified START, END and PLIST. */
+
+Lisp_Object
+build_overlay (Lisp_Object start, Lisp_Object end, Lisp_Object plist)
+{
+ register Lisp_Object overlay;
+
+ overlay = allocate_misc (Lisp_Misc_Overlay);
+ OVERLAY_START (overlay) = start;
+ OVERLAY_END (overlay) = end;
+ set_overlay_plist (overlay, plist);
+ XOVERLAY (overlay)->next = NULL;
+ return overlay;
+}
+
DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
doc: /* Return a newly allocated marker which does not point at any place. */)
(void)
register Lisp_Object val;
register struct Lisp_Marker *p;
- val = allocate_misc ();
- XMISCTYPE (val) = Lisp_Misc_Marker;
+ val = allocate_misc (Lisp_Misc_Marker);
p = XMARKER (val);
p->buffer = 0;
p->bytepos = 0;
struct Lisp_Marker *m;
/* No dead buffers here. */
- eassert (!NILP (BVAR (buf, name)));
+ eassert (BUFFER_LIVE_P (buf));
/* Every character is at least one byte. */
eassert (charpos <= bytepos);
- obj = allocate_misc ();
- XMISCTYPE (obj) = Lisp_Misc_Marker;
+ obj = allocate_misc (Lisp_Misc_Marker);
m = XMARKER (obj);
m->buffer = buf;
m->charpos = charpos;
memory_full (size_t nbytes)
{
/* Do not go into hysterics merely because a large request failed. */
- int enough_free_memory = 0;
+ bool enough_free_memory = 0;
if (SPARE_MEMORY < nbytes)
{
void *p;
spare_memory[0] = malloc (SPARE_MEMORY);
if (spare_memory[1] == 0)
spare_memory[1] = lisp_align_malloc (sizeof (struct cons_block),
- MEM_TYPE_CONS);
+ MEM_TYPE_SPARE);
if (spare_memory[2] == 0)
spare_memory[2] = lisp_align_malloc (sizeof (struct cons_block),
- MEM_TYPE_CONS);
+ MEM_TYPE_SPARE);
if (spare_memory[3] == 0)
spare_memory[3] = lisp_align_malloc (sizeof (struct cons_block),
- MEM_TYPE_CONS);
+ MEM_TYPE_SPARE);
if (spare_memory[4] == 0)
spare_memory[4] = lisp_align_malloc (sizeof (struct cons_block),
- MEM_TYPE_CONS);
+ MEM_TYPE_SPARE);
if (spare_memory[5] == 0)
spare_memory[5] = lisp_malloc (sizeof (struct string_block),
- MEM_TYPE_STRING);
+ MEM_TYPE_SPARE);
if (spare_memory[6] == 0)
spare_memory[6] = lisp_malloc (sizeof (struct string_block),
- MEM_TYPE_STRING);
+ MEM_TYPE_SPARE);
if (spare_memory[0] && spare_memory[1] && spare_memory[5])
Vmemory_full = Qnil;
#endif
while (c != MEM_NIL)
{
if (start >= c->start && start < c->end)
- abort ();
+ emacs_abort ();
parent = c;
c = start < c->start ? c->left : c->right;
}
#ifdef GC_MALLOC_CHECK
x = _malloc_internal (sizeof *x);
if (x == NULL)
- abort ();
+ emacs_abort ();
#else
x = xmalloc (sizeof *x);
#endif
/* Value is non-zero if P is a pointer to a live Lisp string on
the heap. M is a pointer to the mem_block for P. */
-static inline int
+static inline bool
live_string_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_STRING)
/* Value is non-zero if P is a pointer to a live Lisp cons on
the heap. M is a pointer to the mem_block for P. */
-static inline int
+static inline bool
live_cons_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_CONS)
/* Value is non-zero if P is a pointer to a live Lisp symbol on
the heap. M is a pointer to the mem_block for P. */
-static inline int
+static inline bool
live_symbol_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_SYMBOL)
&& offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
&& (b != symbol_block
|| offset / sizeof b->symbols[0] < symbol_block_index)
- && !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
+ && !EQ (((struct Lisp_Symbol *)p)->function, Vdead));
}
else
return 0;
/* Value is non-zero if P is a pointer to a live Lisp float on
the heap. M is a pointer to the mem_block for P. */
-static inline int
+static inline bool
live_float_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_FLOAT)
/* Value is non-zero if P is a pointer to a live Lisp Misc on
the heap. M is a pointer to the mem_block for P. */
-static inline int
+static inline bool
live_misc_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_MISC)
/* Value is non-zero if P is a pointer to a live vector-like object.
M is a pointer to the mem_block for P. */
-static inline int
+static inline bool
live_vector_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_VECTOR_BLOCK)
/* Value is non-zero if P is a pointer to a live buffer. M is a
pointer to the mem_block for P. */
-static inline int
+static inline bool
live_buffer_p (struct mem_node *m, void *p)
{
/* P must point to the start of the block, and the buffer
must not have been killed. */
return (m->type == MEM_TYPE_BUFFER
&& p == m->start
- && !NILP (((struct buffer *) p)->BUFFER_INTERNAL_FIELD (name)));
+ && !NILP (((struct buffer *) p)->INTERNAL_FIELD (name)));
}
#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
if (m != MEM_NIL)
{
- int mark_p = 0;
+ bool mark_p = 0;
switch (XTYPE (obj))
{
struct mem_node *m;
/* Quickly rule out some values which can't point to Lisp data.
- USE_LSB_TAG needs Lisp data to be aligned on multiples of 1 << GCTYPEBITS.
+ USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
Otherwise, assume that Lisp data is aligned on even addresses. */
- if ((intptr_t) p % (USE_LSB_TAG ? 1 << GCTYPEBITS : 2))
+ if ((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2))
return;
m = mem_find (p);
switch (m->type)
{
case MEM_TYPE_NON_LISP:
+ case MEM_TYPE_SPARE:
/* Nothing to do; not a pointer to Lisp memory. */
break;
break;
default:
- abort ();
+ emacs_abort ();
}
if (!NILP (obj))
}
-/* Alignment of pointer values. Use offsetof, as it sometimes returns
+/* Alignment of pointer values. Use alignof, as it sometimes returns
a smaller alignment than GCC's __alignof__ and mark_memory might
miss objects if __alignof__ were used. */
-#define GC_POINTER_ALIGNMENT offsetof (struct {char a; void *b;}, b)
+#define GC_POINTER_ALIGNMENT alignof (void *)
/* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
not suffice, which is the typical case. A host where a Lisp_Object is
static void
mark_memory (void *start, void *end)
-#ifdef __clang__
+#if defined (__clang__) && defined (__has_feature)
+#if __has_feature(address_sanitizer)
/* Do not allow -faddress-sanitizer to check this function, since it
crosses the function stack boundary, and thus would yield many
false positives. */
__attribute__((no_address_safety_analysis))
#endif
+#endif
{
void **pp;
int i;
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
-static int setjmp_tested_p, longjmps_done;
+static bool setjmp_tested_p;
+static int longjmps_done;
#define SETJMP_WILL_LIKELY_WORK "\
\n\
char buf[10];
register int x;
jmp_buf jbuf;
- int result = 0;
/* Arrange for X to be put in a register. */
sprintf (buf, "1");
x = strlen (buf);
x = 2 * x - 1;
- setjmp (jbuf);
+ _setjmp (jbuf);
if (longjmps_done == 1)
{
/* Came here after the longjmp at the end of the function.
++longjmps_done;
x = 2;
if (longjmps_done == 1)
- longjmp (jbuf, 1);
+ _longjmp (jbuf, 1);
}
#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
if (!survives_gc_p (p->var[i]))
/* FIXME: It's not necessarily a bug. It might just be that the
GCPRO is unnecessary or should release the object sooner. */
- abort ();
+ emacs_abort ();
}
#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
Lisp_Object o;
jmp_buf j;
} j;
- volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
+ volatile bool 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. */
}
#endif /* GC_SETJMP_WORKS */
- setjmp (j.j);
+ _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 */
if (pipe (fd) == 0)
{
- int valid = (emacs_write (fd[1], (char *) p, 16) == 16);
+ bool valid = emacs_write (fd[1], (char *) p, 16) == 16;
emacs_close (fd[1]);
emacs_close (fd[0]);
return valid;
#endif
}
-/* Return 1 if OBJ is a valid lisp object.
+/* Return 2 if OBJ is a killed or special buffer object.
+ Return 1 if OBJ is a valid lisp object.
Return 0 if OBJ is NOT a valid lisp object.
Return -1 if we cannot validate OBJ.
This function can be quite slow,
if (PURE_POINTER_P (p))
return 1;
+ if (p == &buffer_defaults || p == &buffer_local_symbols)
+ return 2;
+
#if !GC_MARK_STACK
return valid_pointer_p (p);
#else
switch (m->type)
{
case MEM_TYPE_NON_LISP:
+ case MEM_TYPE_SPARE:
return 0;
case MEM_TYPE_BUFFER:
- return live_buffer_p (m, p);
+ return live_buffer_p (m, p) ? 1 : 2;
case MEM_TYPE_CONS:
return live_cons_p (m, p);
{
void *result;
#if USE_LSB_TAG
- size_t alignment = (1 << GCTYPEBITS);
+ size_t alignment = GCALIGNMENT;
#else
- size_t alignment = sizeof (EMACS_INT);
+ size_t alignment = alignof (EMACS_INT);
/* Give Lisp_Floats an extra alignment. */
if (type == Lisp_Float)
- {
-#if defined __GNUC__ && __GNUC__ >= 2
- alignment = __alignof (struct Lisp_Float);
-#else
- alignment = sizeof (struct Lisp_Float);
-#endif
- }
+ alignment = alignof (struct Lisp_Float);
#endif
again:
/* Return a string allocated in pure space. DATA is a buffer holding
NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
- non-zero means make the result string multibyte.
+ means make the result string multibyte.
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
Lisp_Object
make_pure_string (const char *data,
- ptrdiff_t nchars, ptrdiff_t nbytes, int multibyte)
+ ptrdiff_t nchars, ptrdiff_t nbytes, bool multibyte)
{
Lisp_Object string;
- struct Lisp_String *s;
-
- s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
+ struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
s->data = (unsigned char *) find_string_data_in_pure (data, nbytes);
if (s->data == NULL)
{
- s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
+ s->data = pure_alloc (nbytes + 1, -1);
memcpy (s->data, data, nbytes);
s->data[nbytes] = '\0';
}
s->size = nchars;
s->size_byte = multibyte ? nbytes : -1;
- s->intervals = NULL_INTERVAL;
+ s->intervals = NULL;
XSETSTRING (string, s);
return string;
}
make_pure_c_string (const char *data, ptrdiff_t nchars)
{
Lisp_Object string;
- struct Lisp_String *s;
-
- s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
+ struct Lisp_String *s = pure_alloc (sizeof *s, Lisp_String);
s->size = nchars;
s->size_byte = -1;
s->data = (unsigned char *) data;
- s->intervals = NULL_INTERVAL;
+ s->intervals = NULL;
XSETSTRING (string, s);
return string;
}
Lisp_Object
pure_cons (Lisp_Object car, Lisp_Object cdr)
{
- register Lisp_Object new;
- struct Lisp_Cons *p;
-
- p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
+ Lisp_Object new;
+ struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons);
XSETCONS (new, p);
XSETCAR (new, Fpurecopy (car));
XSETCDR (new, Fpurecopy (cdr));
static Lisp_Object
make_pure_float (double num)
{
- register Lisp_Object new;
- struct Lisp_Float *p;
-
- p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
+ Lisp_Object new;
+ struct Lisp_Float *p = pure_alloc (sizeof *p, Lisp_Float);
XSETFLOAT (new, p);
XFLOAT_INIT (new, num);
return new;
make_pure_vector (ptrdiff_t len)
{
Lisp_Object new;
- struct Lisp_Vector *p;
- size_t size = (offsetof (struct Lisp_Vector, contents)
- + len * sizeof (Lisp_Object));
-
- p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
+ size_t size = header_size + len * word_size;
+ struct Lisp_Vector *p = pure_alloc (size, Lisp_Vectorlike);
XSETVECTOR (new, p);
XVECTOR (new)->header.size = len;
return new;
{
staticvec[staticidx++] = varaddress;
if (staticidx >= NSTATICS)
- abort ();
+ emacs_abort ();
}
\f
return count;
}
+/* Used to avoid possible overflows when
+ converting from C to Lisp integers. */
+
+static inline Lisp_Object
+bounded_number (EMACS_INT number)
+{
+ return make_number (min (MOST_POSITIVE_FIXNUM, number));
+}
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
doc: /* Reclaim storage for Lisp objects no longer needed.
Garbage collection happens automatically if you cons more than
`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
-`garbage-collect' normally returns a list with info on amount of space in use:
- ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
- (USED-MISCS . FREE-MISCS) USED-STRING-CHARS USED-VECTOR-SLOTS
- (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
- (USED-STRINGS . FREE-STRINGS))
+`garbage-collect' normally returns a list with info on amount of space in use,
+where each entry has the form (NAME SIZE USED FREE), where:
+- NAME is a symbol describing the kind of objects this entry represents,
+- SIZE is the number of bytes used by each one,
+- USED is the number of those objects that were found live in the heap,
+- FREE is the number of those objects that are not live but that Emacs
+ keeps around for future allocations (maybe because it does not know how
+ to return them to the OS).
However, if there was overflow in pure space, `garbage-collect'
returns nil, because real GC can't be done.
See Info node `(elisp)Garbage Collection'. */)
(void)
{
- register struct specbinding *bind;
+ struct specbinding *bind;
+ struct buffer *nextb;
char stack_top_variable;
ptrdiff_t i;
- int message_p;
- Lisp_Object total[8];
+ bool message_p;
ptrdiff_t count = SPECPDL_INDEX ();
- EMACS_TIME t1, t2, t3;
+ EMACS_TIME start;
+ Lisp_Object retval = Qnil;
if (abort_on_gc)
- abort ();
+ emacs_abort ();
/* Can't GC if pure storage overflowed because we can't determine
if something is a pure object or not. */
if (pure_bytes_used_before_overflow)
return Qnil;
- CHECK_CONS_LIST ();
+ check_cons_list ();
/* Don't keep undo information around forever.
Do this early on, so it is no problem if the user quits. */
- {
- register struct buffer *nextb = all_buffers;
-
- while (nextb)
- {
- /* If a buffer's undo list is Qt, that means that undo is
- turned off in that buffer. Calling truncate_undo_list on
- Qt tends to return NULL, which effectively turns undo back on.
- So don't call truncate_undo_list if undo_list is Qt. */
- if (! 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->BUFFER_INTERNAL_FIELD (name))
- && ! nextb->text->inhibit_shrinking)
- {
- /* If a buffer's gap size is more than 10% of the buffer
- size, or larger than 2000 bytes, then shrink it
- accordingly. Keep a minimum size of 20 bytes. */
- int size = min (2000, max (20, (nextb->text->z_byte / 10)));
+ FOR_EACH_BUFFER (nextb)
+ compact_buffer (nextb);
- if (nextb->text->gap_size > size)
- {
- struct buffer *save_current = current_buffer;
- current_buffer = nextb;
- make_gap (-(nextb->text->gap_size - size));
- current_buffer = save_current;
- }
- }
-
- nextb = nextb->header.next.buffer;
- }
- }
-
- EMACS_GET_TIME (t1);
+ start = current_emacs_time ();
/* In case user calls debug_print during GC,
don't let that cause a recursive GC. */
gc_in_progress = 1;
- /* clear_marks (); */
-
/* Mark all the special slots that serve as the roots of accessibility. */
+ mark_buffer (&buffer_defaults);
+ mark_buffer (&buffer_local_symbols);
+
for (i = 0; i < staticidx; i++)
mark_object (*staticvec[i]);
}
mark_terminals ();
mark_kboards ();
- mark_ttys ();
#ifdef USE_GTK
- {
- extern void xg_mark_data (void);
- xg_mark_data ();
- }
+ xg_mark_data ();
#endif
#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
Look thru every buffer's undo list
for elements that update markers that were not marked,
and delete them. */
- {
- register struct buffer *nextb = all_buffers;
-
- while (nextb)
- {
- /* If a buffer's undo list is Qt, that means that undo is
- turned off in that buffer. Calling truncate_undo_list on
- Qt tends to return NULL, which effectively turns undo back on.
- So don't call truncate_undo_list if undo_list is Qt. */
- if (! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
- {
- Lisp_Object tail, prev;
- tail = nextb->BUFFER_INTERNAL_FIELD (undo_list);
- prev = Qnil;
- while (CONSP (tail))
- {
- if (CONSP (XCAR (tail))
- && MARKERP (XCAR (XCAR (tail)))
- && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
- {
- if (NILP (prev))
- nextb->BUFFER_INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
- else
- {
- tail = XCDR (tail);
- XSETCDR (prev, tail);
- }
- }
- else
- {
- prev = tail;
- 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->BUFFER_INTERNAL_FIELD (undo_list));
-
- nextb = nextb->header.next.buffer;
- }
- }
+ FOR_EACH_BUFFER (nextb)
+ {
+ /* If a buffer's undo list is Qt, that means that undo is
+ turned off in that buffer. Calling truncate_undo_list on
+ Qt tends to return NULL, which effectively turns undo back on.
+ So don't call truncate_undo_list if undo_list is Qt. */
+ if (! EQ (nextb->INTERNAL_FIELD (undo_list), Qt))
+ {
+ Lisp_Object tail, prev;
+ tail = nextb->INTERNAL_FIELD (undo_list);
+ prev = Qnil;
+ while (CONSP (tail))
+ {
+ if (CONSP (XCAR (tail))
+ && MARKERP (XCAR (XCAR (tail)))
+ && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
+ {
+ if (NILP (prev))
+ nextb->INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
+ else
+ {
+ tail = XCDR (tail);
+ XSETCDR (prev, tail);
+ }
+ }
+ else
+ {
+ prev = tail;
+ 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->INTERNAL_FIELD (undo_list));
+ }
gc_sweep ();
UNBLOCK_INPUT;
- CHECK_CONS_LIST ();
+ check_cons_list ();
- /* clear_marks (); */
gc_in_progress = 0;
consing_since_gc = 0;
- if (gc_cons_threshold < 10000)
- gc_cons_threshold = 10000;
+ if (gc_cons_threshold < GC_DEFAULT_THRESHOLD / 10)
+ gc_cons_threshold = GC_DEFAULT_THRESHOLD / 10;
gc_relative_threshold = 0;
if (FLOATP (Vgc_cons_percentage))
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_string_bytes;
+ tot += total_vector_slots * word_size;
tot += total_floats * sizeof (struct Lisp_Float);
tot += total_intervals * sizeof (struct interval);
tot += total_strings * sizeof (struct Lisp_String);
}
unbind_to (count, Qnil);
+ {
+ Lisp_Object total[11];
+ int total_size = 10;
+
+ total[0] = list4 (Qconses, make_number (sizeof (struct Lisp_Cons)),
+ bounded_number (total_conses),
+ bounded_number (total_free_conses));
+
+ total[1] = list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)),
+ bounded_number (total_symbols),
+ bounded_number (total_free_symbols));
+
+ total[2] = list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)),
+ bounded_number (total_markers),
+ bounded_number (total_free_markers));
+
+ total[3] = list4 (Qstrings, make_number (sizeof (struct Lisp_String)),
+ bounded_number (total_strings),
+ bounded_number (total_free_strings));
+
+ total[4] = list3 (Qstring_bytes, make_number (1),
+ bounded_number (total_string_bytes));
+
+ total[5] = list3 (Qvectors, make_number (sizeof (struct Lisp_Vector)),
+ bounded_number (total_vectors));
- total[0] = Fcons (make_number (total_conses),
- make_number (total_free_conses));
- total[1] = Fcons (make_number (total_symbols),
- make_number (total_free_symbols));
- total[2] = Fcons (make_number (total_markers),
- make_number (total_free_markers));
- total[3] = make_number (total_string_size);
- total[4] = make_number (total_vector_size);
- total[5] = Fcons (make_number (total_floats),
- make_number (total_free_floats));
- total[6] = Fcons (make_number (total_intervals),
- make_number (total_free_intervals));
- total[7] = Fcons (make_number (total_strings),
- make_number (total_free_strings));
+ total[6] = list4 (Qvector_slots, make_number (word_size),
+ bounded_number (total_vector_slots),
+ bounded_number (total_free_vector_slots));
+
+ total[7] = list4 (Qfloats, make_number (sizeof (struct Lisp_Float)),
+ bounded_number (total_floats),
+ bounded_number (total_free_floats));
+
+ total[8] = list4 (Qintervals, make_number (sizeof (struct interval)),
+ bounded_number (total_intervals),
+ bounded_number (total_free_intervals));
+
+ total[9] = list3 (Qbuffers, make_number (sizeof (struct buffer)),
+ bounded_number (total_buffers));
+
+#ifdef DOUG_LEA_MALLOC
+ total_size++;
+ total[10] = list4 (Qheap, make_number (1024),
+ bounded_number ((mallinfo ().uordblks + 1023) >> 10),
+ bounded_number ((mallinfo ().fordblks + 1023) >> 10));
+#endif
+ retval = Flist (total_size, total);
+ }
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
{
/* Compute average percentage of zombies. */
- double nlive = 0;
-
- for (i = 0; i < 7; ++i)
- if (CONSP (total[i]))
- nlive += XFASTINT (XCAR (total[i]));
+ double nlive
+ = (total_conses + total_symbols + total_markers + total_strings
+ + total_vectors + total_floats + total_intervals + total_buffers);
avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
max_live = max (nlive, max_live);
avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
max_zombies = max (nzombies, max_zombies);
++ngcs;
- }
+ }
#endif
if (!NILP (Vpost_gc_hook))
/* Accumulate statistics. */
if (FLOATP (Vgc_elapsed))
{
- EMACS_GET_TIME (t2);
- EMACS_SUB_TIME (t3, t2, t1);
+ EMACS_TIME since_start = sub_emacs_time (current_emacs_time (), start);
Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed)
- + EMACS_TIME_TO_DOUBLE (t3));
+ + EMACS_TIME_TO_DOUBLE (since_start));
}
gcs_done++;
- return Flist (sizeof total / sizeof *total, total);
+ return retval;
}
/* ...but there are some buffer-specific things. */
- MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
+ MARK_INTERVAL_TREE (buffer_intervals (buffer));
/* For now, we just don't mark the undo_list. It's done later in
a special way just before the sweep phase, and after stripping
do { \
m = mem_find (po); \
if (m == MEM_NIL) \
- abort (); \
+ emacs_abort (); \
} while (0)
/* Check that the object pointed to by PO is live, using predicate
#define CHECK_LIVE(LIVEP) \
do { \
if (!LIVEP (m, po)) \
- abort (); \
+ emacs_abort (); \
} while (0)
/* Check both of the above conditions. */
#endif /* not GC_CHECK_MARKED_OBJECTS */
- switch (SWITCH_ENUM_CAST (XTYPE (obj)))
+ switch (XTYPE (obj))
{
case Lisp_String:
{
#ifdef GC_CHECK_STRING_BYTES
/* Check that the string size recorded in the string is the
same as the one recorded in the sdata structure. */
- CHECK_STRING_BYTES (ptr);
+ string_bytes (ptr);
#endif /* GC_CHECK_STRING_BYTES */
}
break;
#ifdef GC_CHECK_MARKED_OBJECTS
m = mem_find (po);
- if (m == MEM_NIL && !SUBRP (obj)
- && po != &buffer_defaults
- && po != &buffer_local_symbols)
- abort ();
+ if (m == MEM_NIL && !SUBRP (obj))
+ emacs_abort ();
#endif /* GC_CHECK_MARKED_OBJECTS */
if (ptr->header.size & PSEUDOVECTOR_FLAG)
{
case PVEC_BUFFER:
#ifdef GC_CHECK_MARKED_OBJECTS
- if (po != &buffer_defaults && po != &buffer_local_symbols)
- {
- struct buffer *b = all_buffers;
- for (; b && b != po; b = b->header.next.buffer)
- ;
- if (b == NULL)
- abort ();
- }
+ {
+ struct buffer *b;
+ FOR_EACH_BUFFER (b)
+ if (b == po)
+ break;
+ if (b == NULL)
+ emacs_abort ();
+ }
#endif /* GC_CHECK_MARKED_OBJECTS */
mark_buffer ((struct buffer *) ptr);
break;
break;
case PVEC_FRAME:
- {
- mark_vectorlike (ptr);
- mark_face_cache (((struct frame *) ptr)->face_cache);
- }
+ mark_vectorlike (ptr);
+ mark_face_cache (((struct frame *) ptr)->face_cache);
break;
case PVEC_WINDOW:
/* Mark glyphs for leaf windows. Marking window
matrices is sufficient because frame matrices
use the same glyph memory. */
- if (NILP (w->hchild) && NILP (w->vchild) && w->current_matrix)
+ if (NILP (w->hchild) && NILP (w->vchild)
+ && w->current_matrix)
{
mark_glyph_matrix (w->current_matrix);
mark_glyph_matrix (w->desired_matrix);
break;
case PVEC_FREE:
- abort ();
+ emacs_abort ();
default:
mark_vectorlike (ptr);
And if it's forwarded to a C variable, either it's not
a Lisp_Object var, or it's staticpro'd already. */
break;
- default: abort ();
+ default: emacs_abort ();
}
- if (!PURE_POINTER_P (XSTRING (ptr->xname)))
- MARK_STRING (XSTRING (ptr->xname));
- MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
+ if (!PURE_POINTER_P (XSTRING (ptr->name)))
+ MARK_STRING (XSTRING (ptr->name));
+ MARK_INTERVAL_TREE (string_intervals (ptr->name));
ptr = ptr->next;
if (ptr)
break;
default:
- abort ();
+ emacs_abort ();
}
break;
obj = ptr->u.cdr;
cdr_count++;
if (cdr_count == mark_object_loop_halt)
- abort ();
+ emacs_abort ();
goto loop;
}
break;
default:
- abort ();
+ emacs_abort ();
}
#undef CHECK_LIVE
/* Value is non-zero if OBJ will survive the current GC because it's
either marked or does not need to be marked to survive. */
-int
+bool
survives_gc_p (Lisp_Object obj)
{
- int survives_p;
+ bool survives_p;
switch (XTYPE (obj))
{
break;
default:
- abort ();
+ emacs_abort ();
}
return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
sweep_weak_hash_tables ();
sweep_strings ();
-#ifdef GC_CHECK_STRING_BYTES
- if (!noninteractive)
- check_string_bytes (1);
-#endif
+ check_string_bytes (!noninteractive);
/* Put all unmarked conses on free list */
{
{
if (!iblk->intervals[i].gcmarkbit)
{
- SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
+ set_interval_parent (&iblk->intervals[i], interval_free_list);
interval_free_list = &iblk->intervals[i];
this_free++;
}
/* Check if the symbol was created during loadup. In such a case
it might be pointed to by pure bytecode which we don't trace,
so we conservatively assume that it is live. */
- int pure_p = PURE_POINTER_P (XSTRING (sym->s.xname));
+ bool pure_p = PURE_POINTER_P (XSTRING (sym->s.name));
if (!sym->s.gcmarkbit && !pure_p)
{
{
++num_used;
if (!pure_p)
- UNMARK_STRING (XSTRING (sym->s.xname));
+ UNMARK_STRING (XSTRING (sym->s.name));
sym->s.gcmarkbit = 0;
}
}
{
register struct buffer *buffer = all_buffers, *prev = 0, *next;
+ total_buffers = 0;
while (buffer)
if (!VECTOR_MARKED_P (buffer))
{
else
{
VECTOR_UNMARK (buffer);
- UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
+ /* Do not use buffer_(set|get)_intervals here. */
+ buffer->text->intervals = balance_intervals (buffer->text->intervals);
+ total_buffers++;
prev = buffer, buffer = buffer->header.next.buffer;
}
}
sweep_vectors ();
-
-#ifdef GC_CHECK_STRING_BYTES
- if (!noninteractive)
- check_string_bytes (1);
-#endif
+ check_string_bytes (!noninteractive);
}
(but the contents of a buffer's text do not count here). */)
(void)
{
- Lisp_Object consed[8];
-
- consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed));
- consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed));
- consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed));
- consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed));
- consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed));
- consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed));
- consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed));
- consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
-
- return Flist (8, consed);
+ return listn (CONSTYPE_HEAP, 8,
+ bounded_number (cons_cells_consed),
+ bounded_number (floats_consed),
+ bounded_number (vector_cells_consed),
+ bounded_number (symbols_consed),
+ bounded_number (string_chars_consed),
+ bounded_number (misc_objects_consed),
+ bounded_number (intervals_consed),
+ bounded_number (strings_consed));
}
/* Find at most FIND_MAX symbols which have OBJ as their value or
}
#ifdef ENABLE_CHECKING
-int suppress_checking;
+
+bool suppress_checking;
void
die (const char *msg, const char *file, int line)
{
fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
file, line, msg);
- abort ();
+ fatal_error_backtrace (SIGABRT, INT_MAX);
}
#endif
\f
/* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
purebeg = PUREBEG;
pure_size = PURESIZE;
- pure_bytes_used = 0;
- pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
- pure_bytes_used_before_overflow = 0;
-
- /* Initialize the list of free aligned blocks. */
- free_ablock = NULL;
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
mem_init ();
Vdead = make_pure_string ("DEAD", 4, 4, 0);
#endif
- ignore_warnings = 1;
#ifdef DOUG_LEA_MALLOC
mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
#endif
init_strings ();
- init_cons ();
- init_symbol ();
- init_marker ();
- init_float ();
- init_intervals ();
init_vectors ();
- init_weak_hash_tables ();
#ifdef REL_ALLOC
malloc_hysteresis = 32;
#endif
refill_memory_reserve ();
-
- ignore_warnings = 0;
- gcprolist = 0;
- byte_stack_list = 0;
- staticidx = 0;
- consing_since_gc = 0;
- gc_cons_threshold = 100000 * sizeof (Lisp_Object);
- gc_relative_threshold = 0;
+ gc_cons_threshold = GC_DEFAULT_THRESHOLD;
}
void
/* 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. */
Vmemory_signal_data
- = pure_cons (Qerror,
- pure_cons (build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil));
+ = listn (CONSTYPE_PURE, 2, Qerror,
+ build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
DEFVAR_LISP ("memory-full", Vmemory_full,
doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
Vmemory_full = Qnil;
+ DEFSYM (Qconses, "conses");
+ DEFSYM (Qsymbols, "symbols");
+ DEFSYM (Qmiscs, "miscs");
+ DEFSYM (Qstrings, "strings");
+ DEFSYM (Qvectors, "vectors");
+ DEFSYM (Qfloats, "floats");
+ DEFSYM (Qintervals, "intervals");
+ DEFSYM (Qbuffers, "buffers");
+ DEFSYM (Qstring_bytes, "string-bytes");
+ DEFSYM (Qvector_slots, "vector-slots");
+ DEFSYM (Qheap, "heap");
+
DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
defsubr (&Sgc_status);
#endif
}
+
+/* When compiled with GCC, GDB might say "No enum type named
+ pvec_type" if we don't have at least one symbol with that type, and
+ then xbacktrace could fail. Similarly for the other enums and
+ their values. */
+union
+{
+ enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS;
+ enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS;
+ enum char_bits char_bits;
+ enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE;
+ enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE;
+ enum enum_USE_LSB_TAG enum_USE_LSB_TAG;
+ enum FLOAT_TO_STRING_BUFSIZE FLOAT_TO_STRING_BUFSIZE;
+ enum Lisp_Bits Lisp_Bits;
+ enum Lisp_Compiled Lisp_Compiled;
+ enum maxargs maxargs;
+ enum MAX_ALLOCA MAX_ALLOCA;
+ enum More_Lisp_Bits More_Lisp_Bits;
+ enum pvec_type pvec_type;
+#if USE_LSB_TAG
+ enum lsb_bits lsb_bits;
+#endif
+} const EXTERNALLY_VISIBLE gdb_make_enums_visible = {0};
HCoop / bpt / emacs.git / blobdiff