/* Storage allocation and gc for GNU Emacs Lisp interpreter.
-Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
+Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2016 Free Software
Foundation, Inc.
This file is part of GNU Emacs.
#endif
#include "lisp.h"
-#include "process.h"
+#include "dispextern.h"
#include "intervals.h"
#include "puresize.h"
+#include "systime.h"
#include "character.h"
#include "buffer.h"
#include "window.h"
static bool valgrind_p;
#endif
-/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
- Doable only if GC_MARK_STACK. */
-#if ! GC_MARK_STACK
-# undef GC_CHECK_MARKED_OBJECTS
-#endif
+/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects. */
/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
memory. Can do this only if using gmalloc.c and if not checking
static ptrdiff_t pure_bytes_used_before_overflow;
-/* 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.. */
static ptrdiff_t pure_bytes_used_lisp;
#endif /* MAX_SAVE_STACK > 0 */
-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 Qautomatic_gc;
-Lisp_Object Qchar_table_extra_slots;
-
-/* Hook run after GC has finished. */
-
-static Lisp_Object Qpost_gc_hook;
-
static void mark_terminals (void);
static void gc_sweep (void);
static Lisp_Object make_pure_vector (ptrdiff_t);
MEM_TYPE_SPARE
};
-#if GC_MARK_STACK || defined GC_MALLOC_CHECK
-
/* A unique object in pure space used to make some Lisp objects
on free lists recognizable in O(1). */
static void mem_delete_fixup (struct mem_node *);
static struct mem_node *mem_find (void *);
-#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
-
#ifndef DEADP
# define DEADP(x) 0
#endif
-/* Recording what needs to be marked for gc. */
-
-struct gcpro *gcprolist;
-
/* Addresses of staticpro'd variables. Initialize it to a nonzero
value; otherwise some compilers put it into BSS. */
return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
}
+/* Extract the pointer hidden within A, if A is not a symbol.
+ If A is a symbol, extract the hidden pointer's offset from lispsym,
+ converted to void *. */
+
+#define macro_XPNTR_OR_SYMBOL_OFFSET(a) \
+ ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK))
+
+/* Extract the pointer hidden within A. */
+
+#define macro_XPNTR(a) \
+ ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \
+ + (SYMBOLP (a) ? (char *) lispsym : NULL)))
+
+/* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as
+ functions, as functions are cleaner and can be used in debuggers.
+ Also, define them as macros if being compiled with GCC without
+ optimization, for performance in that case. The macro_* names are
+ private to this section of code. */
+
+static ATTRIBUTE_UNUSED void *
+XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a)
+{
+ return macro_XPNTR_OR_SYMBOL_OFFSET (a);
+}
+static ATTRIBUTE_UNUSED void *
+XPNTR (Lisp_Object a)
+{
+ return macro_XPNTR (a);
+}
+
+#if DEFINE_KEY_OPS_AS_MACROS
+# define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a)
+# define XPNTR(a) macro_XPNTR (a)
+#endif
+
static void
XFLOAT_INIT (Lisp_Object f, double n)
{
XFLOAT (f)->u.data = n;
}
+#ifdef DOUG_LEA_MALLOC
static bool
pointers_fit_in_lispobj_p (void)
{
/* If we can't store all memory addresses in our lisp objects, it's
risky to let the heap use mmap and give us addresses from all
over our address space. We also can't use mmap for lisp objects
- if we might dump: unexec doesn't preserve the contents of mmaped
+ if we might dump: unexec doesn't preserve the contents of mmapped
regions. */
return pointers_fit_in_lispobj_p () && !might_dump;
}
+#endif
+
+/* Head of a circularly-linked list of extant finalizers. */
+static struct Lisp_Finalizer finalizers;
+
+/* Head of a circularly-linked list of finalizers that must be invoked
+ because we deemed them unreachable. This list must be global, and
+ not a local inside garbage_collect_1, in case we GC again while
+ running finalizers. */
+static struct Lisp_Finalizer doomed_finalizers;
\f
/************************************************************************
/* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
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 \
- alignof (union { long double d; intmax_t i; void *p; })
+#define XMALLOC_BASE_ALIGNMENT alignof (max_align_t)
-#if USE_LSB_TAG
-# define XMALLOC_HEADER_ALIGNMENT \
- COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
-#else
-# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
-#endif
+#define XMALLOC_HEADER_ALIGNMENT \
+ COMMON_MULTIPLE (GCALIGNMENT, XMALLOC_BASE_ALIGNMENT)
#define XMALLOC_OVERRUN_SIZE_SIZE \
(((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
+ XMALLOC_HEADER_ALIGNMENT - 1) \
xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
{
eassert (0 <= nitems && 0 < item_size);
- if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
+ ptrdiff_t nbytes;
+ if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
memory_full (SIZE_MAX);
- return xmalloc (nitems * item_size);
+ return xmalloc (nbytes);
}
xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
{
eassert (0 <= nitems && 0 < item_size);
- if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
+ ptrdiff_t nbytes;
+ if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes)
memory_full (SIZE_MAX);
- return xrealloc (pa, nitems * item_size);
+ return xrealloc (pa, nbytes);
}
xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
ptrdiff_t nitems_max, ptrdiff_t item_size)
{
+ ptrdiff_t n0 = *nitems;
+ eassume (0 < item_size && 0 < nitems_incr_min && 0 <= n0 && -1 <= nitems_max);
+
/* The approximate size to use for initial small allocation
requests. This is the largest "small" request for the GNU C
library malloc. */
enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 };
/* If the array is tiny, grow it to about (but no greater than)
- DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
- ptrdiff_t n = *nitems;
- ptrdiff_t tiny_max = DEFAULT_MXFAST / item_size - n;
- ptrdiff_t half_again = n >> 1;
- ptrdiff_t incr_estimate = max (tiny_max, half_again);
-
- /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
+ DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%.
+ Adjust the growth according to three constraints: NITEMS_INCR_MIN,
NITEMS_MAX, and what the C language can represent safely. */
- ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / item_size;
- ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
- ? nitems_max : C_language_max);
- ptrdiff_t nitems_incr_max = n_max - n;
- ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max));
- eassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max);
+ ptrdiff_t n, nbytes;
+ if (INT_ADD_WRAPV (n0, n0 >> 1, &n))
+ n = PTRDIFF_MAX;
+ if (0 <= nitems_max && nitems_max < n)
+ n = nitems_max;
+
+ ptrdiff_t adjusted_nbytes
+ = ((INT_MULTIPLY_WRAPV (n, item_size, &nbytes) || SIZE_MAX < nbytes)
+ ? min (PTRDIFF_MAX, SIZE_MAX)
+ : nbytes < DEFAULT_MXFAST ? DEFAULT_MXFAST : 0);
+ if (adjusted_nbytes)
+ {
+ n = adjusted_nbytes / item_size;
+ nbytes = adjusted_nbytes - adjusted_nbytes % item_size;
+ }
+
if (! pa)
*nitems = 0;
- if (nitems_incr_max < incr)
+ if (n - n0 < nitems_incr_min
+ && (INT_ADD_WRAPV (n0, nitems_incr_min, &n)
+ || (0 <= nitems_max && nitems_max < n)
+ || INT_MULTIPLY_WRAPV (n, item_size, &nbytes)))
memory_full (SIZE_MAX);
- n += incr;
- pa = xrealloc (pa, n * item_size);
+ pa = xrealloc (pa, nbytes);
*nitems = n;
return pa;
}
}
#endif
-#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+#ifndef GC_MALLOC_CHECK
if (val && type != MEM_TYPE_NON_LISP)
mem_insert (val, (char *) val + nbytes, type);
#endif
{
MALLOC_BLOCK_INPUT;
free (block);
-#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+#ifndef GC_MALLOC_CHECK
mem_delete (mem_find (block));
#endif
MALLOC_UNBLOCK_INPUT;
val = free_ablock;
free_ablock = free_ablock->x.next_free;
-#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+#ifndef GC_MALLOC_CHECK
if (type != MEM_TYPE_NON_LISP)
mem_insert (val, (char *) val + nbytes, type);
#endif
struct ablocks *abase = ABLOCK_ABASE (ablock);
MALLOC_BLOCK_INPUT;
-#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+#ifndef GC_MALLOC_CHECK
mem_delete (mem_find (block));
#endif
/* Put on free list. */
ptrdiff_t nbytes =
(s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
- if (!PURE_POINTER_P (s)
- && s->data
- && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
+ if (!PURE_P (s) && s->data && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
emacs_abort ();
return nbytes;
}
{
nbytes = XINT (length);
val = make_uninit_string (nbytes);
- memset (SDATA (val), c, nbytes);
- SDATA (val)[nbytes] = 0;
+ if (nbytes)
+ {
+ memset (SDATA (val), c, nbytes);
+ SDATA (val)[nbytes] = 0;
+ }
}
else
{
EMACS_INT string_len = XINT (length);
unsigned char *p, *beg, *end;
- if (string_len > STRING_BYTES_MAX / len)
+ if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes))
string_overflow ();
- nbytes = len * string_len;
val = make_uninit_multibyte_string (string_len, nbytes);
for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len)
{
memcpy (p, beg, len);
}
}
- *p = 0;
+ if (nbytes)
+ *p = 0;
}
return val;
return val;
}
-
-/* Make an unibyte string from LENGTH bytes at CONTENTS. */
+/* Make a unibyte string from LENGTH bytes at CONTENTS. */
Lisp_Object
make_unibyte_string (const char *contents, ptrdiff_t length)
}
-/* Return an unibyte Lisp_String set up to hold LENGTH characters
+/* Return a unibyte Lisp_String set up to hold LENGTH characters
occupying LENGTH bytes. */
Lisp_Object
free_cons (struct Lisp_Cons *ptr)
{
ptr->u.chain = cons_free_list;
-#if GC_MARK_STACK
ptr->car = Vdead;
-#endif
cons_free_list = ptr;
consing_since_gc -= sizeof *ptr;
total_free_conses++;
static struct Lisp_Vector *
next_vector (struct Lisp_Vector *v)
{
- return XUNTAG (v->contents[0], 0);
+ return XUNTAG (v->contents[0], Lisp_Int0);
}
static void
set_next_vector (struct Lisp_Vector *v, struct Lisp_Vector *p)
{
- v->contents[0] = make_lisp_ptr (p, 0);
+ v->contents[0] = make_lisp_ptr (p, Lisp_Int0);
}
/* This value is balanced well enough to avoid too much internal overhead
{
/* Alignment of struct Lisp_Vector objects. */
vector_alignment = COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR,
- USE_LSB_TAG ? GCALIGNMENT : 1),
+ GCALIGNMENT),
/* Vector size requests are a multiple of this. */
roundup_size = COMMON_MULTIPLE (vector_alignment, word_size)
{
struct vector_block *block = xmalloc (sizeof *block);
-#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+#ifndef GC_MALLOC_CHECK
mem_insert (block->data, block->data + VECTOR_BLOCK_BYTES,
MEM_TYPE_VECTOR_BLOCK);
#endif
if (free_this_block)
{
*bprev = block->next;
-#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+#ifndef GC_MALLOC_CHECK
mem_delete (mem_find (block->data));
#endif
xfree (block);
if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len)
memory_full (SIZE_MAX);
v = allocate_vectorlike (len);
- v->header.size = len;
+ if (len)
+ v->header.size = len;
return v;
}
/* Allocate other vector-like structures. */
struct Lisp_Vector *
-allocate_pseudovector (int memlen, int lisplen, enum pvec_type tag)
+allocate_pseudovector (int memlen, int lisplen,
+ int zerolen, enum pvec_type tag)
{
struct Lisp_Vector *v = allocate_vectorlike (memlen);
- int i;
/* Catch bogus values. */
- eassert (tag <= PVEC_FONT);
+ eassert (0 <= tag && tag <= PVEC_FONT);
+ eassert (0 <= lisplen && lisplen <= zerolen && zerolen <= memlen);
eassert (memlen - lisplen <= (1 << PSEUDOVECTOR_REST_BITS) - 1);
eassert (lisplen <= (1 << PSEUDOVECTOR_SIZE_BITS) - 1);
- /* Only the first lisplen slots will be traced normally by the GC. */
- for (i = 0; i < lisplen; ++i)
- v->contents[i] = Qnil;
-
+ /* Only the first LISPLEN slots will be traced normally by the GC. */
+ memclear (v->contents, zerolen * word_size);
XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen);
return v;
}
return b;
}
-struct Lisp_Hash_Table *
-allocate_hash_table (void)
-{
- return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
-}
-
-struct window *
-allocate_window (void)
-{
- struct window *w;
-
- w = ALLOCATE_PSEUDOVECTOR (struct window, current_matrix, PVEC_WINDOW);
- /* Users assumes that non-Lisp data is zeroed. */
- memset (&w->current_matrix, 0,
- sizeof (*w) - offsetof (struct window, current_matrix));
- return w;
-}
-
-struct terminal *
-allocate_terminal (void)
-{
- struct terminal *t;
-
- t = ALLOCATE_PSEUDOVECTOR (struct terminal, next_terminal, PVEC_TERMINAL);
- /* Users assumes that non-Lisp data is zeroed. */
- memset (&t->next_terminal, 0,
- sizeof (*t) - offsetof (struct terminal, next_terminal));
- return t;
-}
-
-struct frame *
-allocate_frame (void)
-{
- struct frame *f;
-
- f = ALLOCATE_PSEUDOVECTOR (struct frame, face_cache, PVEC_FRAME);
- /* Users assumes that non-Lisp data is zeroed. */
- memset (&f->face_cache, 0,
- sizeof (*f) - offsetof (struct frame, face_cache));
- return f;
-}
-
-struct Lisp_Process *
-allocate_process (void)
-{
- struct Lisp_Process *p;
-
- p = ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
- /* Users assumes that non-Lisp data is zeroed. */
- memset (&p->pid, 0,
- sizeof (*p) - offsetof (struct Lisp_Process, pid));
- return p;
-}
-
DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
See also the function `vector'. */)
return vector;
}
-
DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
doc: /* Return a newly created vector with specified arguments as elements.
Any number of arguments, even zero arguments, are allowed.
***********************************************************************/
/* Like struct Lisp_Symbol, but padded so that the size is a multiple
- of the required alignment if LSB tags are used. */
+ of the required alignment. */
union aligned_Lisp_Symbol
{
struct Lisp_Symbol s;
-#if USE_LSB_TAG
unsigned char c[(sizeof (struct Lisp_Symbol) + GCALIGNMENT - 1)
& -GCALIGNMENT];
-#endif
};
/* Each symbol_block is just under 1020 bytes long, since malloc
XSYMBOL (sym)->name = name;
}
+void
+init_symbol (Lisp_Object val, Lisp_Object name)
+{
+ struct Lisp_Symbol *p = XSYMBOL (val);
+ set_symbol_name (val, name);
+ set_symbol_plist (val, Qnil);
+ p->redirect = SYMBOL_PLAINVAL;
+ SET_SYMBOL_VAL (p, Qunbound);
+ set_symbol_function (val, Qnil);
+ set_symbol_next (val, NULL);
+ p->gcmarkbit = false;
+ p->interned = SYMBOL_UNINTERNED;
+ p->constant = 0;
+ p->declared_special = false;
+ p->pinned = false;
+}
+
DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
doc: /* Return a newly allocated uninterned symbol whose name is NAME.
Its value is void, and its function definition and property list are nil. */)
(Lisp_Object name)
{
- register Lisp_Object val;
- register struct Lisp_Symbol *p;
+ Lisp_Object val;
CHECK_STRING (name);
MALLOC_UNBLOCK_INPUT;
- p = XSYMBOL (val);
- set_symbol_name (val, name);
- set_symbol_plist (val, Qnil);
- p->redirect = SYMBOL_PLAINVAL;
- SET_SYMBOL_VAL (p, Qunbound);
- set_symbol_function (val, Qnil);
- set_symbol_next (val, NULL);
- p->gcmarkbit = false;
- p->interned = SYMBOL_UNINTERNED;
- p->constant = 0;
- p->declared_special = false;
- p->pinned = false;
+ init_symbol (val, name);
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
total_free_symbols--;
***********************************************************************/
/* Like union Lisp_Misc, but padded so that its size is a multiple of
- the required alignment when LSB tags are used. */
+ the required alignment. */
union aligned_Lisp_Misc
{
union Lisp_Misc m;
-#if USE_LSB_TAG
unsigned char c[(sizeof (union Lisp_Misc) + GCALIGNMENT - 1)
& -GCALIGNMENT];
-#endif
};
/* Allocation of markers and other objects that share that structure.
- Works like allocation of conses. */
+ Works like allocation of conses. */
#define MARKER_BLOCK_SIZE \
((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
return val;
}
-Lisp_Object
-make_save_int_obj (ptrdiff_t a, Lisp_Object b)
-{
- Lisp_Object val = allocate_misc (Lisp_Misc_Save_Value);
- struct Lisp_Save_Value *p = XSAVE_VALUE (val);
- p->save_type = SAVE_TYPE_INT_OBJ;
- p->data[0].integer = a;
- p->data[1].object = b;
- return val;
-}
-
#if ! (defined USE_X_TOOLKIT || defined USE_GTK)
Lisp_Object
make_save_ptr_ptr (void *a, void *b)
}
}
+#ifdef HAVE_MODULES
+/* Create a new module user ptr object. */
+Lisp_Object
+make_user_ptr (void (*finalizer) (void *), void *p)
+{
+ Lisp_Object obj;
+ struct Lisp_User_Ptr *uptr;
+
+ obj = allocate_misc (Lisp_Misc_User_Ptr);
+ uptr = XUSER_PTR (obj);
+ uptr->finalizer = finalizer;
+ uptr->p = p;
+ return obj;
+}
+
+#endif
+
+static void
+init_finalizer_list (struct Lisp_Finalizer *head)
+{
+ head->prev = head->next = head;
+}
+
+/* Insert FINALIZER before ELEMENT. */
+
+static void
+finalizer_insert (struct Lisp_Finalizer *element,
+ struct Lisp_Finalizer *finalizer)
+{
+ eassert (finalizer->prev == NULL);
+ eassert (finalizer->next == NULL);
+ finalizer->next = element;
+ finalizer->prev = element->prev;
+ finalizer->prev->next = finalizer;
+ element->prev = finalizer;
+}
+
+static void
+unchain_finalizer (struct Lisp_Finalizer *finalizer)
+{
+ if (finalizer->prev != NULL)
+ {
+ eassert (finalizer->next != NULL);
+ finalizer->prev->next = finalizer->next;
+ finalizer->next->prev = finalizer->prev;
+ finalizer->prev = finalizer->next = NULL;
+ }
+}
+
+static void
+mark_finalizer_list (struct Lisp_Finalizer *head)
+{
+ for (struct Lisp_Finalizer *finalizer = head->next;
+ finalizer != head;
+ finalizer = finalizer->next)
+ {
+ finalizer->base.gcmarkbit = true;
+ mark_object (finalizer->function);
+ }
+}
+
+/* Move doomed finalizers to list DEST from list SRC. A doomed
+ finalizer is one that is not GC-reachable and whose
+ finalizer->function is non-nil. */
+
+static void
+queue_doomed_finalizers (struct Lisp_Finalizer *dest,
+ struct Lisp_Finalizer *src)
+{
+ struct Lisp_Finalizer *finalizer = src->next;
+ while (finalizer != src)
+ {
+ struct Lisp_Finalizer *next = finalizer->next;
+ if (!finalizer->base.gcmarkbit && !NILP (finalizer->function))
+ {
+ unchain_finalizer (finalizer);
+ finalizer_insert (dest, finalizer);
+ }
+
+ finalizer = next;
+ }
+}
+
+static Lisp_Object
+run_finalizer_handler (Lisp_Object args)
+{
+ add_to_log ("finalizer failed: %S", args);
+ return Qnil;
+}
+
+static void
+run_finalizer_function (Lisp_Object function)
+{
+ ptrdiff_t count = SPECPDL_INDEX ();
+
+ specbind (Qinhibit_quit, Qt);
+ internal_condition_case_1 (call0, function, Qt, run_finalizer_handler);
+ unbind_to (count, Qnil);
+}
+
+static void
+run_finalizers (struct Lisp_Finalizer *finalizers)
+{
+ struct Lisp_Finalizer *finalizer;
+ Lisp_Object function;
+
+ while (finalizers->next != finalizers)
+ {
+ finalizer = finalizers->next;
+ eassert (finalizer->base.type == Lisp_Misc_Finalizer);
+ unchain_finalizer (finalizer);
+ function = finalizer->function;
+ if (!NILP (function))
+ {
+ finalizer->function = Qnil;
+ run_finalizer_function (function);
+ }
+ }
+}
+
+DEFUN ("make-finalizer", Fmake_finalizer, Smake_finalizer, 1, 1, 0,
+ doc: /* Make a finalizer that will run FUNCTION.
+FUNCTION will be called after garbage collection when the returned
+finalizer object becomes unreachable. If the finalizer object is
+reachable only through references from finalizer objects, it does not
+count as reachable for the purpose of deciding whether to run
+FUNCTION. FUNCTION will be run once per finalizer object. */)
+ (Lisp_Object function)
+{
+ Lisp_Object val = allocate_misc (Lisp_Misc_Finalizer);
+ struct Lisp_Finalizer *finalizer = XFINALIZER (val);
+ finalizer->function = function;
+ finalizer->prev = finalizer->next = NULL;
+ finalizer_insert (&finalizers, finalizer);
+ return val;
+}
\f
/************************************************************************
C Stack Marking
************************************************************************/
-#if GC_MARK_STACK || defined GC_MALLOC_CHECK
-
/* Conservative C stack marking requires a method to identify possibly
live Lisp objects given a pointer value. We do this by keeping
track of blocks of Lisp data that are allocated in a red-black tree
c = mem_root;
parent = NULL;
-#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
-
- while (c != MEM_NIL)
- {
- if (start >= c->start && start < c->end)
- emacs_abort ();
- parent = c;
- c = start < c->start ? c->left : c->right;
- }
-
-#else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
-
while (c != MEM_NIL)
{
parent = c;
c = start < c->start ? c->left : c->right;
}
-#endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
-
/* Create a new node. */
#ifdef GC_MALLOC_CHECK
x = malloc (sizeof *x);
must not have been killed. */
return (m->type == MEM_TYPE_BUFFER
&& p == m->start
- && !NILP (((struct buffer *) p)->INTERNAL_FIELD (name)));
-}
-
-#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
-
-#if GC_MARK_STACK
-
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
-
-/* Currently not used, but may be called from gdb. */
-
-void dump_zombies (void) EXTERNALLY_VISIBLE;
-
-/* Array of objects that are kept alive because the C stack contains
- a pattern that looks like a reference to them. */
-
-#define MAX_ZOMBIES 10
-static Lisp_Object zombies[MAX_ZOMBIES];
-
-/* Number of zombie objects. */
-
-static EMACS_INT nzombies;
-
-/* Number of garbage collections. */
-
-static EMACS_INT ngcs;
-
-/* Average percentage of zombies per collection. */
-
-static double avg_zombies;
-
-/* Max. number of live and zombie objects. */
-
-static EMACS_INT max_live, max_zombies;
-
-/* Average number of live objects per GC. */
-
-static double avg_live;
-
-DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
- doc: /* Show information about live and zombie objects. */)
- (void)
-{
- Lisp_Object args[8], zombie_list = Qnil;
- EMACS_INT i;
- for (i = 0; i < min (MAX_ZOMBIES, nzombies); i++)
- zombie_list = Fcons (zombies[i], zombie_list);
- args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
- args[1] = make_number (ngcs);
- args[2] = make_float (avg_live);
- args[3] = make_float (avg_zombies);
- args[4] = make_float (avg_zombies / avg_live / 100);
- args[5] = make_number (max_live);
- args[6] = make_number (max_zombies);
- args[7] = zombie_list;
- return Fmessage (8, args);
+ && !NILP (((struct buffer *) p)->name_));
}
-#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
-
-
/* Mark OBJ if we can prove it's a Lisp_Object. */
static void
mark_maybe_object (Lisp_Object obj)
{
- void *po;
- struct mem_node *m;
-
#if USE_VALGRIND
if (valgrind_p)
VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj));
if (INTEGERP (obj))
return;
- po = (void *) XPNTR (obj);
- m = mem_find (po);
+ void *po = XPNTR (obj);
+ struct mem_node *m = mem_find (po);
if (m != MEM_NIL)
{
- bool mark_p = 0;
+ bool mark_p = false;
switch (XTYPE (obj))
{
}
if (mark_p)
- {
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- if (nzombies < MAX_ZOMBIES)
- zombies[nzombies] = obj;
- ++nzombies;
-#endif
- mark_object (obj);
- }
+ mark_object (obj);
}
}
/* Return true if P can point to Lisp data, and false otherwise.
- USE_LSB_TAG needs Lisp data to be aligned on multiples of GCALIGNMENT.
- Otherwise, assume that Lisp data is aligned on even addresses. */
+ Symbols are implemented via offsets not pointers, but the offsets
+ are also multiples of GCALIGNMENT. */
static bool
maybe_lisp_pointer (void *p)
{
- return !((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2));
+ return (uintptr_t) p % GCALIGNMENT == 0;
}
+#ifndef HAVE_MODULES
+enum { HAVE_MODULES = false };
+#endif
+
/* If P points to Lisp data, mark that as live if it isn't already
marked. */
VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
#endif
- if (!maybe_lisp_pointer (p))
- return;
+ if (sizeof (Lisp_Object) == sizeof (void *) || !HAVE_MODULES)
+ {
+ if (!maybe_lisp_pointer (p))
+ return;
+ }
+ else
+ {
+ /* For the wide-int case, also mark emacs_value tagged pointers,
+ which can be generated by emacs-module.c's value_to_lisp. */
+ p = (void *) ((uintptr_t) p & ~(GCALIGNMENT - 1));
+ }
m = mem_find (p);
if (m != MEM_NIL)
miss objects if __alignof__ were used. */
#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
- wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
- If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
- suffice to widen it to to a Lisp_Object and check it that way. */
-#if USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
-# if !USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
- /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
- nor mark_maybe_object can follow the pointers. This should not occur on
- any practical porting target. */
-# error "MSB type bits straddle pointer-word boundaries"
-# endif
- /* Marking via C pointers does not suffice, because Lisp_Objects contain
- pointer words that hold pointers ORed with type bits. */
-# define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
-#else
- /* Marking via C pointers suffices, because Lisp_Objects contain pointer
- words that hold unmodified pointers. */
-# define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
-#endif
-
/* Mark Lisp objects referenced from the address range START+OFFSET..END
- or END+OFFSET..START. */
+ or END+OFFSET..START. */
static void ATTRIBUTE_NO_SANITIZE_ADDRESS
mark_memory (void *start, void *end)
{
- void **pp;
- int i;
-
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- nzombies = 0;
-#endif
+ char *pp;
/* Make START the pointer to the start of the memory region,
if it isn't already. */
end = tem;
}
+ eassert (((uintptr_t) start) % GC_POINTER_ALIGNMENT == 0);
+
/* Mark Lisp data pointed to. This is necessary because, in some
situations, the C compiler optimizes Lisp objects away, so that
only a pointer to them remains. Example:
Lisp_Object obj = build_string ("test");
struct Lisp_String *s = XSTRING (obj);
Fgarbage_collect ();
- fprintf (stderr, "test `%s'\n", s->data);
+ fprintf (stderr, "test '%s'\n", s->data);
return Qnil;
}
away. The only reference to the life string is through the
pointer `s'. */
- for (pp = start; (void *) pp < end; pp++)
- for (i = 0; i < sizeof *pp; i += GC_POINTER_ALIGNMENT)
- {
- void *p = *(void **) ((char *) pp + i);
- mark_maybe_pointer (p);
- if (POINTERS_MIGHT_HIDE_IN_OBJECTS)
- mark_maybe_object (XIL ((intptr_t) p));
- }
+ for (pp = start; (void *) pp < end; pp += GC_POINTER_ALIGNMENT)
+ {
+ mark_maybe_pointer (*(void **) pp);
+ mark_maybe_object (*(Lisp_Object *) pp);
+ }
}
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
-#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
-
-/* Abort if anything GCPRO'd doesn't survive the GC. */
-
-static void
-check_gcpros (void)
-{
- struct gcpro *p;
- ptrdiff_t i;
-
- for (p = gcprolist; p; p = p->next)
- for (i = 0; i < p->nvars; ++i)
- 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. */
- emacs_abort ();
-}
-
-#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
-
-void
-dump_zombies (void)
-{
- int i;
-
- fprintf (stderr, "\nZombies kept alive = %"pI"d:\n", nzombies);
- for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
- {
- fprintf (stderr, " %d = ", i);
- debug_print (zombies[i]);
- }
-}
-
-#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
-
-
/* Mark live Lisp objects on the C stack.
There are several system-dependent problems to consider when
#ifdef GC_MARK_SECONDARY_STACK
GC_MARK_SECONDARY_STACK ();
#endif
-
-#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
- check_gcpros ();
-#endif
}
-#else /* GC_MARK_STACK == 0 */
-
-#define mark_maybe_object(obj) emacs_abort ()
-
-#endif /* GC_MARK_STACK != 0 */
-
+static bool
+c_symbol_p (struct Lisp_Symbol *sym)
+{
+ char *lispsym_ptr = (char *) lispsym;
+ char *sym_ptr = (char *) sym;
+ ptrdiff_t lispsym_offset = sym_ptr - lispsym_ptr;
+ return 0 <= lispsym_offset && lispsym_offset < sizeof lispsym;
+}
/* Determine whether it is safe to access memory at address P. */
static int
#ifdef WINDOWSNT
return w32_valid_pointer_p (p, 16);
#else
+
+ if (ADDRESS_SANITIZER)
+ return p ? -1 : 0;
+
int fd[2];
/* Obviously, we cannot just access it (we would SEGV trying), so we
return valid;
}
- return -1;
+ return -1;
#endif
}
int
valid_lisp_object_p (Lisp_Object obj)
{
- void *p;
-#if GC_MARK_STACK
- struct mem_node *m;
-#endif
-
if (INTEGERP (obj))
return 1;
- p = (void *) XPNTR (obj);
- if (PURE_POINTER_P (p))
+ void *p = XPNTR (obj);
+ if (PURE_P (p))
return 1;
+ if (SYMBOLP (obj) && c_symbol_p (p))
+ return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0;
+
if (p == &buffer_defaults || p == &buffer_local_symbols)
return 2;
-#if !GC_MARK_STACK
- return valid_pointer_p (p);
-#else
-
- m = mem_find (p);
+ struct mem_node *m = mem_find (p);
if (m == MEM_NIL)
{
}
return 0;
-#endif
-}
-
-/* If GC_MARK_STACK, return 1 if STR is a relocatable data of Lisp_String
- (i.e. there is a non-pure Lisp_Object X so that SDATA (X) == STR) and 0
- if not. Otherwise we can't rely on valid_lisp_object_p and return -1.
- This function is slow and should be used for debugging purposes. */
-
-int
-relocatable_string_data_p (const char *str)
-{
- if (PURE_POINTER_P (str))
- return 0;
-#if GC_MARK_STACK
- if (str)
- {
- struct sdata *sdata
- = (struct sdata *) (str - offsetof (struct sdata, data));
-
- if (valid_pointer_p (sdata)
- && valid_pointer_p (sdata->string)
- && maybe_lisp_pointer (sdata->string))
- return (valid_lisp_object_p
- (make_lisp_ptr (sdata->string, Lisp_String))
- && (const char *) sdata->string->data == str);
- }
- return 0;
-#endif /* GC_MARK_STACK */
- return -1;
}
/***********************************************************************
pure_alloc (size_t size, int type)
{
void *result;
-#if USE_LSB_TAG
- size_t alignment = GCALIGNMENT;
-#else
- size_t alignment = alignof (EMACS_INT);
-
- /* Give Lisp_Floats an extra alignment. */
- if (type == Lisp_Float)
- alignment = alignof (struct Lisp_Float);
-#endif
again:
if (type >= 0)
{
/* Allocate space for a Lisp object from the beginning of the free
space with taking account of alignment. */
- result = ALIGN (purebeg + pure_bytes_used_lisp, alignment);
+ result = ALIGN (purebeg + pure_bytes_used_lisp, GCALIGNMENT);
pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
}
else
return new;
}
-
DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
doc: /* Make a copy of object OBJ in pure storage.
Recursively copies contents of vectors and cons cells.
static Lisp_Object
purecopy (Lisp_Object obj)
{
- if (PURE_POINTER_P (XPNTR (obj)) || INTEGERP (obj) || SUBRP (obj))
+ if (INTEGERP (obj)
+ || (! SYMBOLP (obj) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj)))
+ || SUBRP (obj))
return obj; /* Already pure. */
+ if (STRINGP (obj) && XSTRING (obj)->intervals)
+ message_with_string ("Dropping text-properties while making string `%s' pure",
+ obj, true);
+
if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
{
Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil);
obj = make_pure_string (SSDATA (obj), SCHARS (obj),
SBYTES (obj),
STRING_MULTIBYTE (obj));
- else if (COMPILEDP (obj) || VECTORP (obj))
+ else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj))
{
- register struct Lisp_Vector *vec;
+ struct Lisp_Vector *objp = XVECTOR (obj);
+ ptrdiff_t nbytes = vector_nbytes (objp);
+ struct Lisp_Vector *vec = pure_alloc (nbytes, Lisp_Vectorlike);
register ptrdiff_t i;
- ptrdiff_t size;
-
- size = ASIZE (obj);
+ ptrdiff_t size = ASIZE (obj);
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
- vec = XVECTOR (make_pure_vector (size));
+ memcpy (vec, objp, nbytes);
for (i = 0; i < size; i++)
- vec->contents[i] = purecopy (AREF (obj, i));
- if (COMPILEDP (obj))
- {
- XSETPVECTYPE (vec, PVEC_COMPILED);
- XSETCOMPILED (obj, vec);
- }
- else
- XSETVECTOR (obj, vec);
+ vec->contents[i] = purecopy (vec->contents[i]);
+ XSETVECTOR (obj, vec);
}
else if (SYMBOLP (obj))
{
- if (!XSYMBOL (obj)->pinned)
+ if (!XSYMBOL (obj)->pinned && !c_symbol_p (XSYMBOL (obj)))
{ /* We can't purify them, but they appear in many pure objects.
Mark them as `pinned' so we know to mark them at every GC cycle. */
XSYMBOL (obj)->pinned = true;
symbol_block_pinned = symbol_block;
}
+ /* Don't hash-cons it. */
return obj;
}
else
{
- Lisp_Object args[2];
- args[0] = build_pure_c_string ("Don't know how to purify: %S");
- args[1] = obj;
- Fsignal (Qerror, (Fcons (Fformat (2, args), Qnil)));
+ Lisp_Object fmt = build_pure_c_string ("Don't know how to purify: %S");
+ Fsignal (Qerror, list1 (CALLN (Fformat, fmt, obj)));
}
if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
#ifdef HAVE_WINDOW_SYSTEM
-/* This code has a few issues on MS-Windows, see Bug#15876 and Bug#16140. */
-
-#if !defined (HAVE_NTGUI)
-
/* Remove unmarked font-spec and font-entity objects from ENTRY, which is
(DRIVER-TYPE NUM-FRAMES FONT-CACHE-DATA ...), and return changed entry. */
Lisp_Object obj = XCAR (tail);
/* Consider OBJ if it is (font-spec . [font-entity font-entity ...]). */
- if (CONSP (obj) && FONT_SPEC_P (XCAR (obj))
- && !VECTOR_MARKED_P (XFONT_SPEC (XCAR (obj)))
- && VECTORP (XCDR (obj)))
+ if (CONSP (obj) && GC_FONT_SPEC_P (XCAR (obj))
+ && !VECTOR_MARKED_P (GC_XFONT_SPEC (XCAR (obj)))
+ /* Don't use VECTORP here, as that calls ASIZE, which could
+ hit assertion violation during GC. */
+ && (VECTORLIKEP (XCDR (obj))
+ && ! (gc_asize (XCDR (obj)) & PSEUDOVECTOR_FLAG)))
{
- ptrdiff_t i, size = ASIZE (XCDR (obj)) & ~ARRAY_MARK_FLAG;
+ ptrdiff_t i, size = gc_asize (XCDR (obj));
+ Lisp_Object obj_cdr = XCDR (obj);
/* If font-spec is not marked, most likely all font-entities
are not marked too. But we must be sure that nothing is
marked within OBJ before we really drop it. */
for (i = 0; i < size; i++)
- if (VECTOR_MARKED_P (XFONT_ENTITY (AREF (XCDR (obj), i))))
- break;
+ {
+ Lisp_Object objlist;
+
+ if (VECTOR_MARKED_P (GC_XFONT_ENTITY (AREF (obj_cdr, i))))
+ break;
+
+ objlist = AREF (AREF (obj_cdr, i), FONT_OBJLIST_INDEX);
+ for (; CONSP (objlist); objlist = XCDR (objlist))
+ {
+ Lisp_Object val = XCAR (objlist);
+ struct font *font = GC_XFONT_OBJECT (val);
+
+ if (!NILP (AREF (val, FONT_TYPE_INDEX))
+ && VECTOR_MARKED_P(font))
+ break;
+ }
+ if (CONSP (objlist))
+ {
+ /* Found a marked font, bail out. */
+ break;
+ }
+ }
if (i == size)
- drop = 1;
+ {
+ /* No marked fonts were found, so this entire font
+ entity can be dropped. */
+ drop = 1;
+ }
}
if (drop)
*prev = XCDR (tail);
return entry;
}
-#endif /* not HAVE_NTGUI */
-
/* Compact font caches on all terminals and mark
everything which is still here after compaction. */
for (t = terminal_list; t; t = t->next_terminal)
{
Lisp_Object cache = TERMINAL_FONT_CACHE (t);
-#if !defined (HAVE_NTGUI)
if (CONSP (cache))
{
Lisp_Object entry;
for (entry = XCDR (cache); CONSP (entry); entry = XCDR (entry))
XSETCAR (entry, compact_font_cache_entry (XCAR (entry)));
}
-#endif /* not HAVE_NTGUI */
mark_object (cache);
}
}
union aligned_Lisp_Symbol *sym = sblk->symbols, *end = sym + lim;
for (; sym < end; ++sym)
if (sym->s.pinned)
- mark_object (make_lisp_ptr (&sym->s, Lisp_Symbol));
+ mark_object (make_lisp_symbol (&sym->s));
lim = SYMBOL_BLOCK_SIZE;
}
return Qnil;
/* Record this function, so it appears on the profiler's backtraces. */
- record_in_backtrace (Qautomatic_gc, &Qnil, 0);
+ record_in_backtrace (Qautomatic_gc, 0, 0);
check_cons_list ();
don't let that cause a recursive GC. */
consing_since_gc = 0;
- /* Save what's currently displayed in the echo area. */
- message_p = push_message ();
- record_unwind_protect_void (pop_message_unwind);
+ /* Save what's currently displayed in the echo area. Don't do that
+ if we are GC'ing because we've run out of memory, since
+ push_message will cons, and we might have no memory for that. */
+ if (NILP (Vmemory_full))
+ {
+ message_p = push_message ();
+ record_unwind_protect_void (pop_message_unwind);
+ }
+ else
+ message_p = false;
/* Save a copy of the contents of the stack, for debugging. */
#if MAX_SAVE_STACK > 0
mark_buffer (&buffer_defaults);
mark_buffer (&buffer_local_symbols);
+ for (i = 0; i < ARRAYELTS (lispsym); i++)
+ mark_object (builtin_lisp_symbol (i));
+
for (i = 0; i < staticidx; i++)
mark_object (*staticvec[i]);
xg_mark_data ();
#endif
-#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
- || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
mark_stack (end);
-#else
- {
- register struct gcpro *tail;
- for (tail = gcprolist; tail; tail = tail->next)
- for (i = 0; i < tail->nvars; i++)
- mark_object (tail->var[i]);
- }
- mark_byte_stack ();
-#endif
+
{
struct handler *handler;
for (handler = handlerlist; handler; handler = handler->next)
mark_fringe_data ();
#endif
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- mark_stack (end);
-#endif
-
- /* Everything is now marked, except for the data in font caches
- and undo lists. They're compacted by removing an items which
- aren't reachable otherwise. */
+ /* Everything is now marked, except for the data in font caches,
+ undo lists, and finalizers. The first two are compacted by
+ removing an items which aren't reachable otherwise. */
compact_font_caches ();
mark_object (BVAR (nextb, undo_list));
}
+ /* Now pre-sweep finalizers. Here, we add any unmarked finalizers
+ to doomed_finalizers so we can run their associated functions
+ after GC. It's important to scan finalizers at this stage so
+ that we can be sure that unmarked finalizers are really
+ unreachable except for references from their associated functions
+ and from other finalizers. */
+
+ queue_doomed_finalizers (&doomed_finalizers, &finalizers);
+ mark_finalizer_list (&doomed_finalizers);
+
gc_sweep ();
- /* Clear the mark bits that we set in certain root slots. */
+ relocate_byte_stack ();
- unmark_byte_stack ();
+ /* Clear the mark bits that we set in certain root slots. */
VECTOR_UNMARK (&buffer_defaults);
VECTOR_UNMARK (&buffer_local_symbols);
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
- dump_zombies ();
-#endif
-
check_cons_list ();
gc_in_progress = 0;
}
}
- if (garbage_collection_messages)
+ if (garbage_collection_messages && NILP (Vmemory_full))
{
if (message_p || minibuf_level > 0)
restore_message ();
}
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 (header_size + sizeof (Lisp_Object)),
- bounded_number (total_vectors));
-
- 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));
+ Lisp_Object total[] = {
+ list4 (Qconses, make_number (sizeof (struct Lisp_Cons)),
+ bounded_number (total_conses),
+ bounded_number (total_free_conses)),
+ list4 (Qsymbols, make_number (sizeof (struct Lisp_Symbol)),
+ bounded_number (total_symbols),
+ bounded_number (total_free_symbols)),
+ list4 (Qmiscs, make_number (sizeof (union Lisp_Misc)),
+ bounded_number (total_markers),
+ bounded_number (total_free_markers)),
+ list4 (Qstrings, make_number (sizeof (struct Lisp_String)),
+ bounded_number (total_strings),
+ bounded_number (total_free_strings)),
+ list3 (Qstring_bytes, make_number (1),
+ bounded_number (total_string_bytes)),
+ list3 (Qvectors,
+ make_number (header_size + sizeof (Lisp_Object)),
+ bounded_number (total_vectors)),
+ list4 (Qvector_slots, make_number (word_size),
+ bounded_number (total_vector_slots),
+ bounded_number (total_free_vector_slots)),
+ list4 (Qfloats, make_number (sizeof (struct Lisp_Float)),
+ bounded_number (total_floats),
+ bounded_number (total_free_floats)),
+ list4 (Qintervals, make_number (sizeof (struct interval)),
+ bounded_number (total_intervals),
+ bounded_number (total_free_intervals)),
+ 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));
+ list4 (Qheap, make_number (1024),
+ bounded_number ((mallinfo ().uordblks + 1023) >> 10),
+ bounded_number ((mallinfo ().fordblks + 1023) >> 10)),
#endif
- retval = Flist (total_size, total);
- }
+ };
+ retval = CALLMANY (Flist, total);
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- {
- /* Compute average percentage of zombies. */
- 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
+ /* GC is complete: now we can run our finalizer callbacks. */
+ run_finalizers (&doomed_finalizers);
if (!NILP (Vpost_gc_hook))
{
See Info node `(elisp)Garbage Collection'. */)
(void)
{
-#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
- || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS \
- || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
void *end;
#ifdef HAVE___BUILTIN_UNWIND_INIT
#endif /* not GC_SAVE_REGISTERS_ON_STACK */
#endif /* not HAVE___BUILTIN_UNWIND_INIT */
return garbage_collect_1 (end);
-#elif (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE)
- /* Old GCPROs-based method without stack marking. */
- return garbage_collect_1 (NULL);
-#else
- emacs_abort ();
-#endif /* GC_MARK_STACK */
}
/* Mark Lisp objects in glyph matrix MATRIX. Currently the
for (; ptr && !ptr->gcmarkbit; ptr = ptr->next)
{
ptr->gcmarkbit = 1;
- mark_object (ptr->start);
- mark_object (ptr->end);
+ /* These two are always markers and can be marked fast. */
+ XMARKER (ptr->start)->gcmarkbit = 1;
+ XMARKER (ptr->end)->gcmarkbit = 1;
mark_object (ptr->plist);
}
}
/* If `save_type' is zero, `data[0].pointer' is the address
of a memory area containing `data[1].integer' potential
Lisp_Objects. */
- if (GC_MARK_STACK && ptr->save_type == SAVE_TYPE_MEMORY)
+ if (ptr->save_type == SAVE_TYPE_MEMORY)
{
Lisp_Object *p = ptr->data[0].pointer;
ptrdiff_t nelt;
void
mark_object (Lisp_Object arg)
{
- register Lisp_Object obj = arg;
-#ifdef GC_CHECK_MARKED_OBJECTS
+ register Lisp_Object obj;
void *po;
+#ifdef GC_CHECK_MARKED_OBJECTS
struct mem_node *m;
#endif
ptrdiff_t cdr_count = 0;
+ obj = arg;
loop:
- if (PURE_POINTER_P (XPNTR (obj)))
+ po = XPNTR (obj);
+ if (PURE_P (po))
return;
last_marked[last_marked_index++] = obj;
/* Perform some sanity checks on the objects marked here. Abort if
we encounter an object we know is bogus. This increases GC time
- by ~80%, and requires compilation with GC_MARK_STACK != 0. */
+ by ~80%. */
#ifdef GC_CHECK_MARKED_OBJECTS
- po = (void *) XPNTR (obj);
-
/* Check that the object pointed to by PO is known to be a Lisp
structure allocated from the heap. */
#define CHECK_ALLOCATED() \
emacs_abort (); \
} while (0)
- /* Check both of the above conditions. */
+ /* Check both of the above conditions, for non-symbols. */
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
do { \
CHECK_ALLOCATED (); \
CHECK_LIVE (LIVEP); \
} while (0) \
+ /* Check both of the above conditions, for symbols. */
+#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() \
+ do { \
+ if (!c_symbol_p (ptr)) \
+ { \
+ CHECK_ALLOCATED (); \
+ CHECK_LIVE (live_symbol_p); \
+ } \
+ } while (0) \
+
#else /* not GC_CHECK_MARKED_OBJECTS */
-#define CHECK_LIVE(LIVEP) (void) 0
-#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
+#define CHECK_LIVE(LIVEP) ((void) 0)
+#define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0)
+#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0)
#endif /* not GC_CHECK_MARKED_OBJECTS */
nextsym:
if (ptr->gcmarkbit)
break;
- CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
+ CHECK_ALLOCATED_AND_LIVE_SYMBOL ();
ptr->gcmarkbit = 1;
/* Attempt to catch bogus objects. */
- eassert (valid_lisp_object_p (ptr->function) >= 1);
+ eassert (valid_lisp_object_p (ptr->function));
mark_object (ptr->function);
mark_object (ptr->plist);
switch (ptr->redirect)
break;
default: emacs_abort ();
}
- if (!PURE_POINTER_P (XSTRING (ptr->name)))
+ if (!PURE_P (XSTRING (ptr->name)))
MARK_STRING (XSTRING (ptr->name));
MARK_INTERVAL_TREE (string_intervals (ptr->name));
/* Inner loop to mark next symbol in this bucket, if any. */
- ptr = ptr->next;
+ po = ptr = ptr->next;
if (ptr)
goto nextsym;
}
case Lisp_Misc_Overlay:
mark_overlay (XOVERLAY (obj));
+ break;
+
+ case Lisp_Misc_Finalizer:
+ XMISCANY (obj)->gcmarkbit = true;
+ mark_object (XFINALIZER (obj)->function);
+ break;
+
+#ifdef HAVE_MODULES
+ case Lisp_Misc_User_Ptr:
+ XMISCANY (obj)->gcmarkbit = true;
break;
+#endif
default:
emacs_abort ();
emacs_abort ();
}
- return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
+ return survives_p || PURE_P (XPNTR (obj));
}
this_free++;
cblk->conses[pos].u.chain = cons_free_list;
cons_free_list = &cblk->conses[pos];
-#if GC_MARK_STACK
cons_free_list->car = Vdead;
-#endif
}
else
{
static void
sweep_symbols (void)
{
- register struct symbol_block *sblk;
+ struct symbol_block *sblk;
struct symbol_block **sprev = &symbol_block;
- register int lim = symbol_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+ int lim = symbol_block_index;
+ EMACS_INT num_free = 0, num_used = ARRAYELTS (lispsym);
symbol_free_list = NULL;
+ for (int i = 0; i < ARRAYELTS (lispsym); i++)
+ lispsym[i].gcmarkbit = 0;
+
for (sblk = symbol_block; sblk; sblk = *sprev)
{
int this_free = 0;
xfree (SYMBOL_BLV (&sym->s));
sym->s.next = symbol_free_list;
symbol_free_list = &sym->s;
-#if GC_MARK_STACK
symbol_free_list->function = Vdead;
-#endif
++this_free;
}
else
++num_used;
sym->s.gcmarkbit = 0;
/* Attempt to catch bogus objects. */
- eassert (valid_lisp_object_p (sym->s.function) >= 1);
+ eassert (valid_lisp_object_p (sym->s.function));
}
}
total_free_symbols = num_free;
}
-NO_INLINE /* For better stack traces */
+NO_INLINE /* For better stack traces. */
static void
sweep_misc (void)
{
{
if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
unchain_marker (&mblk->markers[i].m.u_marker);
+ else if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer)
+ unchain_finalizer (&mblk->markers[i].m.u_finalizer);
+#ifdef HAVE_MODULES
+ else if (mblk->markers[i].m.u_any.type == Lisp_Misc_User_Ptr)
+ {
+ struct Lisp_User_Ptr *uptr = &mblk->markers[i].m.u_user_ptr;
+ uptr->finalizer (uptr->p);
+ }
+#endif
/* Set the type of the freed object to Lisp_Misc_Free.
We could leave the type alone, since nobody checks it,
but this might catch bugs faster. */
bounded_number (strings_consed));
}
+static bool
+symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj)
+{
+ struct Lisp_Symbol *sym = XSYMBOL (symbol);
+ Lisp_Object val = find_symbol_value (symbol);
+ return (EQ (val, obj)
+ || EQ (sym->function, obj)
+ || (!NILP (sym->function)
+ && COMPILEDP (sym->function)
+ && EQ (AREF (sym->function, COMPILED_BYTECODE), obj))
+ || (!NILP (val)
+ && COMPILEDP (val)
+ && EQ (AREF (val, COMPILED_BYTECODE), obj)));
+}
+
/* Find at most FIND_MAX symbols which have OBJ as their value or
function. This is used in gdbinit's `xwhichsymbols' command. */
if (! DEADP (obj))
{
+ for (int i = 0; i < ARRAYELTS (lispsym); i++)
+ {
+ Lisp_Object sym = builtin_lisp_symbol (i);
+ if (symbol_uses_obj (sym, obj))
+ {
+ found = Fcons (sym, found);
+ if (--find_max == 0)
+ goto out;
+ }
+ }
+
for (sblk = symbol_block; sblk; sblk = sblk->next)
{
union aligned_Lisp_Symbol *aligned_sym = sblk->symbols;
for (bn = 0; bn < SYMBOL_BLOCK_SIZE; bn++, aligned_sym++)
{
- struct Lisp_Symbol *sym = &aligned_sym->s;
- Lisp_Object val;
- Lisp_Object tem;
-
if (sblk == symbol_block && bn >= symbol_block_index)
break;
- XSETSYMBOL (tem, sym);
- val = find_symbol_value (tem);
- if (EQ (val, obj)
- || EQ (sym->function, obj)
- || (!NILP (sym->function)
- && COMPILEDP (sym->function)
- && EQ (AREF (sym->function, COMPILED_BYTECODE), obj))
- || (!NILP (val)
- && COMPILEDP (val)
- && EQ (AREF (val, COMPILED_BYTECODE), obj)))
+ Lisp_Object sym = make_lisp_symbol (&aligned_sym->s);
+ if (symbol_uses_obj (sym, obj))
{
- found = Fcons (tem, found);
+ found = Fcons (sym, found);
if (--find_max == 0)
goto out;
}
DEFUN ("suspicious-object", Fsuspicious_object, Ssuspicious_object, 1, 1, 0,
doc: /* Return OBJ, maybe marking it for extra scrutiny.
-If Emacs is compiled with suspicous object checking, capture
+If Emacs is compiled with suspicious object checking, capture
a stack trace when OBJ is freed in order to help track down
garbage collection bugs. Otherwise, do nothing and return OBJ. */)
(Lisp_Object obj)
#endif /* ENABLE_CHECKING */
-#if defined (ENABLE_CHECKING) && defined (USE_STACK_LISP_OBJECTS)
+#if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
+
+/* Debugging check whether STR is ASCII-only. */
+
+const char *
+verify_ascii (const char *str)
+{
+ const unsigned char *ptr = (unsigned char *) str, *end = ptr + strlen (str);
+ while (ptr < end)
+ {
+ int c = STRING_CHAR_ADVANCE (ptr);
+ if (!ASCII_CHAR_P (c))
+ emacs_abort ();
+ }
+ return str;
+}
/* Stress alloca with inconveniently sized requests and check
whether all allocated areas may be used for Lisp_Object. */
/* Start from size of the smallest Lisp object. */
for (i = sizeof (struct Lisp_Cons); i <= ALLOCA_CHECK_MAX; i++)
{
- char *ptr = alloca (i);
- eassert (pointer_valid_for_lisp_object (ptr));
+ void *ptr = alloca (i);
+ make_lisp_ptr (ptr, Lisp_Cons);
}
}
-#else /* not (ENABLE_CHECKING && USE_STACK_LISP_OBJECTS) */
+#else /* not ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
#define verify_alloca() ((void) 0)
void
init_alloc_once (void)
{
- /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
+ /* Even though Qt's contents are not set up, its address is known. */
+ Vpurify_flag = Qt;
+
purebeg = PUREBEG;
pure_size = PURESIZE;
verify_alloca ();
+ init_finalizer_list (&finalizers);
+ init_finalizer_list (&doomed_finalizers);
-#if GC_MARK_STACK || defined GC_MALLOC_CHECK
mem_init ();
Vdead = make_pure_string ("DEAD", 4, 4, 0);
-#endif
#ifdef DOUG_LEA_MALLOC
mallopt (M_TRIM_THRESHOLD, 128 * 1024); /* Trim threshold. */
void
init_alloc (void)
{
- gcprolist = 0;
- byte_stack_list = 0;
-#if GC_MARK_STACK
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
setjmp_tested_p = longjmps_done = 0;
-#endif
#endif
Vgc_elapsed = make_float (0.0);
gcs_done = 0;
DEFVAR_INT ("symbols-consed", symbols_consed,
doc: /* Number of symbols that have been consed so far. */);
+ symbols_consed += ARRAYELTS (lispsym);
DEFVAR_INT ("string-chars-consed", string_chars_consed,
doc: /* Number of string characters that have been consed so far. */);
doc: /* Accumulated time elapsed in garbage collections.
The time is in seconds as a floating point value. */);
DEFVAR_INT ("gcs-done", gcs_done,
- doc: /* Accumulated number of garbage collections done. */);
+ doc: /* Accumulated number of garbage collections done. */);
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Smake_bool_vector);
defsubr (&Smake_symbol);
defsubr (&Smake_marker);
+ defsubr (&Smake_finalizer);
defsubr (&Spurecopy);
defsubr (&Sgarbage_collect);
defsubr (&Smemory_limit);
defsubr (&Smemory_info);
defsubr (&Smemory_use_counts);
defsubr (&Ssuspicious_object);
-
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- defsubr (&Sgc_status);
-#endif
}
/* When compiled with GCC, GDB might say "No enum type named