summaryrefslogtreecommitdiff
path: root/src/alloc.c
diff options
context:
space:
mode:
authorKen Raeburn <raeburn@raeburn.org>2015-11-01 01:42:21 -0400
committerKen Raeburn <raeburn@raeburn.org>2015-11-01 01:42:21 -0400
commit39372e1a1032521be74575bb06f95a3898fbae30 (patch)
tree754bd242a23d2358ea116126fcb0a629947bd9ec /src/alloc.c
parent6a3121904d76e3b2f63007341d48c5c1af55de80 (diff)
parente11aaee266da52937a3a031cb108fe13f68958c3 (diff)
downloademacs-39372e1a1032521be74575bb06f95a3898fbae30.tar.gz
merge from trunk
Diffstat (limited to 'src/alloc.c')
-rw-r--r--src/alloc.c2830
1 files changed, 1668 insertions, 1162 deletions
diff --git a/src/alloc.c b/src/alloc.c
index 5de7d384a49..685d48b8770 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -1,6 +1,6 @@
/* Storage allocation and gc for GNU Emacs Lisp interpreter.
-Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2013 Free Software
+Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2015 Free Software
Foundation, Inc.
This file is part of GNU Emacs.
@@ -20,8 +20,6 @@ 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. */
@@ -34,9 +32,10 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
#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"
@@ -44,21 +43,41 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
#include "frame.h"
#include "blockinput.h"
#include "termhooks.h" /* For struct terminal. */
+#ifdef HAVE_WINDOW_SYSTEM
+#include TERM_HEADER
+#endif /* HAVE_WINDOW_SYSTEM */
#include <verify.h>
+#include <execinfo.h> /* For backtrace. */
+
+#ifdef HAVE_LINUX_SYSINFO
+#include <sys/sysinfo.h>
+#endif
+
+#ifdef MSDOS
+#include "dosfns.h" /* For dos_memory_info. */
+#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
+#if (defined ENABLE_CHECKING \
+ && defined HAVE_VALGRIND_VALGRIND_H \
+ && !defined USE_VALGRIND)
+# define USE_VALGRIND 1
#endif
+#if USE_VALGRIND
+#include <valgrind/valgrind.h>
+#include <valgrind/memcheck.h>
+static bool valgrind_p;
+#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
marked objects. */
#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
- || defined GC_CHECK_MARKED_OBJECTS)
+ || defined HYBRID_MALLOC || defined GC_CHECK_MARKED_OBJECTS)
#undef GC_MALLOC_CHECK
#endif
@@ -161,11 +180,6 @@ static ptrdiff_t pure_size;
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;
@@ -179,6 +193,35 @@ static ptrdiff_t pure_bytes_used_non_lisp;
const char *pending_malloc_warning;
+#if 0 /* Normally, pointer sanity only on request... */
+#ifdef ENABLE_CHECKING
+#define SUSPICIOUS_OBJECT_CHECKING 1
+#endif
+#endif
+
+/* ... but unconditionally use SUSPICIOUS_OBJECT_CHECKING while the GC
+ bug is unresolved. */
+#define SUSPICIOUS_OBJECT_CHECKING 1
+
+#ifdef SUSPICIOUS_OBJECT_CHECKING
+struct suspicious_free_record
+{
+ void *suspicious_object;
+ void *backtrace[128];
+};
+static void *suspicious_objects[32];
+static int suspicious_object_index;
+struct suspicious_free_record suspicious_free_history[64] EXTERNALLY_VISIBLE;
+static int suspicious_free_history_index;
+/* Find the first currently-monitored suspicious pointer in range
+ [begin,end) or NULL if no such pointer exists. */
+static void *find_suspicious_object_in_range (void *begin, void *end);
+static void detect_suspicious_free (void *ptr);
+#else
+# define find_suspicious_object_in_range(begin, end) NULL
+# define detect_suspicious_free(ptr) (void)
+#endif
+
/* Maximum amount of C stack to save when a GC happens. */
#ifndef MAX_SAVE_STACK
@@ -190,31 +233,34 @@ const char *pending_malloc_warning;
#if MAX_SAVE_STACK > 0
static char *stack_copy;
static ptrdiff_t stack_copy_size;
-#endif
-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;
+/* Copy to DEST a block of memory from SRC of size SIZE bytes,
+ avoiding any address sanitization. */
-/* Hook run after GC has finished. */
+static void * ATTRIBUTE_NO_SANITIZE_ADDRESS
+no_sanitize_memcpy (void *dest, void const *src, size_t size)
+{
+ if (! ADDRESS_SANITIZER)
+ return memcpy (dest, src, size);
+ else
+ {
+ size_t i;
+ char *d = dest;
+ char const *s = src;
+ for (i = 0; i < size; i++)
+ d[i] = s[i];
+ return dest;
+ }
+}
-static Lisp_Object Qpost_gc_hook;
+#endif /* MAX_SAVE_STACK > 0 */
static void mark_terminals (void);
static void gc_sweep (void);
static Lisp_Object make_pure_vector (ptrdiff_t);
static void mark_buffer (struct buffer *);
-#if !defined REL_ALLOC || defined SYSTEM_MALLOC
+#if !defined REL_ALLOC || defined SYSTEM_MALLOC || defined HYBRID_MALLOC
static void refill_memory_reserve (void);
#endif
static void compact_small_strings (void);
@@ -244,8 +290,6 @@ enum mem_type
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). */
@@ -322,8 +366,6 @@ static void mem_delete (struct mem_node *);
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
@@ -340,13 +382,43 @@ static int staticidx;
static void *pure_alloc (size_t, int);
+/* Return X rounded to the next multiple of Y. Arguments should not
+ have side effects, as they are evaluated more than once. Assume X
+ + Y - 1 does not overflow. Tune for Y being a power of 2. */
+
+#define ROUNDUP(x, y) ((y) & ((y) - 1) \
+ ? ((x) + (y) - 1) - ((x) + (y) - 1) % (y) \
+ : ((x) + (y) - 1) & ~ ((y) - 1))
-/* Value is SZ rounded up to the next multiple of ALIGNMENT.
- ALIGNMENT must be a power of 2. */
+/* Return PTR rounded up to the next multiple of ALIGNMENT. */
+
+static void *
+ALIGN (void *ptr, int alignment)
+{
+ return (void *) ROUNDUP ((uintptr_t) ptr, alignment);
+}
-#define ALIGN(ptr, ALIGNMENT) \
- ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
- & ~ ((ALIGNMENT) - 1)))
+/* 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 *. */
+
+static void *
+XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a)
+{
+ intptr_t i = USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK;
+ return (void *) i;
+}
+
+/* Extract the pointer hidden within A. */
+
+static void *
+XPNTR (Lisp_Object a)
+{
+ void *p = XPNTR_OR_SYMBOL_OFFSET (a);
+ if (SYMBOLP (a))
+ p = (intptr_t) p + (char *) lispsym;
+ return p;
+}
static void
XFLOAT_INIT (Lisp_Object f, double n)
@@ -354,6 +426,32 @@ XFLOAT_INIT (Lisp_Object f, double n)
XFLOAT (f)->u.data = n;
}
+static bool
+pointers_fit_in_lispobj_p (void)
+{
+ return (UINTPTR_MAX <= VAL_MAX) || USE_LSB_TAG;
+}
+
+static bool
+mmap_lisp_allowed_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 mmapped
+ regions. */
+ return pointers_fit_in_lispobj_p () && !might_dump;
+}
+
+/* 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;
+
/************************************************************************
Malloc
@@ -430,15 +528,10 @@ buffer_memory_full (ptrdiff_t nbytes)
/* 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) \
@@ -801,6 +894,20 @@ xlispstrdup (Lisp_Object string)
return memcpy (xmalloc (size), SSDATA (string), size);
}
+/* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
+ pointed to. If STRING is null, assign it without copying anything.
+ Allocate before freeing, to avoid a dangling pointer if allocation
+ fails. */
+
+void
+dupstring (char **ptr, char const *string)
+{
+ char *old = *ptr;
+ *ptr = string ? xstrdup (string) : 0;
+ xfree (old);
+}
+
+
/* Like putenv, but (1) use the equivalent of xmalloc and (2) the
argument is a const pointer. */
@@ -860,7 +967,7 @@ lisp_malloc (size_t nbytes, enum mem_type type)
}
#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
@@ -880,7 +987,7 @@ lisp_free (void *block)
{
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;
@@ -891,8 +998,33 @@ lisp_free (void *block)
/* The entry point is lisp_align_malloc which returns blocks of at most
BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
-#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
-#define USE_POSIX_MEMALIGN 1
+/* Use aligned_alloc if it or a simple substitute is available.
+ Address sanitization breaks aligned allocation, as of gcc 4.8.2 and
+ clang 3.3 anyway. */
+
+#if ! ADDRESS_SANITIZER
+# if !defined SYSTEM_MALLOC && !defined DOUG_LEA_MALLOC && !defined HYBRID_MALLOC
+# define USE_ALIGNED_ALLOC 1
+/* Defined in gmalloc.c. */
+void *aligned_alloc (size_t, size_t);
+# elif defined HYBRID_MALLOC
+# if defined ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN
+# define USE_ALIGNED_ALLOC 1
+# define aligned_alloc hybrid_aligned_alloc
+/* Defined in gmalloc.c. */
+void *aligned_alloc (size_t, size_t);
+# endif
+# elif defined HAVE_ALIGNED_ALLOC
+# define USE_ALIGNED_ALLOC 1
+# elif defined HAVE_POSIX_MEMALIGN
+# define USE_ALIGNED_ALLOC 1
+static void *
+aligned_alloc (size_t alignment, size_t size)
+{
+ void *p;
+ return posix_memalign (&p, alignment, size) == 0 ? p : 0;
+}
+# endif
#endif
/* BLOCK_ALIGN has to be a power of 2. */
@@ -902,7 +1034,7 @@ lisp_free (void *block)
malloc a chance to minimize the amount of memory wasted to alignment.
It should be tuned to the particular malloc library used.
On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
- posix_memalign on the other hand would ideally prefer a value of 4
+ aligned_alloc on the other hand would ideally prefer a value of 4
because otherwise, there's 1020 bytes wasted between each ablocks.
In Emacs, testing shows that those 1020 can most of the time be
efficiently used by malloc to place other objects, so a value of 0 can
@@ -947,7 +1079,7 @@ struct ablocks
struct ablock blocks[ABLOCKS_SIZE];
};
-/* Size of the block requested from malloc or posix_memalign. */
+/* Size of the block requested from malloc or aligned_alloc. */
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
#define ABLOCK_ABASE(block) \
@@ -959,11 +1091,11 @@ struct ablocks
#define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
/* Pointer to the (not necessarily aligned) malloc block. */
-#ifdef USE_POSIX_MEMALIGN
+#ifdef USE_ALIGNED_ALLOC
#define ABLOCKS_BASE(abase) (abase)
#else
#define ABLOCKS_BASE(abase) \
- (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
+ (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void **)abase)[-1])
#endif
/* The list of free ablock. */
@@ -992,19 +1124,12 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
intptr_t aligned; /* int gets warning casting to 64-bit pointer. */
#ifdef DOUG_LEA_MALLOC
- /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
- because mapped region contents are not preserved in
- a dumped Emacs. */
- mallopt (M_MMAP_MAX, 0);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, 0);
#endif
-#ifdef USE_POSIX_MEMALIGN
- {
- int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
- if (err)
- base = NULL;
- abase = base;
- }
+#ifdef USE_ALIGNED_ALLOC
+ abase = base = aligned_alloc (BLOCK_ALIGN, ABLOCKS_BYTES);
#else
base = malloc (ABLOCKS_BYTES);
abase = ALIGN (base, BLOCK_ALIGN);
@@ -1018,11 +1143,11 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
aligned = (base == abase);
if (!aligned)
- ((void**)abase)[-1] = base;
+ ((void **) abase)[-1] = base;
#ifdef DOUG_LEA_MALLOC
- /* Back to a reasonable maximum of mmap'ed areas. */
- mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
#if ! USE_LSB_TAG
@@ -1062,12 +1187,12 @@ lisp_align_malloc (size_t nbytes, enum mem_type type)
}
abase = ABLOCK_ABASE (free_ablock);
- ABLOCKS_BUSY (abase) =
- (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase));
+ ABLOCKS_BUSY (abase)
+ = (struct ablocks *) (2 + (intptr_t) ABLOCKS_BUSY (abase));
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
@@ -1087,7 +1212,7 @@ lisp_align_free (void *block)
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. */
@@ -1259,28 +1384,32 @@ mark_interval (register INTERVAL i, Lisp_Object dummy)
#define LARGE_STRING_BYTES 1024
-/* Struct or union describing string memory sub-allocated from an sblock.
- This is where the contents of Lisp strings are stored. */
-
-#ifdef GC_CHECK_STRING_BYTES
+/* The SDATA typedef is a struct or union describing string memory
+ sub-allocated from an sblock. This is where the contents of Lisp
+ strings are stored. */
-typedef struct
+struct sdata
{
/* Back-pointer to the string this sdata belongs to. If null, this
- structure is free, and the NBYTES member of the union below
+ structure is free, and NBYTES (in this structure or in the union below)
contains the string's byte size (the same value that STRING_BYTES
would return if STRING were non-null). If non-null, STRING_BYTES
(STRING) is the size of the data, and DATA contains the string's
contents. */
struct Lisp_String *string;
+#ifdef GC_CHECK_STRING_BYTES
ptrdiff_t nbytes;
+#endif
+
unsigned char data[FLEXIBLE_ARRAY_MEMBER];
-} sdata;
+};
+
+#ifdef GC_CHECK_STRING_BYTES
+typedef struct sdata sdata;
#define SDATA_NBYTES(S) (S)->nbytes
#define SDATA_DATA(S) (S)->data
-#define SDATA_SELECTOR(member) member
#else
@@ -1288,12 +1417,16 @@ typedef union
{
struct Lisp_String *string;
- /* When STRING is non-null. */
- struct
- {
- struct Lisp_String *string;
- unsigned char data[FLEXIBLE_ARRAY_MEMBER];
- } u;
+ /* When STRING is nonnull, this union is actually of type 'struct sdata',
+ which has a flexible array member. However, if implemented by
+ giving this union a member of type 'struct sdata', the union
+ could not be the last (flexible) member of 'struct sblock',
+ because C99 prohibits a flexible array member from having a type
+ that is itself a flexible array. So, comment this member out here,
+ but remember that the option's there when using this union. */
+#if 0
+ struct sdata u;
+#endif
/* When STRING is null. */
struct
@@ -1304,13 +1437,11 @@ typedef union
} sdata;
#define SDATA_NBYTES(S) (S)->n.nbytes
-#define SDATA_DATA(S) (S)->u.data
-#define SDATA_SELECTOR(member) u.member
+#define SDATA_DATA(S) ((struct sdata *) (S))->data
#endif /* not GC_CHECK_STRING_BYTES */
-#define SDATA_DATA_OFFSET offsetof (sdata, SDATA_SELECTOR (data))
-
+enum { SDATA_DATA_OFFSET = offsetof (struct sdata, data) };
/* Structure describing a block of memory which is sub-allocated to
obtain string data memory for strings. Blocks for small strings
@@ -1326,8 +1457,8 @@ struct sblock
of the sblock if there isn't any space left in this block. */
sdata *next_free;
- /* Start of data. */
- sdata first_data;
+ /* String data. */
+ sdata data[FLEXIBLE_ARRAY_MEMBER];
};
/* Number of Lisp strings in a string_block structure. The 1020 is
@@ -1443,7 +1574,7 @@ 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)
+ - offsetof (struct sblock, data)
- SDATA_DATA_OFFSET)
& ~(sizeof (EMACS_INT) - 1)));
@@ -1470,9 +1601,7 @@ string_bytes (struct Lisp_String *s)
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;
}
@@ -1486,7 +1615,7 @@ check_sblock (struct sblock *b)
end = b->next_free;
- for (from = &b->first_data; from < end; from = from_end)
+ for (from = b->data; from < end; from = from_end)
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
@@ -1514,7 +1643,7 @@ check_string_bytes (bool all_p)
for (b = large_sblocks; b; b = b->next)
{
- struct Lisp_String *s = b->first_data.string;
+ struct Lisp_String *s = b->data[0].string;
if (s)
string_bytes (s);
}
@@ -1648,30 +1777,22 @@ allocate_string_data (struct Lisp_String *s,
if (nbytes > LARGE_STRING_BYTES)
{
- size_t size = offsetof (struct sblock, first_data) + needed;
+ size_t size = offsetof (struct sblock, data) + needed;
#ifdef DOUG_LEA_MALLOC
- /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
- because mapped region contents are not preserved in
- a dumped Emacs.
-
- In case you think of allowing it in a dumped Emacs at the
- cost of not being able to re-dump, there's another reason:
- mmap'ed data typically have an address towards the top of the
- address space, which won't fit into an EMACS_INT (at least on
- 32-bit systems with the current tagging scheme). --fx */
- mallopt (M_MMAP_MAX, 0);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, 0);
#endif
b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
#ifdef DOUG_LEA_MALLOC
- /* Back to a reasonable maximum of mmap'ed areas. */
- mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
- b->next_free = &b->first_data;
- b->first_data.string = NULL;
+ b->next_free = b->data;
+ b->data[0].string = NULL;
b->next = large_sblocks;
large_sblocks = b;
}
@@ -1682,8 +1803,8 @@ allocate_string_data (struct Lisp_String *s,
{
/* Not enough room in the current sblock. */
b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
- b->next_free = &b->first_data;
- b->first_data.string = NULL;
+ b->next_free = b->data;
+ b->data[0].string = NULL;
b->next = NULL;
if (current_sblock)
@@ -1728,6 +1849,7 @@ allocate_string_data (struct Lisp_String *s,
/* Sweep and compact strings. */
+NO_INLINE /* For better stack traces */
static void
sweep_strings (void)
{
@@ -1837,7 +1959,7 @@ free_large_strings (void)
{
next = b->next;
- if (b->first_data.string == NULL)
+ if (b->data[0].string == NULL)
lisp_free (b);
else
{
@@ -1864,7 +1986,7 @@ compact_small_strings (void)
to, and TB_END is the end of TB. */
tb = oldest_sblock;
tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
- to = &tb->first_data;
+ to = tb->data;
/* Step through the blocks from the oldest to the youngest. We
expect that old blocks will stabilize over time, so that less
@@ -1874,7 +1996,7 @@ compact_small_strings (void)
end = b->next_free;
eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
- for (from = &b->first_data; from < end; from = from_end)
+ for (from = b->data; from < end; from = from_end)
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
@@ -1911,7 +2033,7 @@ compact_small_strings (void)
tb->next_free = to;
tb = tb->next;
tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE);
- to = &tb->first_data;
+ to = tb->data;
to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
}
@@ -1955,7 +2077,6 @@ INIT must be an integer that represents a character. */)
(Lisp_Object length, Lisp_Object init)
{
register Lisp_Object val;
- register unsigned char *p, *end;
int c;
EMACS_INT nbytes;
@@ -1967,77 +2088,110 @@ INIT must be an integer that represents a character. */)
{
nbytes = XINT (length);
val = make_uninit_string (nbytes);
- p = SDATA (val);
- end = p + SCHARS (val);
- while (p != end)
- *p++ = c;
+ memset (SDATA (val), c, nbytes);
+ SDATA (val)[nbytes] = 0;
}
else
{
unsigned char str[MAX_MULTIBYTE_LENGTH];
- int len = CHAR_STRING (c, str);
+ ptrdiff_t len = CHAR_STRING (c, str);
EMACS_INT string_len = XINT (length);
+ unsigned char *p, *beg, *end;
if (string_len > STRING_BYTES_MAX / len)
string_overflow ();
nbytes = len * string_len;
val = make_uninit_multibyte_string (string_len, nbytes);
- p = SDATA (val);
- end = p + nbytes;
- while (p != end)
+ for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len)
{
- memcpy (p, str, len);
- p += len;
+ /* First time we just copy `str' to the data of `val'. */
+ if (p == beg)
+ memcpy (p, str, len);
+ else
+ {
+ /* Next time we copy largest possible chunk from
+ initialized to uninitialized part of `val'. */
+ len = min (p - beg, end - p);
+ memcpy (p, beg, len);
+ }
}
+ *p = 0;
}
- *p = 0;
return val;
}
+/* Fill A with 1 bits if INIT is non-nil, and with 0 bits otherwise.
+ Return A. */
-DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
- doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
-LENGTH must be a number. INIT matters only in whether it is t or nil. */)
- (Lisp_Object length, Lisp_Object init)
+Lisp_Object
+bool_vector_fill (Lisp_Object a, Lisp_Object init)
{
- register Lisp_Object val;
- struct Lisp_Bool_Vector *p;
- 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);
+ EMACS_INT nbits = bool_vector_size (a);
+ if (0 < nbits)
+ {
+ unsigned char *data = bool_vector_uchar_data (a);
+ int pattern = NILP (init) ? 0 : (1 << BOOL_VECTOR_BITS_PER_CHAR) - 1;
+ ptrdiff_t nbytes = bool_vector_bytes (nbits);
+ int last_mask = ~ (~0u << ((nbits - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1));
+ memset (data, pattern, nbytes - 1);
+ data[nbytes - 1] = pattern & last_mask;
+ }
+ return a;
+}
- CHECK_NATNUM (length);
+/* Return a newly allocated, uninitialized bool vector of size NBITS. */
- bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
+Lisp_Object
+make_uninit_bool_vector (EMACS_INT nbits)
+{
+ Lisp_Object val;
+ EMACS_INT words = bool_vector_words (nbits);
+ EMACS_INT word_bytes = words * sizeof (bits_word);
+ EMACS_INT needed_elements = ((bool_header_size - header_size + word_bytes
+ + word_size - 1)
+ / word_size);
+ struct Lisp_Bool_Vector *p
+ = (struct Lisp_Bool_Vector *) allocate_vector (needed_elements);
+ XSETVECTOR (val, p);
+ XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0);
+ p->size = nbits;
- length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
+ /* Clear padding at the end. */
+ if (words)
+ p->data[words - 1] = 0;
- val = Fmake_vector (make_number (length_in_elts + extra_bool_elts), Qnil);
+ return val;
+}
- /* No Lisp_Object to trace in there. */
- XSETPVECTYPESIZE (XVECTOR (val), PVEC_BOOL_VECTOR, 0, 0);
+DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
+ doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
+LENGTH must be a number. INIT matters only in whether it is t or nil. */)
+ (Lisp_Object length, Lisp_Object init)
+{
+ Lisp_Object val;
- p = XBOOL_VECTOR (val);
- p->size = XFASTINT (length);
+ CHECK_NATNUM (length);
+ val = make_uninit_bool_vector (XFASTINT (length));
+ return bool_vector_fill (val, init);
+}
- length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR);
- if (length_in_chars)
- {
- memset (p->data, ! NILP (init) ? -1 : 0, length_in_chars);
+DEFUN ("bool-vector", Fbool_vector, Sbool_vector, 0, MANY, 0,
+ doc: /* Return a new bool-vector with specified arguments as elements.
+Any number of arguments, even zero arguments, are allowed.
+usage: (bool-vector &rest OBJECTS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ ptrdiff_t i;
+ Lisp_Object vector;
- /* Clear any extraneous bits in the last byte. */
- p->data[length_in_chars - 1]
- &= (1 << ((XFASTINT (length) - 1) % BOOL_VECTOR_BITS_PER_CHAR + 1)) - 1;
- }
+ vector = make_uninit_bool_vector (nargs);
+ for (i = 0; i < nargs; i++)
+ bool_vector_set (vector, i, !NILP (args[i]));
- return val;
+ return vector;
}
-
/* Make a string from NBYTES bytes at CONTENTS, and compute the number
of characters from the contents. This string may be unibyte or
multibyte, depending on the contents. */
@@ -2059,8 +2213,7 @@ make_string (const char *contents, ptrdiff_t nbytes)
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)
@@ -2129,7 +2282,7 @@ make_specified_string (const char *contents,
}
-/* 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
@@ -2195,21 +2348,21 @@ make_formatted_string (char *buf, const char *format, ...)
#define FLOAT_BLOCK_SIZE \
(((BLOCK_BYTES - sizeof (struct float_block *) \
/* The compiler might add padding at the end. */ \
- - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
+ - (sizeof (struct Lisp_Float) - sizeof (bits_word))) * CHAR_BIT) \
/ (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
#define GETMARKBIT(block,n) \
- (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
- >> ((n) % (sizeof (int) * CHAR_BIT))) \
+ (((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
+ >> ((n) % BITS_PER_BITS_WORD)) \
& 1)
#define SETMARKBIT(block,n) \
- (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
- |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
+ ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
+ |= (bits_word) 1 << ((n) % BITS_PER_BITS_WORD))
#define UNSETMARKBIT(block,n) \
- (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
- &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
+ ((block)->gcmarkbits[(n) / BITS_PER_BITS_WORD] \
+ &= ~((bits_word) 1 << ((n) % BITS_PER_BITS_WORD)))
#define FLOAT_BLOCK(fptr) \
((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
@@ -2221,7 +2374,7 @@ struct float_block
{
/* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
- int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
+ bits_word gcmarkbits[1 + FLOAT_BLOCK_SIZE / BITS_PER_BITS_WORD];
struct float_block *next;
};
@@ -2302,7 +2455,7 @@ make_float (double float_value)
#define CONS_BLOCK_SIZE \
(((BLOCK_BYTES - sizeof (struct cons_block *) \
/* The compiler might add padding at the end. */ \
- - (sizeof (struct Lisp_Cons) - sizeof (int))) * CHAR_BIT) \
+ - (sizeof (struct Lisp_Cons) - sizeof (bits_word))) * CHAR_BIT) \
/ (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
#define CONS_BLOCK(fptr) \
@@ -2315,7 +2468,7 @@ struct cons_block
{
/* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
struct Lisp_Cons conses[CONS_BLOCK_SIZE];
- int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
+ bits_word gcmarkbits[1 + CONS_BLOCK_SIZE / BITS_PER_BITS_WORD];
struct cons_block *next;
};
@@ -2346,9 +2499,7 @@ void
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++;
@@ -2451,29 +2602,28 @@ list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, L
Lisp_Object
listn (enum constype type, ptrdiff_t count, Lisp_Object arg, ...)
{
- va_list ap;
- ptrdiff_t i;
- Lisp_Object val, *objp;
+ Lisp_Object (*cons) (Lisp_Object, Lisp_Object);
+ switch (type)
+ {
+ case CONSTYPE_PURE: cons = pure_cons; break;
+ case CONSTYPE_HEAP: cons = Fcons; break;
+ default: emacs_abort ();
+ }
- /* Change to SAFE_ALLOCA if you hit this eassert. */
- eassert (count <= MAX_ALLOCA / word_size);
+ eassume (0 < count);
+ Lisp_Object val = cons (arg, Qnil);
+ Lisp_Object tail = val;
- objp = alloca (count * word_size);
- objp[0] = arg;
+ va_list ap;
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--)
+ for (ptrdiff_t i = 1; i < count; i++)
{
- if (type == CONSTYPE_PURE)
- val = pure_cons (objp[i], val);
- else if (type == CONSTYPE_HEAP)
- val = Fcons (objp[i], val);
- else
- emacs_abort ();
+ Lisp_Object elem = cons (va_arg (ap, Lisp_Object), Qnil);
+ XSETCDR (tail, elem);
+ tail = elem;
}
+ va_end (ap);
+
return val;
}
@@ -2547,36 +2697,55 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
Vector Allocation
***********************************************************************/
+/* Sometimes a vector's contents are merely a pointer internally used
+ in vector allocation code. On the rare platforms where a null
+ pointer cannot be tagged, represent it with a Lisp 0.
+ Usually you don't want to touch this. */
+
+static struct Lisp_Vector *
+next_vector (struct Lisp_Vector *v)
+{
+ 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, Lisp_Int0);
+}
+
/* This value is balanced well enough to avoid too much internal overhead
for the most common cases; it's not required to be a power of two, but
it's expected to be a mult-of-ROUNDUP_SIZE (see below). */
#define VECTOR_BLOCK_SIZE 4096
-/* Align allocation request sizes to be a multiple of ROUNDUP_SIZE. */
enum
{
- roundup_size = COMMON_MULTIPLE (word_size, USE_LSB_TAG ? GCALIGNMENT : 1)
- };
+ /* Alignment of struct Lisp_Vector objects. */
+ vector_alignment = COMMON_MULTIPLE (ALIGNOF_STRUCT_LISP_VECTOR,
+ GCALIGNMENT),
-/* ROUNDUP_SIZE must be a power of 2. */
-verify ((roundup_size & (roundup_size - 1)) == 0);
+ /* Vector size requests are a multiple of this. */
+ roundup_size = COMMON_MULTIPLE (vector_alignment, word_size)
+ };
/* Verify assumptions described above. */
verify ((VECTOR_BLOCK_SIZE % roundup_size) == 0);
verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
-/* Round up X to nearest mult-of-ROUNDUP_SIZE. */
-
-#define vroundup(x) (((x) + (roundup_size - 1)) & ~(roundup_size - 1))
+/* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at compile time. */
+#define vroundup_ct(x) ROUNDUP (x, roundup_size)
+/* Round up X to nearest mult-of-ROUNDUP_SIZE --- use at runtime. */
+#define vroundup(x) (eassume ((x) >= 0), vroundup_ct (x))
/* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
-#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
+#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup_ct (sizeof (void *)))
/* Size of the minimal vector allocated from block. */
-#define VBLOCK_BYTES_MIN vroundup (header_size + sizeof (Lisp_Object))
+#define VBLOCK_BYTES_MIN vroundup_ct (header_size + sizeof (Lisp_Object))
/* Size of the largest vector allocated from block. */
@@ -2597,22 +2766,6 @@ verify (VECTOR_BLOCK_SIZE <= (1 << PSEUDOVECTOR_SIZE_BITS));
#define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
-/* Get and set the next field in block-allocated vectorlike objects on
- the free list. Doing it this way respects C's aliasing rules.
- We could instead make 'contents' a union, but that would mean
- changes everywhere that the code uses 'contents'. */
-static struct Lisp_Vector *
-next_in_free_list (struct Lisp_Vector *v)
-{
- intptr_t i = XLI (v->contents[0]);
- return (struct Lisp_Vector *) i;
-}
-static void
-set_next_in_free_list (struct Lisp_Vector *v, struct Lisp_Vector *next)
-{
- v->contents[0] = XIL ((intptr_t) next);
-}
-
/* Common shortcut to setup vector on a free list. */
#define SETUP_ON_FREE_LIST(v, nbytes, tmp) \
@@ -2622,26 +2775,37 @@ set_next_in_free_list (struct Lisp_Vector *v, struct Lisp_Vector *next)
eassert ((nbytes) % roundup_size == 0); \
(tmp) = VINDEX (nbytes); \
eassert ((tmp) < VECTOR_MAX_FREE_LIST_INDEX); \
- set_next_in_free_list (v, vector_free_lists[tmp]); \
+ set_next_vector (v, vector_free_lists[tmp]); \
vector_free_lists[tmp] = (v); \
total_free_vector_slots += (nbytes) / word_size; \
} while (0)
/* This internal type is used to maintain the list of large vectors
- which are allocated at their own, e.g. outside of vector blocks. */
+ which are allocated at their own, e.g. outside of vector blocks.
+
+ struct large_vector itself cannot contain a struct Lisp_Vector, as
+ the latter contains a flexible array member and C99 does not allow
+ such structs to be nested. Instead, each struct large_vector
+ object LV is followed by a struct Lisp_Vector, which is at offset
+ large_vector_offset from LV, and whose address is therefore
+ large_vector_vec (&LV). */
struct large_vector
{
- union {
- struct large_vector *vector;
-#if USE_LSB_TAG
- /* We need to maintain ROUNDUP_SIZE alignment for the vector member. */
- unsigned char c[vroundup (sizeof (struct large_vector *))];
-#endif
- } next;
- struct Lisp_Vector v;
+ struct large_vector *next;
};
+enum
+{
+ large_vector_offset = ROUNDUP (sizeof (struct large_vector), vector_alignment)
+};
+
+static struct Lisp_Vector *
+large_vector_vec (struct large_vector *p)
+{
+ return (struct Lisp_Vector *) ((char *) p + large_vector_offset);
+}
+
/* This internal type is used to maintain an underlying storage
for small vectors. */
@@ -2683,7 +2847,7 @@ allocate_vector_block (void)
{
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
@@ -2719,7 +2883,7 @@ allocate_vector_from_block (size_t nbytes)
if (vector_free_lists[index])
{
vector = vector_free_lists[index];
- vector_free_lists[index] = next_in_free_list (vector);
+ vector_free_lists[index] = next_vector (vector);
total_free_vector_slots -= nbytes / word_size;
return vector;
}
@@ -2733,7 +2897,7 @@ allocate_vector_from_block (size_t nbytes)
{
/* This vector is larger than requested. */
vector = vector_free_lists[index];
- vector_free_lists[index] = next_in_free_list (vector);
+ vector_free_lists[index] = next_vector (vector);
total_free_vector_slots -= nbytes / word_size;
/* Excess bytes are used for the smaller vector,
@@ -2773,31 +2937,67 @@ static ptrdiff_t
vector_nbytes (struct Lisp_Vector *v)
{
ptrdiff_t size = v->header.size & ~ARRAY_MARK_FLAG;
+ ptrdiff_t nwords;
if (size & PSEUDOVECTOR_FLAG)
{
if (PSEUDOVECTOR_TYPEP (&v->header, PVEC_BOOL_VECTOR))
- size = (bool_header_size
- + (((struct Lisp_Bool_Vector *) v)->size
- + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR);
+ {
+ struct Lisp_Bool_Vector *bv = (struct Lisp_Bool_Vector *) v;
+ ptrdiff_t word_bytes = (bool_vector_words (bv->size)
+ * sizeof (bits_word));
+ ptrdiff_t boolvec_bytes = bool_header_size + word_bytes;
+ verify (header_size <= bool_header_size);
+ nwords = (boolvec_bytes - header_size + word_size - 1) / word_size;
+ }
else
- size = (header_size
- + ((size & PSEUDOVECTOR_SIZE_MASK)
- + ((size & PSEUDOVECTOR_REST_MASK)
- >> PSEUDOVECTOR_SIZE_BITS)) * word_size);
+ nwords = ((size & PSEUDOVECTOR_SIZE_MASK)
+ + ((size & PSEUDOVECTOR_REST_MASK)
+ >> PSEUDOVECTOR_SIZE_BITS));
}
else
- size = header_size + size * word_size;
- return vroundup (size);
+ nwords = size;
+ return vroundup (header_size + word_size * nwords);
+}
+
+/* Release extra resources still in use by VECTOR, which may be any
+ vector-like object. */
+
+static void
+cleanup_vector (struct Lisp_Vector *vector)
+{
+ detect_suspicious_free (vector);
+ if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FONT)
+ && ((vector->header.size & PSEUDOVECTOR_SIZE_MASK)
+ == FONT_OBJECT_MAX))
+ {
+ struct font_driver *drv = ((struct font *) vector)->driver;
+
+ /* The font driver might sometimes be NULL, e.g. if Emacs was
+ interrupted before it had time to set it up. */
+ if (drv)
+ {
+ /* Attempt to catch subtle bugs like Bug#16140. */
+ eassert (valid_font_driver (drv));
+ drv->close ((struct font *) vector);
+ }
+ }
+
+ if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
+ finalize_one_thread ((struct thread_state *) vector);
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
+ finalize_one_mutex ((struct Lisp_Mutex *) vector);
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
+ finalize_one_condvar ((struct Lisp_CondVar *) vector);
}
/* Reclaim space used by unmarked vectors. */
+NO_INLINE /* For better stack traces */
static void
sweep_vectors (void)
{
- struct vector_block *block = vector_blocks, **bprev = &vector_blocks;
+ struct vector_block *block, **bprev = &vector_blocks;
struct large_vector *lv, **lvprev = &large_vectors;
struct Lisp_Vector *vector, *next;
@@ -2826,13 +3026,7 @@ sweep_vectors (void)
{
ptrdiff_t total_bytes;
- if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_THREAD))
- finalize_one_thread ((struct thread_state *) vector);
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MUTEX))
- finalize_one_mutex ((struct Lisp_Mutex *) vector);
- else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CONDVAR))
- finalize_one_condvar ((struct Lisp_CondVar *) vector);
-
+ cleanup_vector (vector);
nbytes = vector_nbytes (vector);
total_bytes = nbytes;
next = ADVANCE (vector, nbytes);
@@ -2844,6 +3038,7 @@ sweep_vectors (void)
{
if (VECTOR_MARKED_P (next))
break;
+ cleanup_vector (next);
nbytes = vector_nbytes (next);
total_bytes += nbytes;
next = ADVANCE (next, nbytes);
@@ -2853,12 +3048,12 @@ sweep_vectors (void)
if (vector == (struct Lisp_Vector *) block->data
&& !VECTOR_IN_BLOCK (next, block))
- /* This block should be freed because all of it's
+ /* This block should be freed because all of its
space was coalesced into the only free vector. */
free_this_block = 1;
else
{
- int tmp;
+ size_t tmp;
SETUP_ON_FREE_LIST (vector, total_bytes, tmp);
}
}
@@ -2867,7 +3062,7 @@ sweep_vectors (void)
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);
@@ -2880,33 +3075,27 @@ sweep_vectors (void)
for (lv = large_vectors; lv; lv = *lvprev)
{
- vector = &lv->v;
+ vector = large_vector_vec (lv);
if (VECTOR_MARKED_P (vector))
{
VECTOR_UNMARK (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;
+ total_vector_slots += vector_nbytes (vector) / word_size;
}
else
total_vector_slots
+= header_size / word_size + vector->header.size;
- lvprev = &lv->next.vector;
+ lvprev = &lv->next;
}
else
{
- *lvprev = lv->next.vector;
+ *lvprev = lv->next;
lisp_free (lv);
}
}
@@ -2929,10 +3118,8 @@ allocate_vectorlike (ptrdiff_t len)
size_t nbytes = header_size + len * word_size;
#ifdef DOUG_LEA_MALLOC
- /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
- because mapped region contents are not preserved in
- a dumped Emacs. */
- mallopt (M_MMAP_MAX, 0);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, 0);
#endif
if (nbytes <= VBLOCK_BYTES_MAX)
@@ -2940,19 +3127,22 @@ allocate_vectorlike (ptrdiff_t len)
else
{
struct large_vector *lv
- = lisp_malloc ((offsetof (struct large_vector, v.contents)
+ = lisp_malloc ((large_vector_offset + header_size
+ len * word_size),
MEM_TYPE_VECTORLIKE);
- lv->next.vector = large_vectors;
+ lv->next = large_vectors;
large_vectors = lv;
- p = &lv->v;
+ p = large_vector_vec (lv);
}
#ifdef DOUG_LEA_MALLOC
- /* Back to a reasonable maximum of mmap'ed areas. */
- mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+ if (!mmap_lisp_allowed_p ())
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
+ if (find_suspicious_object_in_range (p, (char *) p + nbytes))
+ emacs_abort ();
+
consing_since_gc += nbytes;
vector_cells_consed += len;
}
@@ -2982,20 +3172,19 @@ allocate_vector (EMACS_INT len)
/* 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;
}
@@ -3013,60 +3202,6 @@ allocate_buffer (void)
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'. */)
@@ -3088,7 +3223,6 @@ 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.
@@ -3107,6 +3241,9 @@ usage: (vector &rest OBJECTS) */)
void
make_byte_code (struct Lisp_Vector *v)
{
+ /* Don't allow the global zero_vector to become a byte code object. */
+ eassert (0 < v->header.size);
+
if (v->header.size > 1 && STRINGP (v->contents[1])
&& STRING_MULTIBYTE (v->contents[1]))
/* BYTECODE-STRING must have been produced by Emacs 20.2 or the
@@ -3162,15 +3299,13 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT
***********************************************************************/
/* 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
@@ -3192,6 +3327,13 @@ struct symbol_block
static struct symbol_block *symbol_block;
static int symbol_block_index = SYMBOL_BLOCK_SIZE;
+/* Pointer to the first symbol_block that contains pinned symbols.
+ Tests for 24.4 showed that at dump-time, Emacs contains about 15K symbols,
+ 10K of which are pinned (and all but 250 of them are interned in obarray),
+ whereas a "typical session" has in the order of 30K symbols.
+ `symbol_block_pinned' lets mark_pinned_symbols scan only 15K symbols rather
+ than 30K to find the 10K symbols we need to mark. */
+static struct symbol_block *symbol_block_pinned;
/* List of free symbols. */
@@ -3203,13 +3345,29 @@ set_symbol_name (Lisp_Object sym, Lisp_Object name)
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);
@@ -3237,17 +3395,7 @@ Its value is void, and its function definition and property list are nil. */)
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 = 0;
- p->interned = SYMBOL_UNINTERNED;
- p->constant = 0;
- p->declared_special = 0;
+ init_symbol (val, name);
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
total_free_symbols--;
@@ -3261,19 +3409,17 @@ Its value is void, and its function definition and property list are nil. */)
***********************************************************************/
/* 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))
@@ -3377,7 +3523,6 @@ make_save_obj_obj_obj_obj (Lisp_Object a, Lisp_Object b, Lisp_Object c,
return val;
}
-#if defined HAVE_NS || defined HAVE_NTGUI
Lisp_Object
make_save_ptr (void *a)
{
@@ -3387,7 +3532,6 @@ make_save_ptr (void *a)
p->data[0].pointer = a;
return val;
}
-#endif
Lisp_Object
make_save_ptr_int (void *a, ptrdiff_t b)
@@ -3400,7 +3544,7 @@ make_save_ptr_int (void *a, ptrdiff_t b)
return val;
}
-#if defined HAVE_MENUS && ! (defined USE_X_TOOLKIT || defined USE_GTK)
+#if ! (defined USE_X_TOOLKIT || defined USE_GTK)
Lisp_Object
make_save_ptr_ptr (void *a, void *b)
{
@@ -3478,6 +3622,7 @@ DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
p->charpos = 0;
p->next = NULL;
p->insertion_type = 0;
+ p->need_adjustment = 0;
return val;
}
@@ -3502,6 +3647,7 @@ build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
m->charpos = charpos;
m->bytepos = bytepos;
m->insertion_type = 0;
+ m->need_adjustment = 0;
m->next = BUF_MARKERS (buf);
BUF_MARKERS (buf) = m;
return obj;
@@ -3524,9 +3670,9 @@ free_marker (Lisp_Object marker)
Any number of arguments, even zero arguments, are allowed. */
Lisp_Object
-make_event_array (register int nargs, Lisp_Object *args)
+make_event_array (ptrdiff_t nargs, Lisp_Object *args)
{
- int i;
+ ptrdiff_t i;
for (i = 0; i < nargs; i++)
/* The things that fit in a string
@@ -3554,6 +3700,125 @@ make_event_array (register int nargs, Lisp_Object *args)
}
}
+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;
+}
/************************************************************************
@@ -3596,7 +3861,7 @@ memory_full (size_t nbytes)
memory_full_cons_threshold = sizeof (struct cons_block);
/* The first time we get here, free the spare memory. */
- for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
+ for (i = 0; i < ARRAYELTS (spare_memory); i++)
if (spare_memory[i])
{
if (i == 0)
@@ -3624,7 +3889,7 @@ memory_full (size_t nbytes)
void
refill_memory_reserve (void)
{
-#ifndef SYSTEM_MALLOC
+#if !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
if (spare_memory[0] == 0)
spare_memory[0] = malloc (SPARE_MEMORY);
if (spare_memory[1] == 0)
@@ -3654,8 +3919,6 @@ refill_memory_reserve (void)
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
@@ -3722,26 +3985,12 @@ mem_insert (void *start, void *end, enum mem_type type)
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);
@@ -4207,9 +4456,7 @@ live_vector_p (struct mem_node *m, void *p)
vector = ADVANCE (vector, vector_nbytes (vector));
}
}
- else if (m->type == MEM_TYPE_VECTORLIKE
- && (char *) p == ((char *) m->start
- + offsetof (struct large_vector, v)))
+ else if (m->type == MEM_TYPE_VECTORLIKE && p == large_vector_vec (m->start))
/* This memory node corresponds to a large vector. */
return 1;
return 0;
@@ -4226,84 +4473,28 @@ live_buffer_p (struct mem_node *m, void *p)
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));
+#endif
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))
{
@@ -4343,17 +4534,19 @@ mark_maybe_object (Lisp_Object 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.
+ Symbols are implemented via offsets not pointers, but the offsets
+ are also multiples of GCALIGNMENT. */
+
+static bool
+maybe_lisp_pointer (void *p)
+{
+ return (uintptr_t) p % GCALIGNMENT == 0;
+}
/* If P points to Lisp data, mark that as live if it isn't already
marked. */
@@ -4363,10 +4556,12 @@ mark_maybe_pointer (void *p)
{
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 GCALIGNMENT.
- Otherwise, assume that Lisp data is aligned on even addresses. */
- if ((intptr_t) p % (USE_LSB_TAG ? GCALIGNMENT : 2))
+#if USE_VALGRIND
+ if (valgrind_p)
+ VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p));
+#endif
+
+ if (!maybe_lisp_pointer (p))
return;
m = mem_find (p);
@@ -4438,48 +4633,15 @@ mark_maybe_pointer (void *p)
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
+static void ATTRIBUTE_NO_SANITIZE_ADDRESS
mark_memory (void *start, void *end)
-#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 GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- nzombies = 0;
-#endif
-
/* Make START the pointer to the start of the memory region,
if it isn't already. */
if (end < start)
@@ -4499,7 +4661,7 @@ mark_memory (void *start, void *end)
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;
}
@@ -4512,8 +4674,7 @@ mark_memory (void *start, void *end)
{
void *p = *(void **) ((char *) pp + i);
mark_maybe_pointer (p);
- if (POINTERS_MIGHT_HIDE_IN_OBJECTS)
- mark_maybe_object (XIL ((intptr_t) p));
+ mark_maybe_object (XIL ((intptr_t) p));
}
}
@@ -4601,42 +4762,6 @@ test_setjmp (void)
#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
@@ -4698,10 +4823,6 @@ mark_stack (char *bottom, char *end)
#ifdef GC_MARK_SECONDARY_STACK
GC_MARK_SECONDARY_STACK ();
#endif
-
-#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
- check_gcpros ();
-#endif
}
/* This is a trampoline function that flushes registers to the stack,
@@ -4711,7 +4832,7 @@ mark_stack (char *bottom, char *end)
global interpreter lock. This lets the garbage collector easily
find roots in registers on threads that are not actively running
Lisp.
-
+
It is invalid to run any Lisp code or to allocate any GC memory
from FUNC. */
@@ -4779,12 +4900,14 @@ flush_stack_call_func (void (*func) (void *arg), void *arg)
eassert (current_thread == self);
}
-#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
@@ -4793,6 +4916,10 @@ valid_pointer_p (void *p)
#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
@@ -4802,13 +4929,13 @@ valid_pointer_p (void *p)
if (emacs_pipe (fd) == 0)
{
- bool valid = emacs_write (fd[1], (char *) p, 16) == 16;
+ bool valid = emacs_write (fd[1], p, 16) == 16;
emacs_close (fd[1]);
emacs_close (fd[0]);
return valid;
}
- return -1;
+ return -1;
#endif
}
@@ -4822,26 +4949,20 @@ valid_pointer_p (void *p)
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)
{
@@ -4888,12 +5009,8 @@ valid_lisp_object_p (Lisp_Object obj)
}
return 0;
-#endif
}
-
-
-
/***********************************************************************
Pure Storage Management
***********************************************************************/
@@ -4906,22 +5023,13 @@ static void *
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
@@ -5070,6 +5178,8 @@ make_pure_c_string (const char *data, ptrdiff_t nchars)
return string;
}
+static Lisp_Object purecopy (Lisp_Object obj);
+
/* Return a cons allocated from pure space. Give it pure copies
of CAR as car and CDR as cdr. */
@@ -5079,8 +5189,8 @@ pure_cons (Lisp_Object car, Lisp_Object cdr)
Lisp_Object new;
struct Lisp_Cons *p = pure_alloc (sizeof *p, Lisp_Cons);
XSETCONS (new, p);
- XSETCAR (new, Fpurecopy (car));
- XSETCDR (new, Fpurecopy (cdr));
+ XSETCAR (new, purecopy (car));
+ XSETCDR (new, purecopy (cdr));
return new;
}
@@ -5112,7 +5222,6 @@ make_pure_vector (ptrdiff_t len)
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.
@@ -5121,9 +5230,25 @@ Does not copy symbols. Copies strings without text properties. */)
{
if (NILP (Vpurify_flag))
return obj;
-
- if (PURE_POINTER_P (XPNTR (obj)))
+ else if (MARKERP (obj) || OVERLAYP (obj)
+ || HASH_TABLE_P (obj) || SYMBOLP (obj))
+ /* Can't purify those. */
return obj;
+ else
+ return purecopy (obj);
+}
+
+static Lisp_Object
+purecopy (Lisp_Object 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. */
{
@@ -5140,31 +5265,36 @@ Does not copy symbols. Copies strings without text properties. */)
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] = Fpurecopy (AREF (obj, i));
- if (COMPILEDP (obj))
- {
- XSETPVECTYPE (vec, PVEC_COMPILED);
- XSETCOMPILED (obj, vec);
+ vec->contents[i] = purecopy (vec->contents[i]);
+ XSETVECTOR (obj, vec);
+ }
+ else if (SYMBOLP (obj))
+ {
+ 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;
}
- else
- XSETVECTOR (obj, vec);
+ /* Don't hash-cons it. */
+ return obj;
}
- else if (MARKERP (obj))
- error ("Attempt to copy a marker to pure storage");
else
- /* Not purified, don't hash-cons. */
- return obj;
+ {
+ 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. */
Fputhash (obj, obj, Vpurify_flag);
@@ -5231,29 +5361,136 @@ total_bytes_of_live_objects (void)
return tot;
}
-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,
-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)
+#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. */
+
+static Lisp_Object
+compact_font_cache_entry (Lisp_Object entry)
+{
+ Lisp_Object tail, *prev = &entry;
+
+ for (tail = entry; CONSP (tail); tail = XCDR (tail))
+ {
+ bool drop = 0;
+ 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)))
+ {
+ ptrdiff_t i, size = ASIZE (XCDR (obj)) & ~ARRAY_MARK_FLAG;
+
+ /* 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;
+
+ if (i == size)
+ drop = 1;
+ }
+ if (drop)
+ *prev = XCDR (tail);
+ else
+ prev = xcdr_addr (tail);
+ }
+ return entry;
+}
+
+#endif /* not HAVE_NTGUI */
+
+/* Compact font caches on all terminals and mark
+ everything which is still here after compaction. */
+
+static void
+compact_font_caches (void)
+{
+ struct terminal *t;
+
+ 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);
+ }
+}
+
+#else /* not HAVE_WINDOW_SYSTEM */
+
+#define compact_font_caches() (void)(0)
+
+#endif /* HAVE_WINDOW_SYSTEM */
+
+/* Remove (MARKER . DATA) entries with unmarked MARKER
+ from buffer undo LIST and return changed list. */
+
+static Lisp_Object
+compact_undo_list (Lisp_Object list)
+{
+ Lisp_Object tail, *prev = &list;
+
+ for (tail = list; CONSP (tail); tail = XCDR (tail))
+ {
+ if (CONSP (XCAR (tail))
+ && MARKERP (XCAR (XCAR (tail)))
+ && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
+ *prev = XCDR (tail);
+ else
+ prev = xcdr_addr (tail);
+ }
+ return list;
+}
+
+static void
+mark_pinned_symbols (void)
+{
+ struct symbol_block *sblk;
+ int lim = (symbol_block_pinned == symbol_block
+ ? symbol_block_index : SYMBOL_BLOCK_SIZE);
+
+ for (sblk = symbol_block_pinned; sblk; sblk = sblk->next)
+ {
+ union aligned_Lisp_Symbol *sym = sblk->symbols, *end = sym + lim;
+ for (; sym < end; ++sym)
+ if (sym->s.pinned)
+ mark_object (make_lisp_symbol (&sym->s));
+
+ lim = SYMBOL_BLOCK_SIZE;
+ }
+}
+
+/* Subroutine of Fgarbage_collect that does most of the work. It is a
+ separate function so that we could limit mark_stack in searching
+ the stack frames below this function, thus avoiding the rare cases
+ where mark_stack finds values that look like live Lisp objects on
+ portions of stack that couldn't possibly contain such live objects.
+ For more details of this, see the discussion at
+ http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00270.html. */
+static Lisp_Object
+garbage_collect_1 (void *end)
{
struct buffer *nextb;
char stack_top_variable;
ptrdiff_t i;
bool message_p;
ptrdiff_t count = SPECPDL_INDEX ();
- EMACS_TIME start;
+ struct timespec start;
Lisp_Object retval = Qnil;
size_t tot_before = 0;
@@ -5266,7 +5503,7 @@ See Info node `(elisp)Garbage Collection'. */)
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 ();
@@ -5278,7 +5515,7 @@ See Info node `(elisp)Garbage Collection'. */)
if (profiler_memory_running)
tot_before = total_bytes_of_live_objects ();
- start = current_emacs_time ();
+ start = current_timespec ();
/* In case user calls debug_print during GC,
don't let that cause a recursive GC. */
@@ -5311,7 +5548,7 @@ See Info node `(elisp)Garbage Collection'. */)
stack_copy = xrealloc (stack_copy, stack_size);
stack_copy_size = stack_size;
}
- memcpy (stack_copy, stack, stack_size);
+ no_sanitize_memcpy (stack_copy, stack, stack_size);
}
}
#endif /* MAX_SAVE_STACK > 0 */
@@ -5330,12 +5567,16 @@ See Info node `(elisp)Garbage Collection'. */)
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]);
- mark_threads ();
+ mark_pinned_symbols ();
mark_terminals ();
mark_kboards ();
+ mark_threads ();
#ifdef USE_GTK
xg_mark_data ();
@@ -5345,65 +5586,39 @@ See Info node `(elisp)Garbage Collection'. */)
mark_fringe_data ();
#endif
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- FIXME;
- mark_stack ();
-#endif
+ /* 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 ();
- /* Everything is now marked, except for the things that require special
- finalization, i.e. the undo_list.
- Look thru every buffer's undo list
- for elements that update markers that were not marked,
- and delete them. */
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));
+ if (!EQ (BVAR (nextb, undo_list), Qt))
+ bset_undo_list (nextb, compact_undo_list (BVAR (nextb, undo_list)));
+ /* 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 (BVAR (nextb, undo_list));
}
- gc_sweep ();
+ /* 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. */
- /* Clear the mark bits that we set in certain root slots. */
+ queue_doomed_finalizers (&doomed_finalizers, &finalizers);
+ mark_finalizer_list (&doomed_finalizers);
+
+ gc_sweep ();
unmark_threads ();
+
+ /* 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;
@@ -5438,71 +5653,47 @@ See Info node `(elisp)Garbage Collection'. */)
}
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))
{
@@ -5514,9 +5705,9 @@ See Info node `(elisp)Garbage Collection'. */)
/* Accumulate statistics. */
if (FLOATP (Vgc_elapsed))
{
- EMACS_TIME since_start = sub_emacs_time (current_emacs_time (), start);
+ struct timespec since_start = timespec_sub (current_timespec (), start);
Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed)
- + EMACS_TIME_TO_DOUBLE (since_start));
+ + timespectod (since_start));
}
gcs_done++;
@@ -5534,6 +5725,78 @@ See Info node `(elisp)Garbage Collection'. */)
return retval;
}
+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,
+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)
+{
+ void *end;
+
+#ifdef HAVE___BUILTIN_UNWIND_INIT
+ /* Force callee-saved registers and register windows onto the stack.
+ This is the preferred method if available, obviating the need for
+ machine dependent methods. */
+ __builtin_unwind_init ();
+ end = &end;
+#else /* not HAVE___BUILTIN_UNWIND_INIT */
+#ifndef GC_SAVE_REGISTERS_ON_STACK
+ /* jmp_buf may not be aligned enough on darwin-ppc64 */
+ union aligned_jmpbuf {
+ Lisp_Object o;
+ sys_jmp_buf j;
+ } j;
+ 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. */
+ /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
+ needed on ia64 too. See mach_dep.c, where it also says inline
+ assembler doesn't work with relevant proprietary compilers. */
+#ifdef __sparc__
+#if defined (__sparc64__) && defined (__FreeBSD__)
+ /* FreeBSD does not have a ta 3 handler. */
+ asm ("flushw");
+#else
+ asm ("ta 3");
+#endif
+#endif
+
+ /* Save registers that we need to see on the stack. We need to see
+ registers used to hold register variables and registers used to
+ pass parameters. */
+#ifdef GC_SAVE_REGISTERS_ON_STACK
+ GC_SAVE_REGISTERS_ON_STACK (end);
+#else /* not GC_SAVE_REGISTERS_ON_STACK */
+
+#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
+ setjmp will definitely work, test it
+ and print a message with the result
+ of the test. */
+ if (!setjmp_tested_p)
+ {
+ setjmp_tested_p = 1;
+ test_setjmp ();
+ }
+#endif /* GC_SETJMP_WORKS */
+
+ sys_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 */
+ return garbage_collect_1 (end);
+}
/* Mark Lisp objects in glyph matrix MATRIX. Currently the
only interesting objects referenced from glyphs are strings. */
@@ -5561,30 +5824,6 @@ mark_glyph_matrix (struct glyph_matrix *matrix)
}
}
-
-/* Mark Lisp faces in the face cache C. */
-
-static void
-mark_face_cache (struct face_cache *c)
-{
- if (c)
- {
- int i, j;
- for (i = 0; i < c->used; ++i)
- {
- struct face *face = FACE_FROM_ID (c->f, i);
-
- if (face)
- {
- for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
- mark_object (face->lface[j]);
- }
- }
- }
-}
-
-
-
/* Mark reference to a Lisp_Object.
If the object referred to has not been seen yet, recursively mark
all the references contained in it. */
@@ -5623,14 +5862,15 @@ mark_vectorlike (struct Lisp_Vector *ptr)
symbols. */
static void
-mark_char_table (struct Lisp_Vector *ptr)
+mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype)
{
int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
- int i;
+ /* Consult the Lisp_Sub_Char_Table layout before changing this. */
+ int i, idx = (pvectype == PVEC_SUB_CHAR_TABLE ? SUB_CHAR_TABLE_OFFSET : 0);
eassert (!VECTOR_MARKED_P (ptr));
VECTOR_MARK (ptr);
- for (i = 0; i < size; i++)
+ for (i = idx; i < size; i++)
{
Lisp_Object val = ptr->contents[i];
@@ -5639,13 +5879,26 @@ mark_char_table (struct Lisp_Vector *ptr)
if (SUB_CHAR_TABLE_P (val))
{
if (! VECTOR_MARKED_P (XVECTOR (val)))
- mark_char_table (XVECTOR (val));
+ mark_char_table (XVECTOR (val), PVEC_SUB_CHAR_TABLE);
}
else
mark_object (val);
}
}
+NO_INLINE /* To reduce stack depth in mark_object. */
+static Lisp_Object
+mark_compiled (struct Lisp_Vector *ptr)
+{
+ int i, size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
+
+ VECTOR_MARK (ptr);
+ for (i = 0; i < size; i++)
+ if (i != COMPILED_CONSTANTS)
+ mark_object (ptr->contents[i]);
+ return size > COMPILED_CONSTANTS ? ptr->contents[COMPILED_CONSTANTS] : Qnil;
+}
+
/* Mark the chain of overlays starting at PTR. */
static void
@@ -5654,8 +5907,9 @@ mark_overlay (struct Lisp_Overlay *ptr)
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);
}
}
@@ -5684,6 +5938,73 @@ mark_buffer (struct buffer *buffer)
mark_buffer (buffer->base_buffer);
}
+/* Mark Lisp faces in the face cache C. */
+
+NO_INLINE /* To reduce stack depth in mark_object. */
+static void
+mark_face_cache (struct face_cache *c)
+{
+ if (c)
+ {
+ int i, j;
+ for (i = 0; i < c->used; ++i)
+ {
+ struct face *face = FACE_FROM_ID (c->f, i);
+
+ if (face)
+ {
+ if (face->font && !VECTOR_MARKED_P (face->font))
+ mark_vectorlike ((struct Lisp_Vector *) face->font);
+
+ for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
+ mark_object (face->lface[j]);
+ }
+ }
+ }
+}
+
+NO_INLINE /* To reduce stack depth in mark_object. */
+static void
+mark_localized_symbol (struct Lisp_Symbol *ptr)
+{
+ struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
+ Lisp_Object where = blv->where;
+ /* If the value is set up for a killed buffer or deleted
+ frame, restore its global binding. If the value is
+ forwarded to a C variable, either it's not a Lisp_Object
+ var, or it's staticpro'd already. */
+ if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
+ || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
+ swap_in_global_binding (ptr);
+ mark_object (blv->where);
+ mark_object (blv->valcell);
+ mark_object (blv->defcell);
+}
+
+NO_INLINE /* To reduce stack depth in mark_object. */
+static void
+mark_save_value (struct Lisp_Save_Value *ptr)
+{
+ /* If `save_type' is zero, `data[0].pointer' is the address
+ of a memory area containing `data[1].integer' potential
+ Lisp_Objects. */
+ if (ptr->save_type == SAVE_TYPE_MEMORY)
+ {
+ Lisp_Object *p = ptr->data[0].pointer;
+ ptrdiff_t nelt;
+ for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++)
+ mark_maybe_object (*p);
+ }
+ else
+ {
+ /* Find Lisp_Objects in `data[N]' slots and mark them. */
+ int i;
+ for (i = 0; i < SAVE_VALUE_SLOTS; i++)
+ if (save_type (ptr, i) == SAVE_OBJECT)
+ mark_object (ptr->data[i].object);
+ }
+}
+
/* Remove killed buffers or items whose car is a killed buffer from
LIST, and mark other items. Return changed LIST, which is marked. */
@@ -5711,21 +6032,29 @@ mark_discard_killed_buffers (Lisp_Object list)
return list;
}
-/* Determine type of generic Lisp_Object and mark it accordingly. */
+/* Determine type of generic Lisp_Object and mark it accordingly.
+
+ This function implements a straightforward depth-first marking
+ algorithm and so the recursion depth may be very high (a few
+ tens of thousands is not uncommon). To minimize stack usage,
+ a few cold paths are moved out to NO_INLINE functions above.
+ In general, inlining them doesn't help you to gain more speed. */
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;
@@ -5734,11 +6063,9 @@ mark_object (Lisp_Object arg)
/* 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() \
@@ -5756,17 +6083,28 @@ mark_object (Lisp_Object arg)
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 */
@@ -5828,27 +6166,31 @@ mark_object (Lisp_Object arg)
break;
case PVEC_COMPILED:
- { /* We could treat this just like a vector, but it is better
- to save the COMPILED_CONSTANTS element for last and avoid
- recursion there. */
- int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
- int i;
-
- VECTOR_MARK (ptr);
- for (i = 0; i < size; i++)
- if (i != COMPILED_CONSTANTS)
- mark_object (ptr->contents[i]);
- if (size > COMPILED_CONSTANTS)
- {
- obj = ptr->contents[COMPILED_CONSTANTS];
- goto loop;
- }
- }
+ /* Although we could treat this just like a vector, mark_compiled
+ returns the COMPILED_CONSTANTS element, which is marked at the
+ next iteration of goto-loop here. This is done to avoid a few
+ recursive calls to mark_object. */
+ obj = mark_compiled (ptr);
+ if (!NILP (obj))
+ goto loop;
break;
case PVEC_FRAME:
- mark_vectorlike (ptr);
- mark_face_cache (((struct frame *) ptr)->face_cache);
+ {
+ struct frame *f = (struct frame *) ptr;
+
+ mark_vectorlike (ptr);
+ mark_face_cache (f->face_cache);
+#ifdef HAVE_WINDOW_SYSTEM
+ if (FRAME_WINDOW_P (f) && FRAME_X_OUTPUT (f))
+ {
+ struct font *font = FRAME_FONT (f);
+
+ if (font && !VECTOR_MARKED_P (font))
+ mark_vectorlike ((struct Lisp_Vector *) font);
+ }
+#endif
+ }
break;
case PVEC_WINDOW:
@@ -5895,7 +6237,8 @@ mark_object (Lisp_Object arg)
break;
case PVEC_CHAR_TABLE:
- mark_char_table (ptr);
+ case PVEC_SUB_CHAR_TABLE:
+ mark_char_table (ptr, (enum pvec_type) pvectype);
break;
case PVEC_BOOL_VECTOR:
@@ -5918,12 +6261,13 @@ mark_object (Lisp_Object arg)
case Lisp_Symbol:
{
register struct Lisp_Symbol *ptr = XSYMBOL (obj);
- struct Lisp_Symbol *ptrx;
-
+ 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));
mark_object (ptr->function);
mark_object (ptr->plist);
switch (ptr->redirect)
@@ -5937,21 +6281,8 @@ mark_object (Lisp_Object arg)
break;
}
case SYMBOL_LOCALIZED:
- {
- struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
- Lisp_Object where = blv->where;
- /* If the value is set up for a killed buffer or deleted
- frame, restore it's global binding. If the value is
- forwarded to a C variable, either it's not a Lisp_Object
- var, or it's staticpro'd already. */
- if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
- || (FRAMEP (where) && !FRAME_LIVE_P (XFRAME (where))))
- swap_in_global_binding (ptr);
- mark_object (blv->where);
- mark_object (blv->valcell);
- mark_object (blv->defcell);
- break;
- }
+ mark_localized_symbol (ptr);
+ break;
case SYMBOL_FORWARDED:
/* If the value is forwarded to a buffer or keyboard field,
these are marked when we see the corresponding object.
@@ -5960,17 +6291,13 @@ mark_object (Lisp_Object arg)
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));
-
- ptr = ptr->next;
+ /* Inner loop to mark next symbol in this bucket, if any. */
+ po = ptr = ptr->next;
if (ptr)
- {
- ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun. */
- XSETSYMBOL (obj, ptrx);
- goto loop;
- }
+ goto nextsym;
}
break;
@@ -5991,32 +6318,17 @@ mark_object (Lisp_Object arg)
case Lisp_Misc_Save_Value:
XMISCANY (obj)->gcmarkbit = 1;
- {
- struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
- /* 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)
- {
- Lisp_Object *p = ptr->data[0].pointer;
- ptrdiff_t nelt;
- for (nelt = ptr->data[1].integer; nelt > 0; nelt--, p++)
- mark_maybe_object (*p);
- }
- else
- {
- /* Find Lisp_Objects in `data[N]' slots and mark them. */
- int i;
- for (i = 0; i < SAVE_VALUE_SLOTS; i++)
- if (save_type (ptr, i) == SAVE_OBJECT)
- mark_object (ptr->data[i].object);
- }
- }
+ mark_save_value (XSAVE_VALUE (obj));
break;
case Lisp_Misc_Overlay:
mark_overlay (XOVERLAY (obj));
- break;
+ break;
+
+ case Lisp_Misc_Finalizer:
+ XMISCANY (obj)->gcmarkbit = true;
+ mark_object (XFINALIZER (obj)->function);
+ break;
default:
emacs_abort ();
@@ -6126,343 +6438,403 @@ survives_gc_p (Lisp_Object obj)
emacs_abort ();
}
- return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
+ return survives_p || PURE_P (XPNTR (obj));
}
-/* Sweep: find all structures not marked, and free them. */
+NO_INLINE /* For better stack traces */
static void
-gc_sweep (void)
+sweep_conses (void)
{
- /* Remove or mark entries in weak hash tables.
- This must be done before any object is unmarked. */
- sweep_weak_hash_tables ();
+ struct cons_block *cblk;
+ struct cons_block **cprev = &cons_block;
+ int lim = cons_block_index;
+ EMACS_INT num_free = 0, num_used = 0;
- sweep_strings ();
- check_string_bytes (!noninteractive);
+ cons_free_list = 0;
- /* Put all unmarked conses on free list */
- {
- register struct cons_block *cblk;
- struct cons_block **cprev = &cons_block;
- register int lim = cons_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+ for (cblk = cons_block; cblk; cblk = *cprev)
+ {
+ int i = 0;
+ int this_free = 0;
+ int ilim = (lim + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD;
+
+ /* Scan the mark bits an int at a time. */
+ for (i = 0; i < ilim; i++)
+ {
+ if (cblk->gcmarkbits[i] == BITS_WORD_MAX)
+ {
+ /* Fast path - all cons cells for this int are marked. */
+ cblk->gcmarkbits[i] = 0;
+ num_used += BITS_PER_BITS_WORD;
+ }
+ else
+ {
+ /* Some cons cells for this int are not marked.
+ Find which ones, and free them. */
+ int start, pos, stop;
+
+ start = i * BITS_PER_BITS_WORD;
+ stop = lim - start;
+ if (stop > BITS_PER_BITS_WORD)
+ stop = BITS_PER_BITS_WORD;
+ stop += start;
+
+ for (pos = start; pos < stop; pos++)
+ {
+ if (!CONS_MARKED_P (&cblk->conses[pos]))
+ {
+ this_free++;
+ cblk->conses[pos].u.chain = cons_free_list;
+ cons_free_list = &cblk->conses[pos];
+ cons_free_list->car = Vdead;
+ }
+ else
+ {
+ num_used++;
+ CONS_UNMARK (&cblk->conses[pos]);
+ }
+ }
+ }
+ }
- cons_free_list = 0;
+ lim = CONS_BLOCK_SIZE;
+ /* If this block contains only free conses and we have already
+ seen more than two blocks worth of free conses then deallocate
+ this block. */
+ if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
+ {
+ *cprev = cblk->next;
+ /* Unhook from the free list. */
+ cons_free_list = cblk->conses[0].u.chain;
+ lisp_align_free (cblk);
+ }
+ else
+ {
+ num_free += this_free;
+ cprev = &cblk->next;
+ }
+ }
+ total_conses = num_used;
+ total_free_conses = num_free;
+}
- for (cblk = cons_block; cblk; cblk = *cprev)
- {
- register int i = 0;
- int this_free = 0;
- int ilim = (lim + BITS_PER_INT - 1) / BITS_PER_INT;
+NO_INLINE /* For better stack traces */
+static void
+sweep_floats (void)
+{
+ register struct float_block *fblk;
+ struct float_block **fprev = &float_block;
+ register int lim = float_block_index;
+ EMACS_INT num_free = 0, num_used = 0;
- /* Scan the mark bits an int at a time. */
- for (i = 0; i < ilim; i++)
- {
- if (cblk->gcmarkbits[i] == -1)
- {
- /* Fast path - all cons cells for this int are marked. */
- cblk->gcmarkbits[i] = 0;
- num_used += BITS_PER_INT;
- }
- else
- {
- /* Some cons cells for this int are not marked.
- Find which ones, and free them. */
- int start, pos, stop;
-
- start = i * BITS_PER_INT;
- stop = lim - start;
- if (stop > BITS_PER_INT)
- stop = BITS_PER_INT;
- stop += start;
-
- for (pos = start; pos < stop; pos++)
- {
- if (!CONS_MARKED_P (&cblk->conses[pos]))
- {
- 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
- {
- num_used++;
- CONS_UNMARK (&cblk->conses[pos]);
- }
- }
- }
- }
+ float_free_list = 0;
- lim = CONS_BLOCK_SIZE;
- /* If this block contains only free conses and we have already
- seen more than two blocks worth of free conses then deallocate
- this block. */
- if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
- {
- *cprev = cblk->next;
- /* Unhook from the free list. */
- cons_free_list = cblk->conses[0].u.chain;
- lisp_align_free (cblk);
- }
- else
- {
- num_free += this_free;
- cprev = &cblk->next;
- }
- }
- total_conses = num_used;
- total_free_conses = num_free;
- }
+ for (fblk = float_block; fblk; fblk = *fprev)
+ {
+ register int i;
+ int this_free = 0;
+ for (i = 0; i < lim; i++)
+ if (!FLOAT_MARKED_P (&fblk->floats[i]))
+ {
+ this_free++;
+ fblk->floats[i].u.chain = float_free_list;
+ float_free_list = &fblk->floats[i];
+ }
+ else
+ {
+ num_used++;
+ FLOAT_UNMARK (&fblk->floats[i]);
+ }
+ lim = FLOAT_BLOCK_SIZE;
+ /* If this block contains only free floats and we have already
+ seen more than two blocks worth of free floats then deallocate
+ this block. */
+ if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
+ {
+ *fprev = fblk->next;
+ /* Unhook from the free list. */
+ float_free_list = fblk->floats[0].u.chain;
+ lisp_align_free (fblk);
+ }
+ else
+ {
+ num_free += this_free;
+ fprev = &fblk->next;
+ }
+ }
+ total_floats = num_used;
+ total_free_floats = num_free;
+}
- /* Put all unmarked floats on free list */
- {
- register struct float_block *fblk;
- struct float_block **fprev = &float_block;
- register int lim = float_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+NO_INLINE /* For better stack traces */
+static void
+sweep_intervals (void)
+{
+ register struct interval_block *iblk;
+ struct interval_block **iprev = &interval_block;
+ register int lim = interval_block_index;
+ EMACS_INT num_free = 0, num_used = 0;
- float_free_list = 0;
+ interval_free_list = 0;
- for (fblk = float_block; fblk; fblk = *fprev)
- {
- register int i;
- int this_free = 0;
- for (i = 0; i < lim; i++)
- if (!FLOAT_MARKED_P (&fblk->floats[i]))
- {
- this_free++;
- fblk->floats[i].u.chain = float_free_list;
- float_free_list = &fblk->floats[i];
- }
- else
- {
- num_used++;
- FLOAT_UNMARK (&fblk->floats[i]);
- }
- lim = FLOAT_BLOCK_SIZE;
- /* If this block contains only free floats and we have already
- seen more than two blocks worth of free floats then deallocate
- this block. */
- if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
- {
- *fprev = fblk->next;
- /* Unhook from the free list. */
- float_free_list = fblk->floats[0].u.chain;
- lisp_align_free (fblk);
- }
- else
- {
- num_free += this_free;
- fprev = &fblk->next;
- }
- }
- total_floats = num_used;
- total_free_floats = num_free;
- }
+ for (iblk = interval_block; iblk; iblk = *iprev)
+ {
+ register int i;
+ int this_free = 0;
+
+ for (i = 0; i < lim; i++)
+ {
+ if (!iblk->intervals[i].gcmarkbit)
+ {
+ set_interval_parent (&iblk->intervals[i], interval_free_list);
+ interval_free_list = &iblk->intervals[i];
+ this_free++;
+ }
+ else
+ {
+ num_used++;
+ iblk->intervals[i].gcmarkbit = 0;
+ }
+ }
+ lim = INTERVAL_BLOCK_SIZE;
+ /* If this block contains only free intervals and we have already
+ seen more than two blocks worth of free intervals then
+ deallocate this block. */
+ if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
+ {
+ *iprev = iblk->next;
+ /* Unhook from the free list. */
+ interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
+ lisp_free (iblk);
+ }
+ else
+ {
+ num_free += this_free;
+ iprev = &iblk->next;
+ }
+ }
+ total_intervals = num_used;
+ total_free_intervals = num_free;
+}
- /* Put all unmarked intervals on free list */
- {
- register struct interval_block *iblk;
- struct interval_block **iprev = &interval_block;
- register int lim = interval_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+NO_INLINE /* For better stack traces */
+static void
+sweep_symbols (void)
+{
+ struct symbol_block *sblk;
+ struct symbol_block **sprev = &symbol_block;
+ int lim = symbol_block_index;
+ EMACS_INT num_free = 0, num_used = ARRAYELTS (lispsym);
- interval_free_list = 0;
+ symbol_free_list = NULL;
- for (iblk = interval_block; iblk; iblk = *iprev)
- {
- register int i;
- int this_free = 0;
+ for (int i = 0; i < ARRAYELTS (lispsym); i++)
+ lispsym[i].gcmarkbit = 0;
- for (i = 0; i < lim; i++)
- {
- if (!iblk->intervals[i].gcmarkbit)
- {
- set_interval_parent (&iblk->intervals[i], interval_free_list);
- interval_free_list = &iblk->intervals[i];
- this_free++;
- }
- else
- {
- num_used++;
- iblk->intervals[i].gcmarkbit = 0;
- }
- }
- lim = INTERVAL_BLOCK_SIZE;
- /* If this block contains only free intervals and we have already
- seen more than two blocks worth of free intervals then
- deallocate this block. */
- if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
- {
- *iprev = iblk->next;
- /* Unhook from the free list. */
- interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
- lisp_free (iblk);
- }
- else
- {
- num_free += this_free;
- iprev = &iblk->next;
- }
- }
- total_intervals = num_used;
- total_free_intervals = num_free;
- }
+ for (sblk = symbol_block; sblk; sblk = *sprev)
+ {
+ int this_free = 0;
+ union aligned_Lisp_Symbol *sym = sblk->symbols;
+ union aligned_Lisp_Symbol *end = sym + lim;
+
+ for (; sym < end; ++sym)
+ {
+ if (!sym->s.gcmarkbit)
+ {
+ if (sym->s.redirect == SYMBOL_LOCALIZED)
+ xfree (SYMBOL_BLV (&sym->s));
+ sym->s.next = symbol_free_list;
+ symbol_free_list = &sym->s;
+ symbol_free_list->function = Vdead;
+ ++this_free;
+ }
+ else
+ {
+ ++num_used;
+ sym->s.gcmarkbit = 0;
+ /* Attempt to catch bogus objects. */
+ eassert (valid_lisp_object_p (sym->s.function));
+ }
+ }
- /* Put all unmarked symbols on free list */
- {
- register struct symbol_block *sblk;
- struct symbol_block **sprev = &symbol_block;
- register int lim = symbol_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+ lim = SYMBOL_BLOCK_SIZE;
+ /* If this block contains only free symbols and we have already
+ seen more than two blocks worth of free symbols then deallocate
+ this block. */
+ if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
+ {
+ *sprev = sblk->next;
+ /* Unhook from the free list. */
+ symbol_free_list = sblk->symbols[0].s.next;
+ lisp_free (sblk);
+ }
+ else
+ {
+ num_free += this_free;
+ sprev = &sblk->next;
+ }
+ }
+ total_symbols = num_used;
+ total_free_symbols = num_free;
+}
- symbol_free_list = NULL;
+NO_INLINE /* For better stack traces. */
+static void
+sweep_misc (void)
+{
+ register struct marker_block *mblk;
+ struct marker_block **mprev = &marker_block;
+ register int lim = marker_block_index;
+ EMACS_INT num_free = 0, num_used = 0;
- for (sblk = symbol_block; sblk; sblk = *sprev)
- {
- int this_free = 0;
- union aligned_Lisp_Symbol *sym = sblk->symbols;
- union aligned_Lisp_Symbol *end = sym + lim;
+ /* Put all unmarked misc's on free list. For a marker, first
+ unchain it from the buffer it points into. */
- for (; sym < end; ++sym)
- {
- /* 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. */
- bool pure_p = PURE_POINTER_P (XSTRING (sym->s.name));
-
- if (!sym->s.gcmarkbit && !pure_p)
- {
- if (sym->s.redirect == SYMBOL_LOCALIZED)
- 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;
- if (!pure_p)
- UNMARK_STRING (XSTRING (sym->s.name));
- sym->s.gcmarkbit = 0;
- }
- }
+ marker_free_list = 0;
- lim = SYMBOL_BLOCK_SIZE;
- /* If this block contains only free symbols and we have already
- seen more than two blocks worth of free symbols then deallocate
- this block. */
- if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
- {
- *sprev = sblk->next;
- /* Unhook from the free list. */
- symbol_free_list = sblk->symbols[0].s.next;
- lisp_free (sblk);
- }
- else
- {
- num_free += this_free;
- sprev = &sblk->next;
- }
- }
- total_symbols = num_used;
- total_free_symbols = num_free;
- }
+ for (mblk = marker_block; mblk; mblk = *mprev)
+ {
+ register int i;
+ int this_free = 0;
+
+ for (i = 0; i < lim; i++)
+ {
+ if (!mblk->markers[i].m.u_any.gcmarkbit)
+ {
+ if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
+ unchain_marker (&mblk->markers[i].m.u_marker);
+ if (mblk->markers[i].m.u_any.type == Lisp_Misc_Finalizer)
+ unchain_finalizer (&mblk->markers[i].m.u_finalizer);
+ /* 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. */
+ mblk->markers[i].m.u_marker.type = Lisp_Misc_Free;
+ mblk->markers[i].m.u_free.chain = marker_free_list;
+ marker_free_list = &mblk->markers[i].m;
+ this_free++;
+ }
+ else
+ {
+ num_used++;
+ mblk->markers[i].m.u_any.gcmarkbit = 0;
+ }
+ }
+ lim = MARKER_BLOCK_SIZE;
+ /* If this block contains only free markers and we have already
+ seen more than two blocks worth of free markers then deallocate
+ this block. */
+ if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
+ {
+ *mprev = mblk->next;
+ /* Unhook from the free list. */
+ marker_free_list = mblk->markers[0].m.u_free.chain;
+ lisp_free (mblk);
+ }
+ else
+ {
+ num_free += this_free;
+ mprev = &mblk->next;
+ }
+ }
- /* Put all unmarked misc's on free list.
- For a marker, first unchain it from the buffer it points into. */
- {
- register struct marker_block *mblk;
- struct marker_block **mprev = &marker_block;
- register int lim = marker_block_index;
- EMACS_INT num_free = 0, num_used = 0;
+ total_markers = num_used;
+ total_free_markers = num_free;
+}
- marker_free_list = 0;
+NO_INLINE /* For better stack traces */
+static void
+sweep_buffers (void)
+{
+ register struct buffer *buffer, **bprev = &all_buffers;
- for (mblk = marker_block; mblk; mblk = *mprev)
+ total_buffers = 0;
+ for (buffer = all_buffers; buffer; buffer = *bprev)
+ if (!VECTOR_MARKED_P (buffer))
{
- register int i;
- int this_free = 0;
-
- for (i = 0; i < lim; i++)
- {
- if (!mblk->markers[i].m.u_any.gcmarkbit)
- {
- if (mblk->markers[i].m.u_any.type == Lisp_Misc_Marker)
- unchain_marker (&mblk->markers[i].m.u_marker);
- /* 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. */
- mblk->markers[i].m.u_marker.type = Lisp_Misc_Free;
- mblk->markers[i].m.u_free.chain = marker_free_list;
- marker_free_list = &mblk->markers[i].m;
- this_free++;
- }
- else
- {
- num_used++;
- mblk->markers[i].m.u_any.gcmarkbit = 0;
- }
- }
- lim = MARKER_BLOCK_SIZE;
- /* If this block contains only free markers and we have already
- seen more than two blocks worth of free markers then deallocate
- this block. */
- if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
- {
- *mprev = mblk->next;
- /* Unhook from the free list. */
- marker_free_list = mblk->markers[0].m.u_free.chain;
- lisp_free (mblk);
- }
- else
- {
- num_free += this_free;
- mprev = &mblk->next;
- }
+ *bprev = buffer->next;
+ lisp_free (buffer);
}
+ else
+ {
+ VECTOR_UNMARK (buffer);
+ /* Do not use buffer_(set|get)_intervals here. */
+ buffer->text->intervals = balance_intervals (buffer->text->intervals);
+ total_buffers++;
+ bprev = &buffer->next;
+ }
+}
- total_markers = num_used;
- total_free_markers = num_free;
- }
-
- /* Free all unmarked buffers */
- {
- register struct buffer *buffer, **bprev = &all_buffers;
-
- total_buffers = 0;
- for (buffer = all_buffers; buffer; buffer = *bprev)
- if (!VECTOR_MARKED_P (buffer))
- {
- *bprev = buffer->next;
- lisp_free (buffer);
- }
- else
- {
- VECTOR_UNMARK (buffer);
- /* Do not use buffer_(set|get)_intervals here. */
- buffer->text->intervals = balance_intervals (buffer->text->intervals);
- total_buffers++;
- bprev = &buffer->next;
- }
- }
+/* Sweep: find all structures not marked, and free them. */
+static void
+gc_sweep (void)
+{
+ /* Remove or mark entries in weak hash tables.
+ This must be done before any object is unmarked. */
+ sweep_weak_hash_tables ();
+ sweep_strings ();
+ check_string_bytes (!noninteractive);
+ sweep_conses ();
+ sweep_floats ();
+ sweep_intervals ();
+ sweep_symbols ();
+ sweep_misc ();
+ sweep_buffers ();
sweep_vectors ();
check_string_bytes (!noninteractive);
}
+DEFUN ("memory-info", Fmemory_info, Smemory_info, 0, 0, 0,
+ doc: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
+All values are in Kbytes. If there is no swap space,
+last two values are zero. If the system is not supported
+or memory information can't be obtained, return nil. */)
+ (void)
+{
+#if defined HAVE_LINUX_SYSINFO
+ struct sysinfo si;
+ uintmax_t units;
+ if (sysinfo (&si))
+ return Qnil;
+#ifdef LINUX_SYSINFO_UNIT
+ units = si.mem_unit;
+#else
+ units = 1;
+#endif
+ return list4i ((uintmax_t) si.totalram * units / 1024,
+ (uintmax_t) si.freeram * units / 1024,
+ (uintmax_t) si.totalswap * units / 1024,
+ (uintmax_t) si.freeswap * units / 1024);
+#elif defined WINDOWSNT
+ unsigned long long totalram, freeram, totalswap, freeswap;
+
+ if (w32_memory_info (&totalram, &freeram, &totalswap, &freeswap) == 0)
+ return list4i ((uintmax_t) totalram / 1024,
+ (uintmax_t) freeram / 1024,
+ (uintmax_t) totalswap / 1024,
+ (uintmax_t) freeswap / 1024);
+ else
+ return Qnil;
+#elif defined MSDOS
+ unsigned long totalram, freeram, totalswap, freeswap;
+
+ if (dos_memory_info (&totalram, &freeram, &totalswap, &freeswap) == 0)
+ return list4i ((uintmax_t) totalram / 1024,
+ (uintmax_t) freeram / 1024,
+ (uintmax_t) totalswap / 1024,
+ (uintmax_t) freeswap / 1024);
+ else
+ return Qnil;
+#else /* not HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
+ /* FIXME: add more systems. */
+ return Qnil;
+#endif /* HAVE_LINUX_SYSINFO, not WINDOWSNT, not MSDOS */
+}
-
/* Debugging aids. */
DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
@@ -6473,7 +6845,12 @@ We divide the value by 1024 to make sure it fits in a Lisp integer. */)
{
Lisp_Object end;
+#ifdef HAVE_NS
+ /* Avoid warning. sbrk has no relation to memory allocated anyway. */
+ XSETINT (end, 0);
+#else
XSETINT (end, (intptr_t) (char *) sbrk (0) / 1024);
+#endif
return end;
}
@@ -6504,6 +6881,21 @@ Frames, windows, buffers, and subprocesses count as vectors
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. */
@@ -6516,6 +6908,17 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max)
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;
@@ -6523,25 +6926,13 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max)
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;
}
@@ -6554,6 +6945,78 @@ which_symbols (Lisp_Object obj, EMACS_INT find_max)
return found;
}
+#ifdef SUSPICIOUS_OBJECT_CHECKING
+
+static void *
+find_suspicious_object_in_range (void *begin, void *end)
+{
+ char *begin_a = begin;
+ char *end_a = end;
+ int i;
+
+ for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
+ {
+ char *suspicious_object = suspicious_objects[i];
+ if (begin_a <= suspicious_object && suspicious_object < end_a)
+ return suspicious_object;
+ }
+
+ return NULL;
+}
+
+static void
+note_suspicious_free (void* ptr)
+{
+ struct suspicious_free_record* rec;
+
+ rec = &suspicious_free_history[suspicious_free_history_index++];
+ if (suspicious_free_history_index ==
+ ARRAYELTS (suspicious_free_history))
+ {
+ suspicious_free_history_index = 0;
+ }
+
+ memset (rec, 0, sizeof (*rec));
+ rec->suspicious_object = ptr;
+ backtrace (&rec->backtrace[0], ARRAYELTS (rec->backtrace));
+}
+
+static void
+detect_suspicious_free (void* ptr)
+{
+ int i;
+
+ eassert (ptr != NULL);
+
+ for (i = 0; i < ARRAYELTS (suspicious_objects); ++i)
+ if (suspicious_objects[i] == ptr)
+ {
+ note_suspicious_free (ptr);
+ suspicious_objects[i] = NULL;
+ }
+}
+
+#endif /* SUSPICIOUS_OBJECT_CHECKING */
+
+DEFUN ("suspicious-object", Fsuspicious_object, Ssuspicious_object, 1, 1, 0,
+ doc: /* Return OBJ, maybe marking it for extra scrutiny.
+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)
+{
+#ifdef SUSPICIOUS_OBJECT_CHECKING
+ /* Right now, we care only about vectors. */
+ if (VECTORLIKEP (obj))
+ {
+ suspicious_objects[suspicious_object_index++] = XVECTOR (obj);
+ if (suspicious_object_index == ARRAYELTS (suspicious_objects))
+ suspicious_object_index = 0;
+ }
+#endif
+ return obj;
+}
+
#ifdef ENABLE_CHECKING
bool suppress_checking;
@@ -6565,21 +7028,65 @@ die (const char *msg, const char *file, int line)
file, line, msg);
terminate_due_to_signal (SIGABRT, INT_MAX);
}
-#endif
-
+
+#endif /* ENABLE_CHECKING */
+
+#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. */
+
+NO_INLINE static void
+verify_alloca (void)
+{
+ int i;
+ enum { ALLOCA_CHECK_MAX = 256 };
+ /* Start from size of the smallest Lisp object. */
+ for (i = sizeof (struct Lisp_Cons); i <= ALLOCA_CHECK_MAX; i++)
+ {
+ void *ptr = alloca (i);
+ make_lisp_ptr (ptr, Lisp_Cons);
+ }
+}
+
+#else /* not ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
+
+#define verify_alloca() ((void) 0)
+
+#endif /* ENABLE_CHECKING && USE_STACK_LISP_OBJECTS */
+
/* Initialization. */
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;
-#if GC_MARK_STACK || defined GC_MALLOC_CHECK
+ verify_alloca ();
+ init_finalizer_list (&finalizers);
+ init_finalizer_list (&doomed_finalizers);
+
mem_init ();
Vdead = make_pure_string ("DEAD", 4, 4, 0);
-#endif
#ifdef DOUG_LEA_MALLOC
mallopt (M_TRIM_THRESHOLD, 128 * 1024); /* Trim threshold. */
@@ -6596,15 +7103,15 @@ init_alloc_once (void)
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;
+
+#if USE_VALGRIND
+ valgrind_p = RUNNING_ON_VALGRIND != 0;
+#endif
}
void
@@ -6642,6 +7149,7 @@ If this portion is smaller than `gc-cons-threshold', this is ignored. */);
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. */);
@@ -6704,11 +7212,12 @@ do hash-consing of the objects allocated to pure space. */);
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 (&Svector);
+ defsubr (&Sbool_vector);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
@@ -6716,14 +7225,13 @@ The time is in seconds as a floating point value. */);
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);
-
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- defsubr (&Sgc_status);
-#endif
+ defsubr (&Ssuspicious_object);
}
/* When compiled with GCC, GDB might say "No enum type named
@@ -6734,12 +7242,10 @@ The time is in seconds as a floating point value. */);
union
{
enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS;
- enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS;
+ enum char_table_specials char_table_specials;
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;
View Lorry Controller Status