/* Storage allocation and gc for GNU Emacs Lisp interpreter.
- Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
- 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
- Free Software Foundation, Inc.
+
+Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2012
+ Free Software Foundation, Inc.
This file is part of GNU Emacs.
#include <limits.h> /* For CHAR_BIT. */
#include <setjmp.h>
-#ifdef STDC_HEADERS
-#include <stddef.h> /* For offsetof, used by PSEUDOVECSIZE. */
-#endif
-
-#ifdef ALLOC_DEBUG
-#undef INLINE
-#endif
-
#include <signal.h>
-#ifdef HAVE_GTK_AND_PTHREAD
+#ifdef HAVE_PTHREAD
#include <pthread.h>
#endif
#include "process.h"
#include "intervals.h"
#include "puresize.h"
+#include "character.h"
#include "buffer.h"
#include "window.h"
#include "keyboard.h"
#include "frame.h"
#include "blockinput.h"
-#include "character.h"
#include "syssignal.h"
#include "termhooks.h" /* For struct terminal. */
#include <setjmp.h>
+#include <verify.h>
+
+/* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
+ Doable only if GC_MARK_STACK. */
+#if ! GC_MARK_STACK
+# undef GC_CHECK_MARKED_OBJECTS
+#endif
/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
- memory. Can do this only if using gmalloc.c. */
+ memory. Can do this only if using gmalloc.c and if not checking
+ marked objects. */
-#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
+#if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
+ || defined GC_CHECK_MARKED_OBJECTS)
#undef GC_MALLOC_CHECK
#endif
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#else
-extern POINTER_TYPE *sbrk ();
+#ifndef HAVE_UNISTD_H
+extern void *sbrk ();
#endif
-#ifdef HAVE_FCNTL_H
-#define INCLUDED_FCNTL
#include <fcntl.h>
-#endif
-#ifndef O_WRONLY
-#define O_WRONLY 1
-#endif
#ifdef WINDOWSNT
-#include <fcntl.h>
#include "w32.h"
#endif
#ifdef DOUG_LEA_MALLOC
#include <malloc.h>
-/* malloc.h #defines this as size_t, at least in glibc2. */
-#ifndef __malloc_size_t
-#define __malloc_size_t int
-#endif
/* Specify maximum number of areas to mmap. It would be nice to use a
value that explicitly means "no limit". */
/* The following come from gmalloc.c. */
-#define __malloc_size_t size_t
-extern __malloc_size_t _bytes_used;
-extern __malloc_size_t __malloc_extra_blocks;
+extern size_t _bytes_used;
+extern size_t __malloc_extra_blocks;
+extern void *_malloc_internal (size_t);
+extern void _free_internal (void *);
#endif /* not DOUG_LEA_MALLOC */
-#if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
+#if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
+#ifdef HAVE_PTHREAD
/* When GTK uses the file chooser dialog, different backends can be loaded
dynamically. One such a backend is the Gnome VFS backend that gets loaded
if you run Gnome. That backend creates several threads and also allocates
memory with malloc.
+ Also, gconf and gsettings may create several threads.
+
If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
functions below are called from malloc, there is a chance that one
of these threads preempts the Emacs main thread and the hook variables
} \
while (0)
-#else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
+#else /* ! defined HAVE_PTHREAD */
#define BLOCK_INPUT_ALLOC BLOCK_INPUT
#define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
-#endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
-
-/* Value of _bytes_used, when spare_memory was freed. */
-
-static __malloc_size_t bytes_used_when_full;
-
-static __malloc_size_t bytes_used_when_reconsidered;
+#endif /* ! defined HAVE_PTHREAD */
+#endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
#define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
#define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
-/* Value is the number of bytes/chars of S, a pointer to a struct
- Lisp_String. This must be used instead of STRING_BYTES (S) or
- S->size during GC, because S->size contains the mark bit for
+/* Value is the number of bytes of S, a pointer to a struct Lisp_String.
+ Be careful during GC, because S->size contains the mark bit for
strings. */
#define GC_STRING_BYTES(S) (STRING_BYTES (S))
-#define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
-/* Number of bytes of consing done since the last gc. */
-
-int consing_since_gc;
-
-/* Count the amount of consing of various sorts of space. */
+/* Global variables. */
+struct emacs_globals globals;
-EMACS_INT cons_cells_consed;
-EMACS_INT floats_consed;
-EMACS_INT vector_cells_consed;
-EMACS_INT symbols_consed;
-EMACS_INT string_chars_consed;
-EMACS_INT misc_objects_consed;
-EMACS_INT intervals_consed;
-EMACS_INT strings_consed;
-
-/* Minimum number of bytes of consing since GC before next GC. */
+/* Number of bytes of consing done since the last gc. */
-EMACS_INT gc_cons_threshold;
+EMACS_INT consing_since_gc;
/* Similar minimum, computed from Vgc_cons_percentage. */
EMACS_INT gc_relative_threshold;
-static Lisp_Object Vgc_cons_percentage;
-
/* Minimum number of bytes of consing since GC before next GC,
when memory is full. */
int abort_on_gc;
-/* Nonzero means display messages at beginning and end of GC. */
-
-int garbage_collection_messages;
-
-#ifndef VIRT_ADDR_VARIES
-extern
-#endif /* VIRT_ADDR_VARIES */
-int malloc_sbrk_used;
-
-#ifndef VIRT_ADDR_VARIES
-extern
-#endif /* VIRT_ADDR_VARIES */
-int malloc_sbrk_unused;
-
/* Number of live and free conses etc. */
-static int total_conses, total_markers, total_symbols, total_vector_size;
-static int total_free_conses, total_free_markers, total_free_symbols;
-static int total_free_floats, total_floats;
+static EMACS_INT total_conses, total_markers, total_symbols, total_vector_size;
+static EMACS_INT total_free_conses, total_free_markers, total_free_symbols;
+static EMACS_INT total_free_floats, total_floats;
/* Points to memory space allocated as "spare", to be freed if we run
out of memory. We keep one large block, four cons-blocks, and
static char *spare_memory[7];
-/* Amount of spare memory to keep in large reserve block. */
+/* Amount of spare memory to keep in large reserve block, or to see
+ whether this much is available when malloc fails on a larger request. */
#define SPARE_MEMORY (1 << 14)
static int malloc_hysteresis;
-/* Non-nil means defun should do purecopy on the function definition. */
-
-Lisp_Object Vpurify_flag;
-
-/* Non-nil means we are handling a memory-full error. */
-
-Lisp_Object Vmemory_full;
-
-#ifndef HAVE_SHM
-
/* Initialize it to a nonzero value to force it into data space
(rather than bss space). That way unexec will remap it into text
space (pure), on some systems. We have not implemented the
EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
#define PUREBEG (char *) pure
-#else /* HAVE_SHM */
-
-#define pure PURE_SEG_BITS /* Use shared memory segment */
-#define PUREBEG (char *)PURE_SEG_BITS
-
-#endif /* HAVE_SHM */
-
/* Pointer to the pure area, and its size. */
static char *purebeg;
-static size_t pure_size;
+static ptrdiff_t pure_size;
/* Number of bytes of pure storage used before pure storage overflowed.
If this is non-zero, this implies that an overflow occurred. */
-static size_t pure_bytes_used_before_overflow;
+static ptrdiff_t pure_bytes_used_before_overflow;
/* Value is non-zero if P points into pure space. */
#define PURE_POINTER_P(P) \
- (((PNTR_COMPARISON_TYPE) (P) \
- < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
- && ((PNTR_COMPARISON_TYPE) (P) \
- >= (PNTR_COMPARISON_TYPE) purebeg))
-
-/* Total number of bytes allocated in pure storage. */
-
-EMACS_INT pure_bytes_used;
+ ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
/* Index in pure at which next pure Lisp object will be allocated.. */
-static EMACS_INT pure_bytes_used_lisp;
+static ptrdiff_t pure_bytes_used_lisp;
/* Number of bytes allocated for non-Lisp objects in pure storage. */
-static EMACS_INT pure_bytes_used_non_lisp;
+static ptrdiff_t pure_bytes_used_non_lisp;
/* If nonzero, this is a warning delivered by malloc and not yet
displayed. */
-char *pending_malloc_warning;
-
-/* Pre-computed signal argument for use when memory is exhausted. */
-
-Lisp_Object Vmemory_signal_data;
+const char *pending_malloc_warning;
/* Maximum amount of C stack to save when a GC happens. */
/* Buffer in which we save a copy of the C stack at each GC. */
+#if MAX_SAVE_STACK > 0
static char *stack_copy;
-static int stack_copy_size;
+static ptrdiff_t stack_copy_size;
+#endif
/* Non-zero means ignore malloc warnings. Set during initialization.
Currently not used. */
static int ignore_warnings;
-Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
+static Lisp_Object Qgc_cons_threshold;
+Lisp_Object Qchar_table_extra_slots;
/* Hook run after GC has finished. */
-Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
-
-Lisp_Object Vgc_elapsed; /* accumulated elapsed time in GC */
-EMACS_INT gcs_done; /* accumulated GCs */
+static Lisp_Object Qpost_gc_hook;
-static void mark_buffer P_ ((Lisp_Object));
-static void mark_terminals P_ ((void));
-extern void mark_kboards P_ ((void));
-extern void mark_ttys P_ ((void));
-extern void mark_backtrace P_ ((void));
-static void gc_sweep P_ ((void));
-static void mark_glyph_matrix P_ ((struct glyph_matrix *));
-static void mark_face_cache P_ ((struct face_cache *));
+static void mark_terminals (void);
+static void gc_sweep (void);
+static Lisp_Object make_pure_vector (ptrdiff_t);
+static void mark_glyph_matrix (struct glyph_matrix *);
+static void mark_face_cache (struct face_cache *);
-#ifdef HAVE_WINDOW_SYSTEM
-extern void mark_fringe_data P_ ((void));
-#endif /* HAVE_WINDOW_SYSTEM */
-
-static struct Lisp_String *allocate_string P_ ((void));
-static void compact_small_strings P_ ((void));
-static void free_large_strings P_ ((void));
-static void sweep_strings P_ ((void));
-
-extern int message_enable_multibyte;
+#if !defined REL_ALLOC || defined SYSTEM_MALLOC
+static void refill_memory_reserve (void);
+#endif
+static struct Lisp_String *allocate_string (void);
+static void compact_small_strings (void);
+static void free_large_strings (void);
+static void sweep_strings (void);
+static void free_misc (Lisp_Object);
+extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE;
/* When scanning the C stack for live Lisp objects, Emacs keeps track
of what memory allocated via lisp_malloc is intended for what
process, hash_table, frame, terminal, and window, but we never made
use of the distinction, so it only caused source-code complexity
and runtime slowdown. Minor but pointless. */
- MEM_TYPE_VECTORLIKE
+ MEM_TYPE_VECTORLIKE,
+ /* Special type to denote vector blocks. */
+ MEM_TYPE_VECTOR_BLOCK
};
-static POINTER_TYPE *lisp_align_malloc P_ ((size_t, enum mem_type));
-static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
-void refill_memory_reserve ();
+static void *lisp_malloc (size_t, enum mem_type);
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
on free lists recognizable in O(1). */
static Lisp_Object Vdead;
+#define DEADP(x) EQ (x, Vdead)
#ifdef GC_MALLOC_CHECK
enum mem_type allocated_mem_type;
-static int dont_register_blocks;
#endif /* GC_MALLOC_CHECK */
static struct mem_node mem_z;
#define MEM_NIL &mem_z
-static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
-static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT));
-static void lisp_free P_ ((POINTER_TYPE *));
-static void mark_stack P_ ((void));
-static int live_vector_p P_ ((struct mem_node *, void *));
-static int live_buffer_p P_ ((struct mem_node *, void *));
-static int live_string_p P_ ((struct mem_node *, void *));
-static int live_cons_p P_ ((struct mem_node *, void *));
-static int live_symbol_p P_ ((struct mem_node *, void *));
-static int live_float_p P_ ((struct mem_node *, void *));
-static int live_misc_p P_ ((struct mem_node *, void *));
-static void mark_maybe_object P_ ((Lisp_Object));
-static void mark_memory P_ ((void *, void *, int));
-static void mem_init P_ ((void));
-static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
-static void mem_insert_fixup P_ ((struct mem_node *));
-static void mem_rotate_left P_ ((struct mem_node *));
-static void mem_rotate_right P_ ((struct mem_node *));
-static void mem_delete P_ ((struct mem_node *));
-static void mem_delete_fixup P_ ((struct mem_node *));
-static INLINE struct mem_node *mem_find P_ ((void *));
+static struct Lisp_Vector *allocate_vectorlike (ptrdiff_t);
+static void lisp_free (void *);
+static void mark_stack (void);
+static int live_vector_p (struct mem_node *, void *);
+static int live_buffer_p (struct mem_node *, void *);
+static int live_string_p (struct mem_node *, void *);
+static int live_cons_p (struct mem_node *, void *);
+static int live_symbol_p (struct mem_node *, void *);
+static int live_float_p (struct mem_node *, void *);
+static int live_misc_p (struct mem_node *, void *);
+static void mark_maybe_object (Lisp_Object);
+static void mark_memory (void *, void *);
+#if GC_MARK_STACK || defined GC_MALLOC_CHECK
+static void mem_init (void);
+static struct mem_node *mem_insert (void *, void *, enum mem_type);
+static void mem_insert_fixup (struct mem_node *);
+#endif
+static void mem_rotate_left (struct mem_node *);
+static void mem_rotate_right (struct mem_node *);
+static void mem_delete (struct mem_node *);
+static void mem_delete_fixup (struct mem_node *);
+static inline struct mem_node *mem_find (void *);
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
-static void check_gcpros P_ ((void));
+static void check_gcpros (void);
#endif
#endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
+#ifndef DEADP
+# define DEADP(x) 0
+#endif
+
/* Recording what needs to be marked for gc. */
struct gcpro *gcprolist;
/* Addresses of staticpro'd variables. Initialize it to a nonzero
value; otherwise some compilers put it into BSS. */
-#define NSTATICS 0x640
+#define NSTATICS 0x650
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
/* Index of next unused slot in staticvec. */
static int staticidx = 0;
-static POINTER_TYPE *pure_alloc P_ ((size_t, int));
+static void *pure_alloc (size_t, int);
/* Value is SZ rounded up to the next multiple of ALIGNMENT.
ALIGNMENT must be a power of 2. */
#define ALIGN(ptr, ALIGNMENT) \
- ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
- & ~((ALIGNMENT) - 1)))
+ ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
+ & ~ ((ALIGNMENT) - 1)))
\f
/* Function malloc calls this if it finds we are near exhausting storage. */
void
-malloc_warning (str)
- char *str;
+malloc_warning (const char *str)
{
pending_malloc_warning = str;
}
/* Display an already-pending malloc warning. */
void
-display_malloc_warning ()
+display_malloc_warning (void)
{
call3 (intern ("display-warning"),
intern ("alloc"),
intern ("emergency"));
pending_malloc_warning = 0;
}
-
-
-#ifdef DOUG_LEA_MALLOC
-# define BYTES_USED (mallinfo ().uordblks)
-#else
-# define BYTES_USED _bytes_used
-#endif
\f
/* Called if we can't allocate relocatable space for a buffer. */
void
-buffer_memory_full ()
+buffer_memory_full (ptrdiff_t nbytes)
{
/* If buffers use the relocating allocator, no need to free
spare_memory, because we may have plenty of malloc space left
malloc. */
#ifndef REL_ALLOC
- memory_full ();
+ memory_full (nbytes);
#endif
/* This used to call error, but if we've run out of memory, we could
xsignal (Qnil, Vmemory_signal_data);
}
+/* A common multiple of the positive integers A and B. Ideally this
+ would be the least common multiple, but there's no way to do that
+ as a constant expression in C, so do the best that we can easily do. */
+#define COMMON_MULTIPLE(a, b) \
+ ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
-#ifdef XMALLOC_OVERRUN_CHECK
+#ifndef XMALLOC_OVERRUN_CHECK
+#define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
+#else
-/* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
- and a 16 byte trailer around each block.
+/* Check for overrun in malloc'ed buffers by wrapping a header and trailer
+ around each block.
- The header consists of 12 fixed bytes + a 4 byte integer contaning the
- original block size, while the trailer consists of 16 fixed bytes.
+ The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
+ followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
+ block size in little-endian order. The trailer consists of
+ XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
The header is used to detect whether this block has been allocated
- through these functions -- as it seems that some low-level libc
- functions may bypass the malloc hooks.
-*/
-
+ through these functions, as some low-level libc functions may
+ bypass the malloc hooks. */
#define XMALLOC_OVERRUN_CHECK_SIZE 16
+#define XMALLOC_OVERRUN_CHECK_OVERHEAD \
+ (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
+
+/* 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 \
+ offsetof ( \
+ struct { \
+ union { long double d; intmax_t i; void *p; } u; \
+ char c; \
+ }, \
+ c)
+
+#if USE_LSB_TAG
+# define XMALLOC_HEADER_ALIGNMENT \
+ COMMON_MULTIPLE (1 << GCTYPEBITS, XMALLOC_BASE_ALIGNMENT)
+#else
+# define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
+#endif
+#define XMALLOC_OVERRUN_SIZE_SIZE \
+ (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
+ + XMALLOC_HEADER_ALIGNMENT - 1) \
+ / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
+ - XMALLOC_OVERRUN_CHECK_SIZE)
+
+static char const xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE] =
+ { '\x9a', '\x9b', '\xae', '\xaf',
+ '\xbf', '\xbe', '\xce', '\xcf',
+ '\xea', '\xeb', '\xec', '\xed',
+ '\xdf', '\xde', '\x9c', '\x9d' };
+
+static char const xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
+ { '\xaa', '\xab', '\xac', '\xad',
+ '\xba', '\xbb', '\xbc', '\xbd',
+ '\xca', '\xcb', '\xcc', '\xcd',
+ '\xda', '\xdb', '\xdc', '\xdd' };
+
+/* Insert and extract the block size in the header. */
-static char xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE-4] =
- { 0x9a, 0x9b, 0xae, 0xaf,
- 0xbf, 0xbe, 0xce, 0xcf,
- 0xea, 0xeb, 0xec, 0xed };
-
-static char xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
- { 0xaa, 0xab, 0xac, 0xad,
- 0xba, 0xbb, 0xbc, 0xbd,
- 0xca, 0xcb, 0xcc, 0xcd,
- 0xda, 0xdb, 0xdc, 0xdd };
-
-/* Macros to insert and extract the block size in the header. */
-
-#define XMALLOC_PUT_SIZE(ptr, size) \
- (ptr[-1] = (size & 0xff), \
- ptr[-2] = ((size >> 8) & 0xff), \
- ptr[-3] = ((size >> 16) & 0xff), \
- ptr[-4] = ((size >> 24) & 0xff))
+static void
+xmalloc_put_size (unsigned char *ptr, size_t size)
+{
+ int i;
+ for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
+ {
+ *--ptr = size & ((1 << CHAR_BIT) - 1);
+ size >>= CHAR_BIT;
+ }
+}
-#define XMALLOC_GET_SIZE(ptr) \
- (size_t)((unsigned)(ptr[-1]) | \
- ((unsigned)(ptr[-2]) << 8) | \
- ((unsigned)(ptr[-3]) << 16) | \
- ((unsigned)(ptr[-4]) << 24))
+static size_t
+xmalloc_get_size (unsigned char *ptr)
+{
+ size_t size = 0;
+ int i;
+ ptr -= XMALLOC_OVERRUN_SIZE_SIZE;
+ for (i = 0; i < XMALLOC_OVERRUN_SIZE_SIZE; i++)
+ {
+ size <<= CHAR_BIT;
+ size += *ptr++;
+ }
+ return size;
+}
/* The call depth in overrun_check functions. For example, this might happen:
xfree(10032)
overrun_check_free(10032)
- decrease overhed
+ decrease overhead
free(10016) <- crash, because 10000 is the original pointer. */
-static int check_depth;
+static ptrdiff_t check_depth;
/* Like malloc, but wraps allocated block with header and trailer. */
-POINTER_TYPE *
-overrun_check_malloc (size)
- size_t size;
+static void *
+overrun_check_malloc (size_t size)
{
register unsigned char *val;
- size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
+ int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0;
+ if (SIZE_MAX - overhead < size)
+ abort ();
- val = (unsigned char *) malloc (size + overhead);
+ val = malloc (size + overhead);
if (val && check_depth == 1)
{
- bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
- val += XMALLOC_OVERRUN_CHECK_SIZE;
- XMALLOC_PUT_SIZE(val, size);
- bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
+ memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
+ val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
+ xmalloc_put_size (val, size);
+ memcpy (val + size, xmalloc_overrun_check_trailer,
+ XMALLOC_OVERRUN_CHECK_SIZE);
}
--check_depth;
- return (POINTER_TYPE *)val;
+ return val;
}
/* Like realloc, but checks old block for overrun, and wraps new block
with header and trailer. */
-POINTER_TYPE *
-overrun_check_realloc (block, size)
- POINTER_TYPE *block;
- size_t size;
+static void *
+overrun_check_realloc (void *block, size_t size)
{
- register unsigned char *val = (unsigned char *)block;
- size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
+ register unsigned char *val = (unsigned char *) block;
+ int overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD : 0;
+ if (SIZE_MAX - overhead < size)
+ abort ();
if (val
&& check_depth == 1
- && bcmp (xmalloc_overrun_check_header,
- val - XMALLOC_OVERRUN_CHECK_SIZE,
- XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
+ && memcmp (xmalloc_overrun_check_header,
+ val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
+ XMALLOC_OVERRUN_CHECK_SIZE) == 0)
{
- size_t osize = XMALLOC_GET_SIZE (val);
- if (bcmp (xmalloc_overrun_check_trailer,
- val + osize,
- XMALLOC_OVERRUN_CHECK_SIZE))
+ size_t osize = xmalloc_get_size (val);
+ if (memcmp (xmalloc_overrun_check_trailer, val + osize,
+ XMALLOC_OVERRUN_CHECK_SIZE))
abort ();
- bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
- val -= XMALLOC_OVERRUN_CHECK_SIZE;
- bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
+ memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
+ val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
+ memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
}
- val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
+ val = realloc (val, size + overhead);
if (val && check_depth == 1)
{
- bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
- val += XMALLOC_OVERRUN_CHECK_SIZE;
- XMALLOC_PUT_SIZE(val, size);
- bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
+ memcpy (val, xmalloc_overrun_check_header, XMALLOC_OVERRUN_CHECK_SIZE);
+ val += XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
+ xmalloc_put_size (val, size);
+ memcpy (val + size, xmalloc_overrun_check_trailer,
+ XMALLOC_OVERRUN_CHECK_SIZE);
}
--check_depth;
- return (POINTER_TYPE *)val;
+ return val;
}
/* Like free, but checks block for overrun. */
-void
-overrun_check_free (block)
- POINTER_TYPE *block;
+static void
+overrun_check_free (void *block)
{
- unsigned char *val = (unsigned char *)block;
+ unsigned char *val = (unsigned char *) block;
++check_depth;
if (val
&& check_depth == 1
- && bcmp (xmalloc_overrun_check_header,
- val - XMALLOC_OVERRUN_CHECK_SIZE,
- XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
+ && memcmp (xmalloc_overrun_check_header,
+ val - XMALLOC_OVERRUN_CHECK_SIZE - XMALLOC_OVERRUN_SIZE_SIZE,
+ XMALLOC_OVERRUN_CHECK_SIZE) == 0)
{
- size_t osize = XMALLOC_GET_SIZE (val);
- if (bcmp (xmalloc_overrun_check_trailer,
- val + osize,
- XMALLOC_OVERRUN_CHECK_SIZE))
+ size_t osize = xmalloc_get_size (val);
+ if (memcmp (xmalloc_overrun_check_trailer, val + osize,
+ XMALLOC_OVERRUN_CHECK_SIZE))
abort ();
#ifdef XMALLOC_CLEAR_FREE_MEMORY
- val -= XMALLOC_OVERRUN_CHECK_SIZE;
- memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_SIZE*2);
+ val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
+ memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_OVERHEAD);
#else
- bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
- val -= XMALLOC_OVERRUN_CHECK_SIZE;
- bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
+ memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
+ val -= XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE;
+ memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE);
#endif
}
/* Like malloc but check for no memory and block interrupt input.. */
-POINTER_TYPE *
-xmalloc (size)
- size_t size;
+void *
+xmalloc (size_t size)
{
- register POINTER_TYPE *val;
+ void *val;
MALLOC_BLOCK_INPUT;
- val = (POINTER_TYPE *) malloc (size);
+ val = malloc (size);
MALLOC_UNBLOCK_INPUT;
if (!val && size)
- memory_full ();
+ memory_full (size);
return val;
}
+/* Like the above, but zeroes out the memory just allocated. */
+
+void *
+xzalloc (size_t size)
+{
+ void *val;
+
+ MALLOC_BLOCK_INPUT;
+ val = malloc (size);
+ MALLOC_UNBLOCK_INPUT;
+
+ if (!val && size)
+ memory_full (size);
+ memset (val, 0, size);
+ return val;
+}
/* Like realloc but check for no memory and block interrupt input.. */
-POINTER_TYPE *
-xrealloc (block, size)
- POINTER_TYPE *block;
- size_t size;
+void *
+xrealloc (void *block, size_t size)
{
- register POINTER_TYPE *val;
+ void *val;
MALLOC_BLOCK_INPUT;
/* We must call malloc explicitly when BLOCK is 0, since some
reallocs don't do this. */
if (! block)
- val = (POINTER_TYPE *) malloc (size);
+ val = malloc (size);
else
- val = (POINTER_TYPE *) realloc (block, size);
+ val = realloc (block, size);
MALLOC_UNBLOCK_INPUT;
- if (!val && size) memory_full ();
+ if (!val && size)
+ memory_full (size);
return val;
}
/* Like free but block interrupt input. */
void
-xfree (block)
- POINTER_TYPE *block;
+xfree (void *block)
{
if (!block)
return;
}
+/* Other parts of Emacs pass large int values to allocator functions
+ expecting ptrdiff_t. This is portable in practice, but check it to
+ be safe. */
+verify (INT_MAX <= PTRDIFF_MAX);
+
+
+/* Allocate an array of NITEMS items, each of size ITEM_SIZE.
+ Signal an error on memory exhaustion, and block interrupt input. */
+
+void *
+xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size)
+{
+ eassert (0 <= nitems && 0 < item_size);
+ if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
+ memory_full (SIZE_MAX);
+ return xmalloc (nitems * item_size);
+}
+
+
+/* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
+ Signal an error on memory exhaustion, and block interrupt input. */
+
+void *
+xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
+{
+ eassert (0 <= nitems && 0 < item_size);
+ if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
+ memory_full (SIZE_MAX);
+ return xrealloc (pa, nitems * item_size);
+}
+
+
+/* Grow PA, which points to an array of *NITEMS items, and return the
+ location of the reallocated array, updating *NITEMS to reflect its
+ new size. The new array will contain at least NITEMS_INCR_MIN more
+ items, but will not contain more than NITEMS_MAX items total.
+ ITEM_SIZE is the size of each item, in bytes.
+
+ ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
+ nonnegative. If NITEMS_MAX is -1, it is treated as if it were
+ infinity.
+
+ If PA is null, then allocate a new array instead of reallocating
+ the old one. Thus, to grow an array A without saving its old
+ contents, invoke xfree (A) immediately followed by xgrowalloc (0,
+ &NITEMS, ...).
+
+ Block interrupt input as needed. If memory exhaustion occurs, set
+ *NITEMS to zero if PA is null, and signal an error (i.e., do not
+ return). */
+
+void *
+xpalloc (void *pa, ptrdiff_t *nitems, ptrdiff_t nitems_incr_min,
+ ptrdiff_t nitems_max, ptrdiff_t item_size)
+{
+ /* The approximate size to use for initial small allocation
+ requests. This is the largest "small" request for the GNU C
+ library malloc. */
+ enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 };
+
+ /* If the array is tiny, grow it to about (but no greater than)
+ DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
+ ptrdiff_t n = *nitems;
+ ptrdiff_t tiny_max = DEFAULT_MXFAST / item_size - n;
+ ptrdiff_t half_again = n >> 1;
+ ptrdiff_t incr_estimate = max (tiny_max, half_again);
+
+ /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
+ NITEMS_MAX, and what the C language can represent safely. */
+ ptrdiff_t C_language_max = min (PTRDIFF_MAX, SIZE_MAX) / item_size;
+ ptrdiff_t n_max = (0 <= nitems_max && nitems_max < C_language_max
+ ? nitems_max : C_language_max);
+ ptrdiff_t nitems_incr_max = n_max - n;
+ ptrdiff_t incr = max (nitems_incr_min, min (incr_estimate, nitems_incr_max));
+
+ eassert (0 < item_size && 0 < nitems_incr_min && 0 <= n && -1 <= nitems_max);
+ if (! pa)
+ *nitems = 0;
+ if (nitems_incr_max < incr)
+ memory_full (SIZE_MAX);
+ n += incr;
+ pa = xrealloc (pa, n * item_size);
+ *nitems = n;
+ return pa;
+}
+
+
/* Like strdup, but uses xmalloc. */
char *
-xstrdup (s)
- const char *s;
+xstrdup (const char *s)
{
size_t len = strlen (s) + 1;
- char *p = (char *) xmalloc (len);
- bcopy (s, p, len);
+ char *p = xmalloc (len);
+ memcpy (p, s, len);
return p;
}
/* Unwind for SAFE_ALLOCA */
Lisp_Object
-safe_alloca_unwind (arg)
- Lisp_Object arg;
+safe_alloca_unwind (Lisp_Object arg)
{
register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);
/* Like malloc but used for allocating Lisp data. NBYTES is the
number of bytes to allocate, TYPE describes the intended use of the
- allcated memory block (for strings, for conses, ...). */
+ allocated memory block (for strings, for conses, ...). */
-#ifndef USE_LSB_TAG
-static void *lisp_malloc_loser;
+#if ! USE_LSB_TAG
+void *lisp_malloc_loser EXTERNALLY_VISIBLE;
#endif
-static POINTER_TYPE *
-lisp_malloc (nbytes, type)
- size_t nbytes;
- enum mem_type type;
+static void *
+lisp_malloc (size_t nbytes, enum mem_type type)
{
register void *val;
allocated_mem_type = type;
#endif
- val = (void *) malloc (nbytes);
+ val = malloc (nbytes);
-#ifndef USE_LSB_TAG
+#if ! USE_LSB_TAG
/* If the memory just allocated cannot be addressed thru a Lisp
object's pointer, and it needs to be,
that's equivalent to running out of memory. */
MALLOC_UNBLOCK_INPUT;
if (!val && nbytes)
- memory_full ();
+ memory_full (nbytes);
return val;
}
call to lisp_malloc. */
static void
-lisp_free (block)
- POINTER_TYPE *block;
+lisp_free (void *block)
{
MALLOC_BLOCK_INPUT;
free (block);
MALLOC_UNBLOCK_INPUT;
}
-/* Allocation of aligned blocks of memory to store Lisp data. */
-/* 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. */
+/***** Allocation of aligned blocks of memory to store Lisp data. *****/
+
+/* 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. */
-/* Use posix_memalloc if the system has it and we're using the system's
- malloc (because our gmalloc.c routines don't have posix_memalign although
- its memalloc could be used). */
#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
#define USE_POSIX_MEMALIGN 1
#endif
nothing else. */
#define BLOCK_PADDING 0
#define BLOCK_BYTES \
- (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
+ (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
/* Internal data structures and constants. */
struct ablock blocks[ABLOCKS_SIZE];
};
-/* Size of the block requested from malloc or memalign. */
+/* Size of the block requested from malloc or posix_memalign. */
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
#define ABLOCK_ABASE(block) \
- (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
+ (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
? (struct ablocks *)(block) \
: (block)->abase)
#define ABLOCKS_BASE(abase) (abase)
#else
#define ABLOCKS_BASE(abase) \
- (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
+ (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
#endif
/* The list of free ablock. */
/* Allocate an aligned block of nbytes.
Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
smaller or equal to BLOCK_BYTES. */
-static POINTER_TYPE *
-lisp_align_malloc (nbytes, type)
- size_t nbytes;
- enum mem_type type;
+static void *
+lisp_align_malloc (size_t nbytes, enum mem_type type)
{
void *base, *val;
struct ablocks *abase;
if (!free_ablock)
{
int i;
- EMACS_INT aligned; /* int gets warning casting to 64-bit pointer. */
+ 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
if (base == 0)
{
MALLOC_UNBLOCK_INPUT;
- memory_full ();
+ memory_full (ABLOCKS_BYTES);
}
aligned = (base == abase);
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
-#ifndef USE_LSB_TAG
+#if ! USE_LSB_TAG
/* If the memory just allocated cannot be addressed thru a Lisp
object's pointer, and it needs to be, that's equivalent to
running out of memory. */
lisp_malloc_loser = base;
free (base);
MALLOC_UNBLOCK_INPUT;
- memory_full ();
+ memory_full (SIZE_MAX);
}
}
#endif
/* Initialize the blocks and put them on the free list.
- Is `base' was not properly aligned, we can't use the last block. */
+ If `base' was not properly aligned, we can't use the last block. */
for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
{
abase->blocks[i].abase = abase;
abase->blocks[i].x.next_free = free_ablock;
free_ablock = &abase->blocks[i];
}
- ABLOCKS_BUSY (abase) = (struct ablocks *) (long) aligned;
+ ABLOCKS_BUSY (abase) = (struct ablocks *) aligned;
- eassert (0 == ((EMACS_UINT)abase) % BLOCK_ALIGN);
+ eassert (0 == ((uintptr_t) abase) % BLOCK_ALIGN);
eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
eassert (ABLOCKS_BASE (abase) == base);
- eassert (aligned == (long) ABLOCKS_BUSY (abase));
+ eassert (aligned == (intptr_t) ABLOCKS_BUSY (abase));
}
abase = ABLOCK_ABASE (free_ablock);
- ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (long) 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
- if (val && type != MEM_TYPE_NON_LISP)
+ if (type != MEM_TYPE_NON_LISP)
mem_insert (val, (char *) val + nbytes, type);
#endif
MALLOC_UNBLOCK_INPUT;
- if (!val && nbytes)
- memory_full ();
- eassert (0 == ((EMACS_UINT)val) % BLOCK_ALIGN);
+ eassert (0 == ((uintptr_t) val) % BLOCK_ALIGN);
return val;
}
static void
-lisp_align_free (block)
- POINTER_TYPE *block;
+lisp_align_free (void *block)
{
struct ablock *ablock = block;
struct ablocks *abase = ABLOCK_ABASE (ablock);
ablock->x.next_free = free_ablock;
free_ablock = ablock;
/* Update busy count. */
- ABLOCKS_BUSY (abase) = (struct ablocks *) (-2 + (long) ABLOCKS_BUSY (abase));
+ ABLOCKS_BUSY (abase)
+ = (struct ablocks *) (-2 + (intptr_t) ABLOCKS_BUSY (abase));
- if (2 > (long) ABLOCKS_BUSY (abase))
+ if (2 > (intptr_t) ABLOCKS_BUSY (abase))
{ /* All the blocks are free. */
- int i = 0, aligned = (long) ABLOCKS_BUSY (abase);
+ int i = 0, aligned = (intptr_t) ABLOCKS_BUSY (abase);
struct ablock **tem = &free_ablock;
struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
eassert ((aligned & 1) == aligned);
eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
#ifdef USE_POSIX_MEMALIGN
- eassert ((unsigned long)ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
+ eassert ((uintptr_t) ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
#endif
free (ABLOCKS_BASE (abase));
}
MALLOC_UNBLOCK_INPUT;
}
-/* Return a new buffer structure allocated from the heap with
- a call to lisp_malloc. */
-
-struct buffer *
-allocate_buffer ()
-{
- struct buffer *b
- = (struct buffer *) lisp_malloc (sizeof (struct buffer),
- MEM_TYPE_BUFFER);
- XSETPVECTYPESIZE (b, PVEC_BUFFER,
- ((sizeof (struct buffer) + sizeof (EMACS_INT) - 1)
- / sizeof (EMACS_INT)));
- return b;
-}
-
\f
#ifndef SYSTEM_MALLOC
there's no need to block input around malloc. */
#ifndef DOUG_LEA_MALLOC
-extern void * (*__malloc_hook) P_ ((size_t, const void *));
-extern void * (*__realloc_hook) P_ ((void *, size_t, const void *));
-extern void (*__free_hook) P_ ((void *, const void *));
+extern void * (*__malloc_hook) (size_t, const void *);
+extern void * (*__realloc_hook) (void *, size_t, const void *);
+extern void (*__free_hook) (void *, const void *);
/* Else declared in malloc.h, perhaps with an extra arg. */
#endif /* DOUG_LEA_MALLOC */
-static void * (*old_malloc_hook) P_ ((size_t, const void *));
-static void * (*old_realloc_hook) P_ ((void *, size_t, const void*));
-static void (*old_free_hook) P_ ((void*, const void*));
+static void * (*old_malloc_hook) (size_t, const void *);
+static void * (*old_realloc_hook) (void *, size_t, const void*);
+static void (*old_free_hook) (void*, const void*);
+
+#ifdef DOUG_LEA_MALLOC
+# define BYTES_USED (mallinfo ().uordblks)
+#else
+# define BYTES_USED _bytes_used
+#endif
+
+#ifdef GC_MALLOC_CHECK
+static int dont_register_blocks;
+#endif
+
+static size_t bytes_used_when_reconsidered;
+
+/* Value of _bytes_used, when spare_memory was freed. */
+
+static size_t bytes_used_when_full;
/* This function is used as the hook for free to call. */
static void
-emacs_blocked_free (ptr, ptr2)
- void *ptr;
- const void *ptr2;
+emacs_blocked_free (void *ptr, const void *ptr2)
{
BLOCK_INPUT_ALLOC;
/* This function is the malloc hook that Emacs uses. */
static void *
-emacs_blocked_malloc (size, ptr)
- size_t size;
- const void *ptr;
+emacs_blocked_malloc (size_t size, const void *ptr)
{
void *value;
__malloc_extra_blocks = malloc_hysteresis;
#endif
- value = (void *) malloc (size);
+ value = malloc (size);
#ifdef GC_MALLOC_CHECK
{
{
fprintf (stderr, "Malloc returned %p which is already in use\n",
value);
- fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n",
+ fprintf (stderr, "Region in use is %p...%p, %td bytes, type %d\n",
m->start, m->end, (char *) m->end - (char *) m->start,
m->type);
abort ();
/* This function is the realloc hook that Emacs uses. */
static void *
-emacs_blocked_realloc (ptr, size, ptr2)
- void *ptr;
- size_t size;
- const void *ptr2;
+emacs_blocked_realloc (void *ptr, size_t size, const void *ptr2)
{
void *value;
dont_register_blocks = 1;
#endif /* GC_MALLOC_CHECK */
- value = (void *) realloc (ptr, size);
+ value = realloc (ptr, size);
#ifdef GC_MALLOC_CHECK
dont_register_blocks = 0;
}
-#ifdef HAVE_GTK_AND_PTHREAD
+#ifdef HAVE_PTHREAD
/* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
normal malloc. Some thread implementations need this as they call
malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
calls malloc because it is the first call, and we have an endless loop. */
void
-reset_malloc_hooks ()
+reset_malloc_hooks (void)
{
__free_hook = old_free_hook;
__malloc_hook = old_malloc_hook;
__realloc_hook = old_realloc_hook;
}
-#endif /* HAVE_GTK_AND_PTHREAD */
+#endif /* HAVE_PTHREAD */
/* Called from main to set up malloc to use our hooks. */
void
-uninterrupt_malloc ()
+uninterrupt_malloc (void)
{
-#ifdef HAVE_GTK_AND_PTHREAD
+#ifdef HAVE_PTHREAD
#ifdef DOUG_LEA_MALLOC
pthread_mutexattr_t attr;
- /* GLIBC has a faster way to do this, but lets keep it portable.
+ /* GLIBC has a faster way to do this, but let's keep it portable.
This is according to the Single UNIX Specification. */
pthread_mutexattr_init (&attr);
pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
pthread_mutex_init (&alloc_mutex, &attr);
#else /* !DOUG_LEA_MALLOC */
- /* Some systems such as Solaris 2.6 doesn't have a recursive mutex,
+ /* Some systems such as Solaris 2.6 don't have a recursive mutex,
and the bundled gmalloc.c doesn't require it. */
pthread_mutex_init (&alloc_mutex, NULL);
#endif /* !DOUG_LEA_MALLOC */
-#endif /* HAVE_GTK_AND_PTHREAD */
+#endif /* HAVE_PTHREAD */
if (__free_hook != emacs_blocked_free)
old_free_hook = __free_hook;
/* Number of free and live intervals. */
-static int total_free_intervals, total_intervals;
+static EMACS_INT total_free_intervals, total_intervals;
/* List of free intervals. */
-INTERVAL interval_free_list;
-
-/* Total number of interval blocks now in use. */
-
-static int n_interval_blocks;
+static INTERVAL interval_free_list;
/* Initialize interval allocation. */
static void
-init_intervals ()
+init_intervals (void)
{
interval_block = NULL;
interval_block_index = INTERVAL_BLOCK_SIZE;
interval_free_list = 0;
- n_interval_blocks = 0;
}
/* Return a new interval. */
INTERVAL
-make_interval ()
+make_interval (void)
{
INTERVAL val;
{
if (interval_block_index == INTERVAL_BLOCK_SIZE)
{
- register struct interval_block *newi;
-
- newi = (struct interval_block *) lisp_malloc (sizeof *newi,
- MEM_TYPE_NON_LISP);
+ struct interval_block *newi
+ = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP);
newi->next = interval_block;
interval_block = newi;
interval_block_index = 0;
- n_interval_blocks++;
}
val = &interval_block->intervals[interval_block_index++];
}
}
-/* Mark Lisp objects in interval I. */
+/* Mark Lisp objects in interval I. */
static void
-mark_interval (i, dummy)
- register INTERVAL i;
- Lisp_Object dummy;
+mark_interval (register INTERVAL i, Lisp_Object dummy)
{
eassert (!i->gcmarkbit); /* Intervals are never shared. */
i->gcmarkbit = 1;
use the macro MARK_INTERVAL_TREE instead. */
static void
-mark_interval_tree (tree)
- register INTERVAL tree;
+mark_interval_tree (register INTERVAL tree)
{
/* No need to test if this tree has been marked already; this
function is always called through the MARK_INTERVAL_TREE macro,
if (! NULL_INTERVAL_P (i)) \
(i) = balance_intervals (i); \
} while (0)
-
-\f
-/* Number support. If USE_LISP_UNION_TYPE is in effect, we
- can't create number objects in macros. */
-#ifndef make_number
-Lisp_Object
-make_number (n)
- EMACS_INT n;
-{
- Lisp_Object obj;
- obj.s.val = n;
- obj.s.type = Lisp_Int;
- return obj;
-}
-#endif
\f
/***********************************************************************
String Allocation
#ifdef GC_CHECK_STRING_BYTES
- EMACS_INT nbytes;
+ ptrdiff_t nbytes;
unsigned char data[1];
#define SDATA_NBYTES(S) (S)->nbytes
#define SDATA_DATA(S) (S)->data
+#define SDATA_SELECTOR(member) member
#else /* not GC_CHECK_STRING_BYTES */
union
{
- /* When STRING in non-null. */
+ /* When STRING is non-null. */
unsigned char data[1];
/* When STRING is null. */
- EMACS_INT nbytes;
+ ptrdiff_t nbytes;
} u;
-
#define SDATA_NBYTES(S) (S)->u.nbytes
#define SDATA_DATA(S) (S)->u.data
+#define SDATA_SELECTOR(member) u.member
#endif /* not GC_CHECK_STRING_BYTES */
+
+#define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
};
static struct sblock *large_sblocks;
-/* List of string_block structures, and how many there are. */
+/* List of string_block structures. */
static struct string_block *string_blocks;
-static int n_string_blocks;
/* Free-list of Lisp_Strings. */
/* Number of live and free Lisp_Strings. */
-static int total_strings, total_free_strings;
+static EMACS_INT total_strings, total_free_strings;
/* Number of bytes used by live strings. */
-static int total_string_size;
+static EMACS_INT total_string_size;
/* Given a pointer to a Lisp_String S which is on the free-list
string_free_list, return a pointer to its successor in the
a pointer to the `u.data' member of its sdata structure; the
structure starts at a constant offset in front of that. */
-#ifdef GC_CHECK_STRING_BYTES
-
-#define SDATA_OF_STRING(S) \
- ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
- - sizeof (EMACS_INT)))
-
-#else /* not GC_CHECK_STRING_BYTES */
-
-#define SDATA_OF_STRING(S) \
- ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
-
-#endif /* not GC_CHECK_STRING_BYTES */
+#define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
#ifdef GC_CHECK_STRING_OVERRUN
presence of this cookie during GC. */
#define GC_STRING_OVERRUN_COOKIE_SIZE 4
-static char string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
- { 0xde, 0xad, 0xbe, 0xef };
+static char const string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
+ { '\xde', '\xad', '\xbe', '\xef' };
#else
#define GC_STRING_OVERRUN_COOKIE_SIZE 0
#ifdef GC_CHECK_STRING_BYTES
#define SDATA_SIZE(NBYTES) \
- ((sizeof (struct Lisp_String *) \
+ ((SDATA_DATA_OFFSET \
+ (NBYTES) + 1 \
- + sizeof (EMACS_INT) \
- + sizeof (EMACS_INT) - 1) \
- & ~(sizeof (EMACS_INT) - 1))
+ + sizeof (ptrdiff_t) - 1) \
+ & ~(sizeof (ptrdiff_t) - 1))
#else /* not GC_CHECK_STRING_BYTES */
-#define SDATA_SIZE(NBYTES) \
- ((sizeof (struct Lisp_String *) \
- + (NBYTES) + 1 \
- + sizeof (EMACS_INT) - 1) \
- & ~(sizeof (EMACS_INT) - 1))
+/* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
+ less than the size of that member. The 'max' is not needed when
+ SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
+ alignment code reserves enough space. */
+
+#define SDATA_SIZE(NBYTES) \
+ ((SDATA_DATA_OFFSET \
+ + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
+ ? NBYTES \
+ : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
+ + 1 \
+ + sizeof (ptrdiff_t) - 1) \
+ & ~(sizeof (ptrdiff_t) - 1))
#endif /* not GC_CHECK_STRING_BYTES */
#define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
+/* Exact bound on the number of bytes in a string, not counting the
+ terminating null. A string cannot contain more bytes than
+ STRING_BYTES_BOUND, nor can it be so long that the size_t
+ arithmetic in allocate_string_data would overflow while it is
+ calculating a value to be passed to malloc. */
+#define STRING_BYTES_MAX \
+ min (STRING_BYTES_BOUND, \
+ ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD \
+ - GC_STRING_EXTRA \
+ - offsetof (struct sblock, first_data) \
+ - SDATA_DATA_OFFSET) \
+ & ~(sizeof (EMACS_INT) - 1)))
+
/* Initialize string allocation. Called from init_alloc_once. */
static void
-init_strings ()
+init_strings (void)
{
total_strings = total_free_strings = total_string_size = 0;
oldest_sblock = current_sblock = large_sblocks = NULL;
string_blocks = NULL;
- n_string_blocks = 0;
string_free_list = NULL;
empty_unibyte_string = make_pure_string ("", 0, 0, 0);
empty_multibyte_string = make_pure_string ("", 0, 0, 1);
static int check_string_bytes_count;
-static void check_string_bytes P_ ((int));
-static void check_sblock P_ ((struct sblock *));
-
#define CHECK_STRING_BYTES(S) STRING_BYTES (S)
/* Like GC_STRING_BYTES, but with debugging check. */
-int
-string_bytes (s)
- struct Lisp_String *s;
+ptrdiff_t
+string_bytes (struct Lisp_String *s)
{
- int nbytes = (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
+ 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)))
/* Check validity of Lisp strings' string_bytes member in B. */
static void
-check_sblock (b)
- struct sblock *b;
+check_sblock (struct sblock *b)
{
struct sdata *from, *end, *from_end;
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
- int nbytes;
+ ptrdiff_t nbytes;
/* Check that the string size recorded in the string is the
- same as the one recorded in the sdata structure. */
+ same as the one recorded in the sdata structure. */
if (from->string)
CHECK_STRING_BYTES (from->string);
recently allocated strings. Used for hunting a bug. */
static void
-check_string_bytes (all_p)
- int all_p;
+check_string_bytes (int all_p)
{
if (all_p)
{
for (b = oldest_sblock; b; b = b->next)
check_sblock (b);
}
- else
+ else if (current_sblock)
check_sblock (current_sblock);
}
This may catch buffer overrun from a previous string. */
static void
-check_string_free_list ()
+check_string_free_list (void)
{
struct Lisp_String *s;
s = string_free_list;
while (s != NULL)
{
- if ((unsigned)s < 1024)
- abort();
+ if ((uintptr_t) s < 1024)
+ abort ();
s = NEXT_FREE_LISP_STRING (s);
}
}
/* Return a new Lisp_String. */
static struct Lisp_String *
-allocate_string ()
+allocate_string (void)
{
struct Lisp_String *s;
add all the Lisp_Strings in it to the free-list. */
if (string_free_list == NULL)
{
- struct string_block *b;
+ struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING);
int i;
- b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
- bzero (b, sizeof *b);
b->next = string_blocks;
string_blocks = b;
- ++n_string_blocks;
for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
{
s = b->strings + i;
+ /* Every string on a free list should have NULL data pointer. */
+ s->data = NULL;
NEXT_FREE_LISP_STRING (s) = string_free_list;
string_free_list = s;
}
MALLOC_UNBLOCK_INPUT;
- /* Probably not strictly necessary, but play it safe. */
- bzero (s, sizeof *s);
-
--total_free_strings;
++total_strings;
++strings_consed;
S->data if it was initially non-null. */
void
-allocate_string_data (s, nchars, nbytes)
- struct Lisp_String *s;
- int nchars, nbytes;
+allocate_string_data (struct Lisp_String *s,
+ EMACS_INT nchars, EMACS_INT nbytes)
{
- struct sdata *data, *old_data;
+ struct sdata *data;
struct sblock *b;
- int needed, old_nbytes;
+ ptrdiff_t needed;
+
+ if (STRING_BYTES_MAX < nbytes)
+ string_overflow ();
/* Determine the number of bytes needed to store NBYTES bytes
of string data. */
needed = SDATA_SIZE (nbytes);
- old_data = s->data ? SDATA_OF_STRING (s) : NULL;
- old_nbytes = GC_STRING_BYTES (s);
MALLOC_BLOCK_INPUT;
if (nbytes > LARGE_STRING_BYTES)
{
- size_t size = sizeof *b - sizeof (struct sdata) + needed;
+ size_t size = offsetof (struct sblock, first_data) + needed;
#ifdef DOUG_LEA_MALLOC
/* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
mallopt (M_MMAP_MAX, 0);
#endif
- b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
+ b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
#ifdef DOUG_LEA_MALLOC
/* Back to a reasonable maximum of mmap'ed areas. */
< (needed + GC_STRING_EXTRA)))
{
/* Not enough room in the current sblock. */
- b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
+ b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
b->next_free = &b->first_data;
b->first_data.string = NULL;
b->next = NULL;
s->size_byte = nbytes;
s->data[nbytes] = '\0';
#ifdef GC_CHECK_STRING_OVERRUN
- bcopy (string_overrun_cookie, (char *) data + needed,
- GC_STRING_OVERRUN_COOKIE_SIZE);
+ memcpy ((char *) data + needed, string_overrun_cookie,
+ GC_STRING_OVERRUN_COOKIE_SIZE);
#endif
-
- /* If S had already data assigned, mark that as free by setting its
- string back-pointer to null, and recording the size of the data
- in it. */
- if (old_data)
- {
- SDATA_NBYTES (old_data) = old_nbytes;
- old_data->string = NULL;
- }
-
consing_since_gc += needed;
}
/* Sweep and compact strings. */
static void
-sweep_strings ()
+sweep_strings (void)
{
struct string_block *b, *next;
struct string_block *live_blocks = NULL;
&& total_free_strings > STRING_BLOCK_SIZE)
{
lisp_free (b);
- --n_string_blocks;
string_free_list = free_list_before;
}
else
/* Free dead large strings. */
static void
-free_large_strings ()
+free_large_strings (void)
{
struct sblock *b, *next;
struct sblock *live_blocks = NULL;
data of live strings after compaction. */
static void
-compact_small_strings ()
+compact_small_strings (void)
{
struct sblock *b, *tb, *next;
struct sdata *from, *to, *end, *tb_end;
for (b = oldest_sblock; b; b = b->next)
{
end = b->next_free;
- xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
+ eassert ((char *) end <= (char *) b + SBLOCK_SIZE);
for (from = &b->first_data; from < end; from = from_end)
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
- int nbytes;
+ ptrdiff_t nbytes;
#ifdef GC_CHECK_STRING_BYTES
/* Check that the string size recorded in the string is the
from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
#ifdef GC_CHECK_STRING_OVERRUN
- if (bcmp (string_overrun_cookie,
- ((char *) from_end) - GC_STRING_OVERRUN_COOKIE_SIZE,
- GC_STRING_OVERRUN_COOKIE_SIZE))
+ if (memcmp (string_overrun_cookie,
+ (char *) from_end - GC_STRING_OVERRUN_COOKIE_SIZE,
+ GC_STRING_OVERRUN_COOKIE_SIZE))
abort ();
#endif
/* Copy, and update the string's `data' pointer. */
if (from != to)
{
- xassert (tb != b || to <= from);
- safe_bcopy ((char *) from, (char *) to, nbytes + GC_STRING_EXTRA);
+ eassert (tb != b || to < from);
+ memmove (to, from, nbytes + GC_STRING_EXTRA);
to->string->data = SDATA_DATA (to);
}
current_sblock = tb;
}
+void
+string_overflow (void)
+{
+ error ("Maximum string size exceeded");
+}
DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
doc: /* Return a newly created string of length LENGTH, with INIT in each element.
LENGTH must be an integer.
INIT must be an integer that represents a character. */)
- (length, init)
- Lisp_Object length, init;
+ (Lisp_Object length, Lisp_Object init)
{
register Lisp_Object val;
register unsigned char *p, *end;
- int c, nbytes;
+ int c;
+ EMACS_INT nbytes;
CHECK_NATNUM (length);
- CHECK_NUMBER (init);
+ CHECK_CHARACTER (init);
- c = XINT (init);
+ c = XFASTINT (init);
if (ASCII_CHAR_P (c))
{
nbytes = XINT (length);
{
unsigned char str[MAX_MULTIBYTE_LENGTH];
int len = CHAR_STRING (c, str);
+ EMACS_INT string_len = XINT (length);
- nbytes = len * XINT (length);
- val = make_uninit_multibyte_string (XINT (length), nbytes);
+ 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)
{
- bcopy (str, p, len);
+ memcpy (p, str, len);
p += len;
}
}
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. */)
- (length, init)
- Lisp_Object length, init;
+ (Lisp_Object length, Lisp_Object init)
{
register Lisp_Object val;
struct Lisp_Bool_Vector *p;
- int real_init, i;
- int length_in_chars, length_in_elts, bits_per_value;
+ ptrdiff_t length_in_chars;
+ EMACS_INT length_in_elts;
+ int bits_per_value;
CHECK_NATNUM (length);
bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
- length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
- / BOOL_VECTOR_BITS_PER_CHAR);
/* We must allocate one more elements than LENGTH_IN_ELTS for the
slot `size' of the struct Lisp_Bool_Vector. */
p = XBOOL_VECTOR (val);
p->size = XFASTINT (length);
- real_init = (NILP (init) ? 0 : -1);
- for (i = 0; i < length_in_chars ; i++)
- p->data[i] = real_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);
- /* Clear the extraneous bits in the last byte. */
- if (XINT (length) != length_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
- p->data[length_in_chars - 1]
- &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
+ /* Clear any extraneous bits in the last byte. */
+ p->data[length_in_chars - 1]
+ &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
+ }
return val;
}
multibyte, depending on the contents. */
Lisp_Object
-make_string (contents, nbytes)
- const char *contents;
- int nbytes;
+make_string (const char *contents, ptrdiff_t nbytes)
{
register Lisp_Object val;
- int nchars, multibyte_nbytes;
+ ptrdiff_t nchars, multibyte_nbytes;
- parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
+ parse_str_as_multibyte ((const unsigned char *) contents, nbytes,
+ &nchars, &multibyte_nbytes);
if (nbytes == nchars || nbytes != multibyte_nbytes)
/* CONTENTS contains no multibyte sequences or contains an invalid
multibyte sequence. We must make unibyte string. */
/* Make an unibyte string from LENGTH bytes at CONTENTS. */
Lisp_Object
-make_unibyte_string (contents, length)
- const char *contents;
- int length;
+make_unibyte_string (const char *contents, ptrdiff_t length)
{
register Lisp_Object val;
val = make_uninit_string (length);
- bcopy (contents, SDATA (val), length);
- STRING_SET_UNIBYTE (val);
+ memcpy (SDATA (val), contents, length);
return val;
}
bytes at CONTENTS. */
Lisp_Object
-make_multibyte_string (contents, nchars, nbytes)
- const char *contents;
- int nchars, nbytes;
+make_multibyte_string (const char *contents,
+ ptrdiff_t nchars, ptrdiff_t nbytes)
{
register Lisp_Object val;
val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, SDATA (val), nbytes);
+ memcpy (SDATA (val), contents, nbytes);
return val;
}
CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
Lisp_Object
-make_string_from_bytes (contents, nchars, nbytes)
- const char *contents;
- int nchars, nbytes;
+make_string_from_bytes (const char *contents,
+ ptrdiff_t nchars, ptrdiff_t nbytes)
{
register Lisp_Object val;
val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, SDATA (val), nbytes);
+ memcpy (SDATA (val), contents, nbytes);
if (SBYTES (val) == SCHARS (val))
STRING_SET_UNIBYTE (val);
return val;
characters by itself. */
Lisp_Object
-make_specified_string (contents, nchars, nbytes, multibyte)
- const char *contents;
- int nchars, nbytes;
- int multibyte;
+make_specified_string (const char *contents,
+ ptrdiff_t nchars, ptrdiff_t nbytes, int multibyte)
{
register Lisp_Object val;
if (nchars < 0)
{
if (multibyte)
- nchars = multibyte_chars_in_text (contents, nbytes);
+ nchars = multibyte_chars_in_text ((const unsigned char *) contents,
+ nbytes);
else
nchars = nbytes;
}
val = make_uninit_multibyte_string (nchars, nbytes);
- bcopy (contents, SDATA (val), nbytes);
+ memcpy (SDATA (val), contents, nbytes);
if (!multibyte)
STRING_SET_UNIBYTE (val);
return val;
}
-/* Make a string from the data at STR, treating it as multibyte if the
- data warrants. */
-
-Lisp_Object
-build_string (str)
- const char *str;
-{
- return make_string (str, strlen (str));
-}
-
-
/* Return an unibyte Lisp_String set up to hold LENGTH characters
occupying LENGTH bytes. */
Lisp_Object
-make_uninit_string (length)
- int length;
+make_uninit_string (EMACS_INT length)
{
Lisp_Object val;
which occupy NBYTES bytes. */
Lisp_Object
-make_uninit_multibyte_string (nchars, nbytes)
- int nchars, nbytes;
+make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes)
{
Lisp_Object string;
struct Lisp_String *s;
return empty_multibyte_string;
s = allocate_string ();
+ s->intervals = NULL_INTERVAL;
allocate_string_data (s, nchars, nbytes);
XSETSTRING (string, s);
string_chars_consed += nbytes;
return string;
}
+/* Print arguments to BUF according to a FORMAT, then return
+ a Lisp_String initialized with the data from BUF. */
+
+Lisp_Object
+make_formatted_string (char *buf, const char *format, ...)
+{
+ va_list ap;
+ int length;
+
+ va_start (ap, format);
+ length = vsprintf (buf, format, ap);
+ va_end (ap);
+ return make_string (buf, length);
+}
\f
/***********************************************************************
/ (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) / (sizeof (int) * CHAR_BIT)] \
+ >> ((n) % (sizeof (int) * CHAR_BIT))) \
& 1)
#define SETMARKBIT(block,n) \
- (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
- |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
+ (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
+ |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
#define UNSETMARKBIT(block,n) \
- (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
- &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
+ (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
+ &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
#define FLOAT_BLOCK(fptr) \
- ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
+ ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
#define FLOAT_INDEX(fptr) \
- ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
+ ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
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)];
+ int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
struct float_block *next;
};
/* Current float_block. */
-struct float_block *float_block;
+static struct float_block *float_block;
/* Index of first unused Lisp_Float in the current float_block. */
-int float_block_index;
-
-/* Total number of float blocks now in use. */
-
-int n_float_blocks;
+static int float_block_index;
/* Free-list of Lisp_Floats. */
-struct Lisp_Float *float_free_list;
+static struct Lisp_Float *float_free_list;
/* Initialize float allocation. */
static void
-init_float ()
+init_float (void)
{
float_block = NULL;
float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
float_free_list = 0;
- n_float_blocks = 0;
-}
-
-
-/* Explicitly free a float cell by putting it on the free-list. */
-
-static void
-free_float (ptr)
- struct Lisp_Float *ptr;
-{
- ptr->u.chain = float_free_list;
- float_free_list = ptr;
}
/* Return a new float object with value FLOAT_VALUE. */
Lisp_Object
-make_float (float_value)
- double float_value;
+make_float (double float_value)
{
register Lisp_Object val;
{
if (float_block_index == FLOAT_BLOCK_SIZE)
{
- register struct float_block *new;
-
- new = (struct float_block *) lisp_align_malloc (sizeof *new,
- MEM_TYPE_FLOAT);
+ struct float_block *new
+ = lisp_align_malloc (sizeof *new, MEM_TYPE_FLOAT);
new->next = float_block;
- bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
+ memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
float_block = new;
float_block_index = 0;
- n_float_blocks++;
}
XSETFLOAT (val, &float_block->floats[float_block_index]);
float_block_index++;
GC are put on a free list to be reallocated before allocating
any new cons cells from the latest cons_block. */
-#define CONS_BLOCK_SIZE \
- (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
+#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) * CHAR_BIT + 1))
#define CONS_BLOCK(fptr) \
- ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
+ ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
#define CONS_INDEX(fptr) \
- ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
+ (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
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)];
+ int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof (int) * CHAR_BIT)];
struct cons_block *next;
};
/* Current cons_block. */
-struct cons_block *cons_block;
+static struct cons_block *cons_block;
/* Index of first unused Lisp_Cons in the current block. */
-int cons_block_index;
+static int cons_block_index;
/* Free-list of Lisp_Cons structures. */
-struct Lisp_Cons *cons_free_list;
-
-/* Total number of cons blocks now in use. */
-
-static int n_cons_blocks;
+static struct Lisp_Cons *cons_free_list;
/* Initialize cons allocation. */
static void
-init_cons ()
+init_cons (void)
{
cons_block = NULL;
cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block. */
cons_free_list = 0;
- n_cons_blocks = 0;
}
/* Explicitly free a cons cell by putting it on the free-list. */
void
-free_cons (ptr)
- struct Lisp_Cons *ptr;
+free_cons (struct Lisp_Cons *ptr)
{
ptr->u.chain = cons_free_list;
#if GC_MARK_STACK
DEFUN ("cons", Fcons, Scons, 2, 2, 0,
doc: /* Create a new cons, give it CAR and CDR as components, and return it. */)
- (car, cdr)
- Lisp_Object car, cdr;
+ (Lisp_Object car, Lisp_Object cdr)
{
register Lisp_Object val;
{
if (cons_block_index == CONS_BLOCK_SIZE)
{
- register struct cons_block *new;
- new = (struct cons_block *) lisp_align_malloc (sizeof *new,
- MEM_TYPE_CONS);
- bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
+ struct cons_block *new
+ = lisp_align_malloc (sizeof *new, MEM_TYPE_CONS);
+ memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
- n_cons_blocks++;
}
XSETCONS (val, &cons_block->conses[cons_block_index]);
cons_block_index++;
return val;
}
+#ifdef GC_CHECK_CONS_LIST
/* Get an error now if there's any junk in the cons free list. */
void
-check_cons_list ()
+check_cons_list (void)
{
-#ifdef GC_CHECK_CONS_LIST
struct Lisp_Cons *tail = cons_free_list;
while (tail)
tail = tail->u.chain;
-#endif
}
+#endif
/* Make a list of 1, 2, 3, 4 or 5 specified objects. */
Lisp_Object
-list1 (arg1)
- Lisp_Object arg1;
+list1 (Lisp_Object arg1)
{
return Fcons (arg1, Qnil);
}
Lisp_Object
-list2 (arg1, arg2)
- Lisp_Object arg1, arg2;
+list2 (Lisp_Object arg1, Lisp_Object arg2)
{
return Fcons (arg1, Fcons (arg2, Qnil));
}
Lisp_Object
-list3 (arg1, arg2, arg3)
- Lisp_Object arg1, arg2, arg3;
+list3 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
{
return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
}
Lisp_Object
-list4 (arg1, arg2, arg3, arg4)
- Lisp_Object arg1, arg2, arg3, arg4;
+list4 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4)
{
return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
}
Lisp_Object
-list5 (arg1, arg2, arg3, arg4, arg5)
- Lisp_Object arg1, arg2, arg3, arg4, arg5;
+list5 (Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
{
return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
Fcons (arg5, Qnil)))));
doc: /* Return a newly created list with specified arguments as elements.
Any number of arguments, even zero arguments, are allowed.
usage: (list &rest OBJECTS) */)
- (nargs, args)
- int nargs;
- register Lisp_Object *args;
+ (ptrdiff_t nargs, Lisp_Object *args)
{
register Lisp_Object val;
val = Qnil;
DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
doc: /* Return a newly created list of length LENGTH, with each element being INIT. */)
- (length, init)
- register Lisp_Object length, init;
+ (register Lisp_Object length, Lisp_Object init)
{
register Lisp_Object val;
- register int size;
+ register EMACS_INT size;
CHECK_NATNUM (length);
size = XFASTINT (length);
Vector Allocation
***********************************************************************/
-/* Singly-linked list of all vectors. */
+/* 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
+
+/* Handy constants for vectorlike objects. */
+enum
+ {
+ header_size = offsetof (struct Lisp_Vector, contents),
+ word_size = sizeof (Lisp_Object),
+ roundup_size = COMMON_MULTIPLE (sizeof (Lisp_Object),
+ USE_LSB_TAG ? 1 << GCTYPEBITS : 1)
+ };
+
+/* ROUNDUP_SIZE must be a power of 2. */
+verify ((roundup_size & (roundup_size - 1)) == 0);
+
+/* 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))
+
+/* Rounding helps to maintain alignment constraints if USE_LSB_TAG. */
+
+#define VECTOR_BLOCK_BYTES (VECTOR_BLOCK_SIZE - vroundup (sizeof (void *)))
+
+/* Size of the minimal vector allocated from block. */
+
+#define VBLOCK_BYTES_MIN vroundup (sizeof (struct Lisp_Vector))
+
+/* Size of the largest vector allocated from block. */
+
+#define VBLOCK_BYTES_MAX \
+ vroundup ((VECTOR_BLOCK_BYTES / 2) - sizeof (Lisp_Object))
+
+/* We maintain one free list for each possible block-allocated
+ vector size, and this is the number of free lists we have. */
+
+#define VECTOR_MAX_FREE_LIST_INDEX \
+ ((VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN) / roundup_size + 1)
+
+/* Common shortcut to advance vector pointer over a block data. */
+
+#define ADVANCE(v, nbytes) ((struct Lisp_Vector *) ((char *) (v) + (nbytes)))
+
+/* Common shortcut to calculate NBYTES-vector index in VECTOR_FREE_LISTS. */
+
+#define VINDEX(nbytes) (((nbytes) - VBLOCK_BYTES_MIN) / roundup_size)
+
+/* Common shortcut to setup vector on a free list. */
+
+#define SETUP_ON_FREE_LIST(v, nbytes, index) \
+ do { \
+ XSETPVECTYPESIZE (v, PVEC_FREE, nbytes); \
+ eassert ((nbytes) % roundup_size == 0); \
+ (index) = VINDEX (nbytes); \
+ eassert ((index) < VECTOR_MAX_FREE_LIST_INDEX); \
+ (v)->header.next.vector = vector_free_lists[index]; \
+ vector_free_lists[index] = (v); \
+ } while (0)
+
+struct vector_block
+{
+ char data[VECTOR_BLOCK_BYTES];
+ struct vector_block *next;
+};
+
+/* Chain of vector blocks. */
+
+static struct vector_block *vector_blocks;
+
+/* Vector free lists, where NTH item points to a chain of free
+ vectors of the same NBYTES size, so NTH == VINDEX (NBYTES). */
+
+static struct Lisp_Vector *vector_free_lists[VECTOR_MAX_FREE_LIST_INDEX];
+
+/* Singly-linked list of large vectors. */
+
+static struct Lisp_Vector *large_vectors;
+
+/* The only vector with 0 slots, allocated from pure space. */
+
+static struct Lisp_Vector *zero_vector;
+
+/* Get a new vector block. */
+
+static struct vector_block *
+allocate_vector_block (void)
+{
+ struct vector_block *block = xmalloc (sizeof *block);
+
+#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+ mem_insert (block->data, block->data + VECTOR_BLOCK_BYTES,
+ MEM_TYPE_VECTOR_BLOCK);
+#endif
+
+ block->next = vector_blocks;
+ vector_blocks = block;
+ return block;
+}
+
+/* Called once to initialize vector allocation. */
+
+static void
+init_vectors (void)
+{
+ zero_vector = pure_alloc (header_size, Lisp_Vectorlike);
+ zero_vector->header.size = 0;
+}
+
+/* Allocate vector from a vector block. */
+
+static struct Lisp_Vector *
+allocate_vector_from_block (size_t nbytes)
+{
+ struct Lisp_Vector *vector, *rest;
+ struct vector_block *block;
+ size_t index, restbytes;
+
+ eassert (VBLOCK_BYTES_MIN <= nbytes && nbytes <= VBLOCK_BYTES_MAX);
+ eassert (nbytes % roundup_size == 0);
+
+ /* First, try to allocate from a free list
+ containing vectors of the requested size. */
+ index = VINDEX (nbytes);
+ if (vector_free_lists[index])
+ {
+ vector = vector_free_lists[index];
+ vector_free_lists[index] = vector->header.next.vector;
+ vector->header.next.nbytes = nbytes;
+ return vector;
+ }
+
+ /* Next, check free lists containing larger vectors. Since
+ we will split the result, we should have remaining space
+ large enough to use for one-slot vector at least. */
+ for (index = VINDEX (nbytes + VBLOCK_BYTES_MIN);
+ index < VECTOR_MAX_FREE_LIST_INDEX; index++)
+ if (vector_free_lists[index])
+ {
+ /* This vector is larger than requested. */
+ vector = vector_free_lists[index];
+ vector_free_lists[index] = vector->header.next.vector;
+ vector->header.next.nbytes = nbytes;
+
+ /* Excess bytes are used for the smaller vector,
+ which should be set on an appropriate free list. */
+ restbytes = index * roundup_size + VBLOCK_BYTES_MIN - nbytes;
+ eassert (restbytes % roundup_size == 0);
+ rest = ADVANCE (vector, nbytes);
+ SETUP_ON_FREE_LIST (rest, restbytes, index);
+ return vector;
+ }
+
+ /* Finally, need a new vector block. */
+ block = allocate_vector_block ();
+
+ /* New vector will be at the beginning of this block. */
+ vector = (struct Lisp_Vector *) block->data;
+ vector->header.next.nbytes = nbytes;
+
+ /* If the rest of space from this block is large enough
+ for one-slot vector at least, set up it on a free list. */
+ restbytes = VECTOR_BLOCK_BYTES - nbytes;
+ if (restbytes >= VBLOCK_BYTES_MIN)
+ {
+ eassert (restbytes % roundup_size == 0);
+ rest = ADVANCE (vector, nbytes);
+ SETUP_ON_FREE_LIST (rest, restbytes, index);
+ }
+ return vector;
+ }
+
+/* Return how many Lisp_Objects can be stored in V. */
+
+#define VECTOR_SIZE(v) ((v)->header.size & PSEUDOVECTOR_FLAG ? \
+ (PSEUDOVECTOR_SIZE_MASK & (v)->header.size) : \
+ (v)->header.size)
+
+/* Nonzero if VECTOR pointer is valid pointer inside BLOCK. */
+
+#define VECTOR_IN_BLOCK(vector, block) \
+ ((char *) (vector) <= (block)->data \
+ + VECTOR_BLOCK_BYTES - VBLOCK_BYTES_MIN)
+
+/* Number of bytes used by vector-block-allocated object. This is the only
+ place where we actually use the `nbytes' field of the vector-header.
+ I.e. we could get rid of the `nbytes' field by computing it based on the
+ vector-type. */
+
+#define PSEUDOVECTOR_NBYTES(vector) \
+ (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE) \
+ ? vector->header.size & PSEUDOVECTOR_SIZE_MASK \
+ : vector->header.next.nbytes)
+
+/* Reclaim space used by unmarked vectors. */
+
+static void
+sweep_vectors (void)
+{
+ struct vector_block *block = vector_blocks, **bprev = &vector_blocks;
+ struct Lisp_Vector *vector, *next, **vprev = &large_vectors;
+
+ total_vector_size = 0;
+ memset (vector_free_lists, 0, sizeof (vector_free_lists));
+
+ /* Looking through vector blocks. */
+
+ for (block = vector_blocks; block; block = *bprev)
+ {
+ int free_this_block = 0;
+
+ for (vector = (struct Lisp_Vector *) block->data;
+ VECTOR_IN_BLOCK (vector, block); vector = next)
+ {
+ if (VECTOR_MARKED_P (vector))
+ {
+ VECTOR_UNMARK (vector);
+ total_vector_size += VECTOR_SIZE (vector);
+ next = ADVANCE (vector, vector->header.next.nbytes);
+ }
+ else
+ {
+ ptrdiff_t nbytes = PSEUDOVECTOR_NBYTES (vector);
+ ptrdiff_t total_bytes = nbytes;
+
+ next = ADVANCE (vector, nbytes);
-static struct Lisp_Vector *all_vectors;
+ /* While NEXT is not marked, try to coalesce with VECTOR,
+ thus making VECTOR of the largest possible size. */
-/* Total number of vector-like objects now in use. */
+ while (VECTOR_IN_BLOCK (next, block))
+ {
+ if (VECTOR_MARKED_P (next))
+ break;
+ nbytes = PSEUDOVECTOR_NBYTES (next);
+ total_bytes += nbytes;
+ next = ADVANCE (next, nbytes);
+ }
-static int n_vectors;
+ eassert (total_bytes % roundup_size == 0);
+
+ if (vector == (struct Lisp_Vector *) block->data
+ && !VECTOR_IN_BLOCK (next, block))
+ /* This block should be freed because all of it's
+ space was coalesced into the only free vector. */
+ free_this_block = 1;
+ else
+ {
+ int tmp;
+ SETUP_ON_FREE_LIST (vector, total_bytes, tmp);
+ }
+ }
+ }
+ if (free_this_block)
+ {
+ *bprev = block->next;
+#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
+ mem_delete (mem_find (block->data));
+#endif
+ xfree (block);
+ }
+ else
+ bprev = &block->next;
+ }
+
+ /* Sweep large vectors. */
+
+ for (vector = large_vectors; vector; vector = *vprev)
+ {
+ if (VECTOR_MARKED_P (vector))
+ {
+ VECTOR_UNMARK (vector);
+ total_vector_size += VECTOR_SIZE (vector);
+ vprev = &vector->header.next.vector;
+ }
+ else
+ {
+ *vprev = vector->header.next.vector;
+ lisp_free (vector);
+ }
+ }
+}
/* Value is a pointer to a newly allocated Lisp_Vector structure
with room for LEN Lisp_Objects. */
static struct Lisp_Vector *
-allocate_vectorlike (len)
- EMACS_INT len;
+allocate_vectorlike (ptrdiff_t len)
{
struct Lisp_Vector *p;
- size_t nbytes;
MALLOC_BLOCK_INPUT;
-#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);
-#endif
-
/* This gets triggered by code which I haven't bothered to fix. --Stef */
/* eassert (!handling_signal); */
- nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
- p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
+ if (len == 0)
+ p = zero_vector;
+ else
+ {
+ size_t nbytes = header_size + len * word_size;
#ifdef DOUG_LEA_MALLOC
- /* Back to a reasonable maximum of mmap'ed areas. */
- mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+ /* 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);
#endif
- consing_since_gc += nbytes;
- vector_cells_consed += len;
+ if (nbytes <= VBLOCK_BYTES_MAX)
+ p = allocate_vector_from_block (vroundup (nbytes));
+ else
+ {
+ p = lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
+ p->header.next.vector = large_vectors;
+ large_vectors = p;
+ }
+
+#ifdef DOUG_LEA_MALLOC
+ /* Back to a reasonable maximum of mmap'ed areas. */
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+#endif
- p->header.next.vector = all_vectors;
- all_vectors = p;
+ consing_since_gc += nbytes;
+ vector_cells_consed += len;
+ }
MALLOC_UNBLOCK_INPUT;
- ++n_vectors;
return p;
}
-/* Allocate a vector with NSLOTS slots. */
+/* Allocate a vector with LEN slots. */
struct Lisp_Vector *
-allocate_vector (nslots)
- EMACS_INT nslots;
+allocate_vector (EMACS_INT len)
{
- struct Lisp_Vector *v = allocate_vectorlike (nslots);
- v->header.size = nslots;
+ struct Lisp_Vector *v;
+ ptrdiff_t nbytes_max = min (PTRDIFF_MAX, SIZE_MAX);
+
+ if (min ((nbytes_max - header_size) / word_size, MOST_POSITIVE_FIXNUM) < len)
+ memory_full (SIZE_MAX);
+ v = allocate_vectorlike (len);
+ v->header.size = len;
return v;
}
/* Allocate other vector-like structures. */
struct Lisp_Vector *
-allocate_pseudovector (memlen, lisplen, tag)
- int memlen, lisplen;
- EMACS_INT tag;
+allocate_pseudovector (int memlen, int lisplen, int tag)
{
struct Lisp_Vector *v = allocate_vectorlike (memlen);
- EMACS_INT i;
+ int i;
/* Only the first lisplen slots will be traced normally by the GC. */
for (i = 0; i < lisplen; ++i)
return v;
}
+struct buffer *
+allocate_buffer (void)
+{
+ struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER);
+
+ XSETPVECTYPESIZE (b, PVEC_BUFFER, (offsetof (struct buffer, own_text)
+ - header_size) / word_size);
+ /* Note that the fields of B are not initialized. */
+ 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 ()
+allocate_window (void)
{
- return ALLOCATE_PSEUDOVECTOR(struct window, current_matrix, PVEC_WINDOW);
-}
+ 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 ()
+allocate_terminal (void)
{
- struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal,
- next_terminal, PVEC_TERMINAL);
- /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
- bzero (&(t->next_terminal),
- ((char*)(t+1)) - ((char*)&(t->next_terminal)));
+ 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 ()
+allocate_frame (void)
{
- struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame,
- face_cache, PVEC_FRAME);
- /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
- bzero (&(f->face_cache),
- ((char*)(f+1)) - ((char*)&(f->face_cache)));
+ 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 ()
+allocate_process (void)
{
- return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
-}
+ 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'. */)
- (length, init)
- register Lisp_Object length, init;
+ (register Lisp_Object length, Lisp_Object init)
{
Lisp_Object vector;
- register EMACS_INT sizei;
- register int index;
+ register ptrdiff_t sizei;
+ register ptrdiff_t i;
register struct Lisp_Vector *p;
CHECK_NATNUM (length);
- sizei = XFASTINT (length);
- p = allocate_vector (sizei);
- for (index = 0; index < sizei; index++)
- p->contents[index] = init;
+ p = allocate_vector (XFASTINT (length));
+ sizei = XFASTINT (length);
+ for (i = 0; i < sizei; i++)
+ p->contents[i] = init;
XSETVECTOR (vector, p);
return vector;
doc: /* Return a newly created vector with specified arguments as elements.
Any number of arguments, even zero arguments, are allowed.
usage: (vector &rest OBJECTS) */)
- (nargs, args)
- register int nargs;
- Lisp_Object *args;
+ (ptrdiff_t nargs, Lisp_Object *args)
{
register Lisp_Object len, val;
- register int index;
+ ptrdiff_t i;
register struct Lisp_Vector *p;
XSETFASTINT (len, nargs);
val = Fmake_vector (len, Qnil);
p = XVECTOR (val);
- for (index = 0; index < nargs; index++)
- p->contents[index] = args[index];
+ for (i = 0; i < nargs; i++)
+ p->contents[i] = args[i];
return val;
}
+void
+make_byte_code (struct Lisp_Vector *v)
+{
+ 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
+ earlier because they produced a raw 8-bit string for byte-code
+ and now such a byte-code string is loaded as multibyte while
+ raw 8-bit characters converted to multibyte form. Thus, now we
+ must convert them back to the original unibyte form. */
+ v->contents[1] = Fstring_as_unibyte (v->contents[1]);
+ XSETPVECTYPE (v, PVEC_COMPILED);
+}
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
doc: /* Create a byte-code object with specified arguments as elements.
-The arguments should be the arglist, bytecode-string, constant vector,
-stack size, (optional) doc string, and (optional) interactive spec.
+The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
+vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
+and (optional) INTERACTIVE-SPEC.
The first four arguments are required; at most six have any
significance.
+The ARGLIST can be either like the one of `lambda', in which case the arguments
+will be dynamically bound before executing the byte code, or it can be an
+integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
+minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
+of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
+argument to catch the left-over arguments. If such an integer is used, the
+arguments will not be dynamically bound but will be instead pushed on the
+stack before executing the byte-code.
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
- (nargs, args)
- register int nargs;
- Lisp_Object *args;
+ (ptrdiff_t nargs, Lisp_Object *args)
{
register Lisp_Object len, val;
- register int index;
+ ptrdiff_t i;
register struct Lisp_Vector *p;
- XSETFASTINT (len, nargs);
- if (!NILP (Vpurify_flag))
- val = make_pure_vector ((EMACS_INT) nargs);
- else
- val = Fmake_vector (len, Qnil);
+ /* We used to purecopy everything here, if purify-flga was set. This worked
+ OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
+ dangerous, since make-byte-code is used during execution to build
+ closures, so any closure built during the preload phase would end up
+ copied into pure space, including its free variables, which is sometimes
+ just wasteful and other times plainly wrong (e.g. those free vars may want
+ to be setcar'd). */
- if (nargs > 1 && STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
- /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
- earlier because they produced a raw 8-bit string for byte-code
- and now such a byte-code string is loaded as multibyte while
- raw 8-bit characters converted to multibyte form. Thus, now we
- must convert them back to the original unibyte form. */
- args[1] = Fstring_as_unibyte (args[1]);
+ XSETFASTINT (len, nargs);
+ val = Fmake_vector (len, Qnil);
p = XVECTOR (val);
- for (index = 0; index < nargs; index++)
- {
- if (!NILP (Vpurify_flag))
- args[index] = Fpurecopy (args[index]);
- p->contents[index] = args[index];
- }
- XSETPVECTYPE (p, PVEC_COMPILED);
+ for (i = 0; i < nargs; i++)
+ p->contents[i] = args[i];
+ make_byte_code (p);
XSETCOMPILED (val, p);
return val;
}
Symbol Allocation
***********************************************************************/
+/* Like struct Lisp_Symbol, but padded so that the size is a multiple
+ of the required alignment if LSB tags are used. */
+
+union aligned_Lisp_Symbol
+{
+ struct Lisp_Symbol s;
+#if USE_LSB_TAG
+ unsigned char c[(sizeof (struct Lisp_Symbol) + (1 << GCTYPEBITS) - 1)
+ & -(1 << GCTYPEBITS)];
+#endif
+};
+
/* Each symbol_block is just under 1020 bytes long, since malloc
really allocates in units of powers of two and uses 4 bytes for its
- own overhead. */
+ own overhead. */
#define SYMBOL_BLOCK_SIZE \
- ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
+ ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
struct symbol_block
{
/* Place `symbols' first, to preserve alignment. */
- struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
+ union aligned_Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
struct symbol_block *next;
};
static struct Lisp_Symbol *symbol_free_list;
-/* Total number of symbol blocks now in use. */
-
-static int n_symbol_blocks;
-
/* Initialize symbol allocation. */
static void
-init_symbol ()
+init_symbol (void)
{
symbol_block = NULL;
symbol_block_index = SYMBOL_BLOCK_SIZE;
symbol_free_list = 0;
- n_symbol_blocks = 0;
}
DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
doc: /* Return a newly allocated uninterned symbol whose name is NAME.
Its value and function definition are void, and its property list is nil. */)
- (name)
- Lisp_Object name;
+ (Lisp_Object name)
{
register Lisp_Object val;
register struct Lisp_Symbol *p;
{
if (symbol_block_index == SYMBOL_BLOCK_SIZE)
{
- struct symbol_block *new;
- new = (struct symbol_block *) lisp_malloc (sizeof *new,
- MEM_TYPE_SYMBOL);
+ struct symbol_block *new
+ = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL);
new->next = symbol_block;
symbol_block = new;
symbol_block_index = 0;
- n_symbol_blocks++;
}
- XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
+ XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index].s);
symbol_block_index++;
}
p = XSYMBOL (val);
p->xname = name;
p->plist = Qnil;
- p->value = Qunbound;
+ p->redirect = SYMBOL_PLAINVAL;
+ SET_SYMBOL_VAL (p, Qunbound);
p->function = Qunbound;
p->next = NULL;
p->gcmarkbit = 0;
p->interned = SYMBOL_UNINTERNED;
p->constant = 0;
- p->indirect_variable = 0;
+ p->declared_special = 0;
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
return val;
Marker (Misc) Allocation
***********************************************************************/
+/* Like union Lisp_Misc, but padded so that its size is a multiple of
+ the required alignment when LSB tags are used. */
+
+union aligned_Lisp_Misc
+{
+ union Lisp_Misc m;
+#if USE_LSB_TAG
+ unsigned char c[(sizeof (union Lisp_Misc) + (1 << GCTYPEBITS) - 1)
+ & -(1 << GCTYPEBITS)];
+#endif
+};
+
/* Allocation of markers and other objects that share that structure.
Works like allocation of conses. */
#define MARKER_BLOCK_SIZE \
- ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
+ ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
struct marker_block
{
/* Place `markers' first, to preserve alignment. */
- union Lisp_Misc markers[MARKER_BLOCK_SIZE];
+ union aligned_Lisp_Misc markers[MARKER_BLOCK_SIZE];
struct marker_block *next;
};
static union Lisp_Misc *marker_free_list;
-/* Total number of marker blocks now in use. */
-
-static int n_marker_blocks;
-
static void
-init_marker ()
+init_marker (void)
{
marker_block = NULL;
marker_block_index = MARKER_BLOCK_SIZE;
marker_free_list = 0;
- n_marker_blocks = 0;
}
/* Return a newly allocated Lisp_Misc object, with no substructure. */
Lisp_Object
-allocate_misc ()
+allocate_misc (void)
{
Lisp_Object val;
{
if (marker_block_index == MARKER_BLOCK_SIZE)
{
- struct marker_block *new;
- new = (struct marker_block *) lisp_malloc (sizeof *new,
- MEM_TYPE_MISC);
+ struct marker_block *new = lisp_malloc (sizeof *new, MEM_TYPE_MISC);
new->next = marker_block;
marker_block = new;
marker_block_index = 0;
- n_marker_blocks++;
total_free_markers += MARKER_BLOCK_SIZE;
}
- XSETMISC (val, &marker_block->markers[marker_block_index]);
+ XSETMISC (val, &marker_block->markers[marker_block_index].m);
marker_block_index++;
}
/* Free a Lisp_Misc object */
-void
-free_misc (misc)
- Lisp_Object misc;
+static void
+free_misc (Lisp_Object misc)
{
XMISCTYPE (misc) = Lisp_Misc_Free;
XMISC (misc)->u_free.chain = marker_free_list;
The unwind function can get the C values back using XSAVE_VALUE. */
Lisp_Object
-make_save_value (pointer, integer)
- void *pointer;
- int integer;
+make_save_value (void *pointer, ptrdiff_t integer)
{
register Lisp_Object val;
register struct Lisp_Save_Value *p;
DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
doc: /* Return a newly allocated marker which does not point at any place. */)
- ()
+ (void)
{
register Lisp_Object val;
register struct Lisp_Marker *p;
return val;
}
+/* Return a newly allocated marker which points into BUF
+ at character position CHARPOS and byte position BYTEPOS. */
+
+Lisp_Object
+build_marker (struct buffer *buf, ptrdiff_t charpos, ptrdiff_t bytepos)
+{
+ Lisp_Object obj;
+ struct Lisp_Marker *m;
+
+ /* No dead buffers here. */
+ eassert (!NILP (BVAR (buf, name)));
+
+ /* Every character is at least one byte. */
+ eassert (charpos <= bytepos);
+
+ obj = allocate_misc ();
+ XMISCTYPE (obj) = Lisp_Misc_Marker;
+ m = XMARKER (obj);
+ m->buffer = buf;
+ m->charpos = charpos;
+ m->bytepos = bytepos;
+ m->insertion_type = 0;
+ m->next = BUF_MARKERS (buf);
+ BUF_MARKERS (buf) = m;
+ return obj;
+}
+
/* Put MARKER back on the free list after using it temporarily. */
void
-free_marker (marker)
- Lisp_Object marker;
+free_marker (Lisp_Object marker)
{
unchain_marker (XMARKER (marker));
free_misc (marker);
Any number of arguments, even zero arguments, are allowed. */
Lisp_Object
-make_event_array (nargs, args)
- register int nargs;
- Lisp_Object *args;
+make_event_array (register int nargs, Lisp_Object *args)
{
int i;
are characters that are in 0...127,
after discarding the meta bit and all the bits above it. */
if (!INTEGERP (args[i])
- || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
+ || (XINT (args[i]) & ~(-CHAR_META)) >= 0200)
return Fvector (nargs, args);
/* Since the loop exited, we know that all the things in it are
************************************************************************/
-/* Called if malloc returns zero. */
+/* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
+ there may have been size_t overflow so that malloc was never
+ called, or perhaps malloc was invoked successfully but the
+ resulting pointer had problems fitting into a tagged EMACS_INT. In
+ either case this counts as memory being full even though malloc did
+ not fail. */
void
-memory_full ()
+memory_full (size_t nbytes)
{
- int i;
+ /* Do not go into hysterics merely because a large request failed. */
+ int enough_free_memory = 0;
+ if (SPARE_MEMORY < nbytes)
+ {
+ void *p;
- Vmemory_full = Qt;
+ MALLOC_BLOCK_INPUT;
+ p = malloc (SPARE_MEMORY);
+ if (p)
+ {
+ free (p);
+ enough_free_memory = 1;
+ }
+ MALLOC_UNBLOCK_INPUT;
+ }
- memory_full_cons_threshold = sizeof (struct cons_block);
+ if (! enough_free_memory)
+ {
+ int i;
- /* The first time we get here, free the spare memory. */
- for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
- if (spare_memory[i])
- {
- if (i == 0)
- free (spare_memory[i]);
- else if (i >= 1 && i <= 4)
- lisp_align_free (spare_memory[i]);
- else
- lisp_free (spare_memory[i]);
- spare_memory[i] = 0;
- }
+ Vmemory_full = Qt;
- /* Record the space now used. When it decreases substantially,
- we can refill the memory reserve. */
-#ifndef SYSTEM_MALLOC
- bytes_used_when_full = BYTES_USED;
+ 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++)
+ if (spare_memory[i])
+ {
+ if (i == 0)
+ free (spare_memory[i]);
+ else if (i >= 1 && i <= 4)
+ lisp_align_free (spare_memory[i]);
+ else
+ lisp_free (spare_memory[i]);
+ spare_memory[i] = 0;
+ }
+
+ /* Record the space now used. When it decreases substantially,
+ we can refill the memory reserve. */
+#if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
+ bytes_used_when_full = BYTES_USED;
#endif
+ }
/* This used to call error, but if we've run out of memory, we could
get infinite recursion trying to build the string. */
and also directly from this file, in case we're not using ralloc.c. */
void
-refill_memory_reserve ()
+refill_memory_reserve (void)
{
#ifndef SYSTEM_MALLOC
if (spare_memory[0] == 0)
- spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
+ spare_memory[0] = malloc (SPARE_MEMORY);
if (spare_memory[1] == 0)
- spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block),
+ spare_memory[1] = lisp_align_malloc (sizeof (struct cons_block),
MEM_TYPE_CONS);
if (spare_memory[2] == 0)
- spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block),
- MEM_TYPE_CONS);
+ spare_memory[2] = lisp_align_malloc (sizeof (struct cons_block),
+ MEM_TYPE_CONS);
if (spare_memory[3] == 0)
- spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block),
- MEM_TYPE_CONS);
+ spare_memory[3] = lisp_align_malloc (sizeof (struct cons_block),
+ MEM_TYPE_CONS);
if (spare_memory[4] == 0)
- spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block),
- MEM_TYPE_CONS);
+ spare_memory[4] = lisp_align_malloc (sizeof (struct cons_block),
+ MEM_TYPE_CONS);
if (spare_memory[5] == 0)
- spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block),
- MEM_TYPE_STRING);
+ spare_memory[5] = lisp_malloc (sizeof (struct string_block),
+ MEM_TYPE_STRING);
if (spare_memory[6] == 0)
- spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block),
- MEM_TYPE_STRING);
+ spare_memory[6] = lisp_malloc (sizeof (struct string_block),
+ MEM_TYPE_STRING);
if (spare_memory[0] && spare_memory[1] && spare_memory[5])
Vmemory_full = Qnil;
#endif
/* Initialize this part of alloc.c. */
static void
-mem_init ()
+mem_init (void)
{
mem_z.left = mem_z.right = MEM_NIL;
mem_z.parent = NULL;
/* Value is a pointer to the mem_node containing START. Value is
MEM_NIL if there is no node in the tree containing START. */
-static INLINE struct mem_node *
-mem_find (start)
- void *start;
+static inline struct mem_node *
+mem_find (void *start)
{
struct mem_node *p;
pointer to the node that was inserted. */
static struct mem_node *
-mem_insert (start, end, type)
- void *start, *end;
- enum mem_type type;
+mem_insert (void *start, void *end, enum mem_type type)
{
struct mem_node *c, *parent, *x;
/* Create a new node. */
#ifdef GC_MALLOC_CHECK
- x = (struct mem_node *) _malloc_internal (sizeof *x);
+ x = _malloc_internal (sizeof *x);
if (x == NULL)
abort ();
#else
- x = (struct mem_node *) xmalloc (sizeof *x);
+ x = xmalloc (sizeof *x);
#endif
x->start = start;
x->end = end;
balance the tree, after node X has been inserted; X is always red. */
static void
-mem_insert_fixup (x)
- struct mem_node *x;
+mem_insert_fixup (struct mem_node *x)
{
while (x != mem_root && x->parent->color == MEM_RED)
{
b c a b */
static void
-mem_rotate_left (x)
- struct mem_node *x;
+mem_rotate_left (struct mem_node *x)
{
struct mem_node *y;
a b b c */
static void
-mem_rotate_right (x)
- struct mem_node *x;
+mem_rotate_right (struct mem_node *x)
{
struct mem_node *y = x->left;
/* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
static void
-mem_delete (z)
- struct mem_node *z;
+mem_delete (struct mem_node *z)
{
struct mem_node *x, *y;
deletion. */
static void
-mem_delete_fixup (x)
- struct mem_node *x;
+mem_delete_fixup (struct mem_node *x)
{
while (x != mem_root && x->color == MEM_BLACK)
{
/* Value is non-zero if P is a pointer to a live Lisp string on
the heap. M is a pointer to the mem_block for P. */
-static INLINE int
-live_string_p (m, p)
- struct mem_node *m;
- void *p;
+static inline int
+live_string_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_STRING)
{
struct string_block *b = (struct string_block *) m->start;
- int offset = (char *) p - (char *) &b->strings[0];
+ ptrdiff_t offset = (char *) p - (char *) &b->strings[0];
/* P must point to the start of a Lisp_String structure, and it
must not be on the free-list. */
/* Value is non-zero if P is a pointer to a live Lisp cons on
the heap. M is a pointer to the mem_block for P. */
-static INLINE int
-live_cons_p (m, p)
- struct mem_node *m;
- void *p;
+static inline int
+live_cons_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_CONS)
{
struct cons_block *b = (struct cons_block *) m->start;
- int offset = (char *) p - (char *) &b->conses[0];
+ ptrdiff_t offset = (char *) p - (char *) &b->conses[0];
/* P must point to the start of a Lisp_Cons, not be
one of the unused cells in the current cons block,
/* Value is non-zero if P is a pointer to a live Lisp symbol on
the heap. M is a pointer to the mem_block for P. */
-static INLINE int
-live_symbol_p (m, p)
- struct mem_node *m;
- void *p;
+static inline int
+live_symbol_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_SYMBOL)
{
struct symbol_block *b = (struct symbol_block *) m->start;
- int offset = (char *) p - (char *) &b->symbols[0];
+ ptrdiff_t offset = (char *) p - (char *) &b->symbols[0];
/* P must point to the start of a Lisp_Symbol, not be
one of the unused cells in the current symbol block,
/* Value is non-zero if P is a pointer to a live Lisp float on
the heap. M is a pointer to the mem_block for P. */
-static INLINE int
-live_float_p (m, p)
- struct mem_node *m;
- void *p;
+static inline int
+live_float_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_FLOAT)
{
struct float_block *b = (struct float_block *) m->start;
- int offset = (char *) p - (char *) &b->floats[0];
+ ptrdiff_t offset = (char *) p - (char *) &b->floats[0];
/* P must point to the start of a Lisp_Float and not be
one of the unused cells in the current float block. */
/* Value is non-zero if P is a pointer to a live Lisp Misc on
the heap. M is a pointer to the mem_block for P. */
-static INLINE int
-live_misc_p (m, p)
- struct mem_node *m;
- void *p;
+static inline int
+live_misc_p (struct mem_node *m, void *p)
{
if (m->type == MEM_TYPE_MISC)
{
struct marker_block *b = (struct marker_block *) m->start;
- int offset = (char *) p - (char *) &b->markers[0];
+ ptrdiff_t offset = (char *) p - (char *) &b->markers[0];
/* P must point to the start of a Lisp_Misc, not be
one of the unused cells in the current misc block,
/* Value is non-zero if P is a pointer to a live vector-like object.
M is a pointer to the mem_block for P. */
-static INLINE int
-live_vector_p (m, p)
- struct mem_node *m;
- void *p;
+static inline int
+live_vector_p (struct mem_node *m, void *p)
{
- return (p == m->start && m->type == MEM_TYPE_VECTORLIKE);
+ if (m->type == MEM_TYPE_VECTOR_BLOCK)
+ {
+ /* This memory node corresponds to a vector block. */
+ struct vector_block *block = (struct vector_block *) m->start;
+ struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data;
+
+ /* P is in the block's allocation range. Scan the block
+ up to P and see whether P points to the start of some
+ vector which is not on a free list. FIXME: check whether
+ some allocation patterns (probably a lot of short vectors)
+ may cause a substantial overhead of this loop. */
+ while (VECTOR_IN_BLOCK (vector, block)
+ && vector <= (struct Lisp_Vector *) p)
+ {
+ if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE))
+ vector = ADVANCE (vector, (vector->header.size
+ & PSEUDOVECTOR_SIZE_MASK));
+ else if (vector == p)
+ return 1;
+ else
+ vector = ADVANCE (vector, vector->header.next.nbytes);
+ }
+ }
+ else if (m->type == MEM_TYPE_VECTORLIKE && p == m->start)
+ /* This memory node corresponds to a large vector. */
+ return 1;
+ return 0;
}
/* Value is non-zero if P is a pointer to a live buffer. M is a
pointer to the mem_block for P. */
-static INLINE int
-live_buffer_p (m, p)
- struct mem_node *m;
- void *p;
+static inline int
+live_buffer_p (struct mem_node *m, void *p)
{
/* P must point to the start of the block, and the buffer
must not have been killed. */
return (m->type == MEM_TYPE_BUFFER
&& p == m->start
- && !NILP (((struct buffer *) p)->name));
+ && !NILP (((struct buffer *) p)->BUFFER_INTERNAL_FIELD (name)));
}
#endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
/* Number of zombie objects. */
-static int nzombies;
+static EMACS_INT nzombies;
/* Number of garbage collections. */
-static int ngcs;
+static EMACS_INT ngcs;
/* Average percentage of zombies per collection. */
/* Max. number of live and zombie objects. */
-static int max_live, max_zombies;
+static EMACS_INT max_live, max_zombies;
/* Average number of live objects per GC. */
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;
- int i;
- for (i = 0; i < nzombies; i++)
+ 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);
/* Mark OBJ if we can prove it's a Lisp_Object. */
-static INLINE void
-mark_maybe_object (obj)
- Lisp_Object obj;
+static inline void
+mark_maybe_object (Lisp_Object obj)
{
- void *po = (void *) XPNTR (obj);
- struct mem_node *m = mem_find (po);
+ void *po;
+ struct mem_node *m;
+
+ if (INTEGERP (obj))
+ return;
+
+ po = (void *) XPNTR (obj);
+ m = mem_find (po);
if (m != MEM_NIL)
{
/* If P points to Lisp data, mark that as live if it isn't already
marked. */
-static INLINE void
-mark_maybe_pointer (p)
- void *p;
+static inline void
+mark_maybe_pointer (void *p)
{
struct mem_node *m;
- /* Quickly rule out some values which can't point to Lisp data. */
- if ((EMACS_INT) p %
-#ifdef USE_LSB_TAG
- 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */
-#else
- 2 /* We assume that Lisp data is aligned on even addresses. */
-#endif
- )
+ /* Quickly rule out some values which can't point to Lisp data.
+ USE_LSB_TAG needs Lisp data to be aligned on multiples of 1 << GCTYPEBITS.
+ Otherwise, assume that Lisp data is aligned on even addresses. */
+ if ((intptr_t) p % (USE_LSB_TAG ? 1 << GCTYPEBITS : 2))
return;
m = mem_find (p);
break;
case MEM_TYPE_BUFFER:
- if (live_buffer_p (m, p) && !VECTOR_MARKED_P((struct buffer *)p))
+ if (live_buffer_p (m, p) && !VECTOR_MARKED_P ((struct buffer *)p))
XSETVECTOR (obj, p);
break;
break;
case MEM_TYPE_VECTORLIKE:
+ case MEM_TYPE_VECTOR_BLOCK:
if (live_vector_p (m, p))
{
Lisp_Object tem;
}
+/* Alignment of pointer values. Use offsetof, as it sometimes returns
+ a smaller alignment than GCC's __alignof__ and mark_memory might
+ miss objects if __alignof__ were used. */
+#define GC_POINTER_ALIGNMENT offsetof (struct {char a; void *b;}, b)
+
+/* Define 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. */
static void
-mark_memory (start, end, offset)
- void *start, *end;
- int offset;
+mark_memory (void *start, void *end)
+#ifdef __clang__
+ /* 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
{
- Lisp_Object *p;
void **pp;
+ int i;
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
nzombies = 0;
end = tem;
}
- /* Mark Lisp_Objects. */
- for (p = (Lisp_Object *) ((char *) start + offset); (void *) p < end; ++p)
- mark_maybe_object (*p);
-
/* Mark Lisp data pointed to. This is necessary because, in some
situations, the C compiler optimizes Lisp objects away, so that
only a pointer to them remains. Example:
away. The only reference to the life string is through the
pointer `s'. */
- for (pp = (void **) ((char *) start + offset); (void *) pp < end; ++pp)
- mark_maybe_pointer (*pp);
+ for (pp = start; (void *) pp < end; pp++)
+ for (i = 0; i < sizeof *pp; i += GC_POINTER_ALIGNMENT)
+ {
+ void *p = *(void **) ((char *) pp + i);
+ mark_maybe_pointer (p);
+ if (POINTERS_MIGHT_HIDE_IN_OBJECTS)
+ mark_maybe_object (XIL ((intptr_t) p));
+ }
}
/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
can prove that. */
static void
-test_setjmp ()
+test_setjmp (void)
{
char buf[10];
register int x;
/* Abort if anything GCPRO'd doesn't survive the GC. */
static void
-check_gcpros ()
+check_gcpros (void)
{
struct gcpro *p;
- int i;
+ ptrdiff_t i;
for (p = gcprolist; p; p = p->next)
for (i = 0; i < p->nvars; ++i)
#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
static void
-dump_zombies ()
+dump_zombies (void)
{
int i;
- fprintf (stderr, "\nZombies kept alive = %d:\n", nzombies);
+ fprintf (stderr, "\nZombies kept alive = %"pI"d:\n", nzombies);
for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
{
fprintf (stderr, " %d = ", i);
have to be true! It must be verified for each system, possibly
by taking a look at the source code of setjmp.
+ If __builtin_unwind_init is available (defined by GCC >= 2.8) we
+ can use it as a machine independent method to store all registers
+ to the stack. In this case the macros described in the previous
+ two paragraphs are not used.
+
Stack Layout
Architectures differ in the way their processor stack is organized.
pass starting at the start of the stack + 2. Likewise, if the
minimal alignment of Lisp_Objects on the stack is 1, four passes
would be necessary, each one starting with one byte more offset
- from the stack start.
-
- The current code assumes by default that Lisp_Objects are aligned
- equally on the stack. */
+ from the stack start. */
static void
-mark_stack ()
+mark_stack (void)
{
- int i;
+ 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;
jmp_buf j;
} j;
volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
- void *end;
-
+#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
setjmp (j.j);
end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
#endif /* not GC_SAVE_REGISTERS_ON_STACK */
+#endif /* not HAVE___BUILTIN_UNWIND_INIT */
/* This assumes that the stack is a contiguous region in memory. If
that's not the case, something has to be done here to iterate
over the stack segments. */
-#ifndef GC_LISP_OBJECT_ALIGNMENT
-#ifdef __GNUC__
-#define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
-#else
-#define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
-#endif
-#endif
- for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
- mark_memory (stack_base, end, i);
+ mark_memory (stack_base, end);
+
/* Allow for marking a secondary stack, like the register stack on the
ia64. */
#ifdef GC_MARK_SECONDARY_STACK
/* Determine whether it is safe to access memory at address P. */
static int
-valid_pointer_p (p)
- void *p;
+valid_pointer_p (void *p)
{
#ifdef WINDOWSNT
return w32_valid_pointer_p (p, 16);
#else
- int fd;
+ int fd[2];
/* Obviously, we cannot just access it (we would SEGV trying), so we
trick the o/s to tell us whether p is a valid pointer.
Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
not validate p in that case. */
- if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0)
+ if (pipe (fd) == 0)
{
- int valid = (emacs_write (fd, (char *)p, 16) == 16);
- emacs_close (fd);
- unlink ("__Valid__Lisp__Object__");
+ int valid = (emacs_write (fd[1], (char *) p, 16) == 16);
+ emacs_close (fd[1]);
+ emacs_close (fd[0]);
return valid;
}
so it should only be used in code for manual debugging. */
int
-valid_lisp_object_p (obj)
- Lisp_Object obj;
+valid_lisp_object_p (Lisp_Object obj)
{
void *p;
#if GC_MARK_STACK
return live_float_p (m, p);
case MEM_TYPE_VECTORLIKE:
+ case MEM_TYPE_VECTOR_BLOCK:
return live_vector_p (m, p);
default:
pointer to it. TYPE is the Lisp type for which the memory is
allocated. TYPE < 0 means it's not used for a Lisp object. */
-static POINTER_TYPE *
-pure_alloc (size, type)
- size_t size;
- int type;
+static void *
+pure_alloc (size_t size, int type)
{
- POINTER_TYPE *result;
-#ifdef USE_LSB_TAG
+ void *result;
+#if USE_LSB_TAG
size_t alignment = (1 << GCTYPEBITS);
#else
size_t alignment = sizeof (EMACS_INT);
/* Don't allocate a large amount here,
because it might get mmap'd and then its address
might not be usable. */
- purebeg = (char *) xmalloc (10000);
+ purebeg = xmalloc (10000);
pure_size = 10000;
pure_bytes_used_before_overflow += pure_bytes_used - size;
pure_bytes_used = 0;
/* Print a warning if PURESIZE is too small. */
void
-check_pure_size ()
+check_pure_size (void)
{
if (pure_bytes_used_before_overflow)
- message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
- (int) (pure_bytes_used + pure_bytes_used_before_overflow));
+ message (("emacs:0:Pure Lisp storage overflow (approx. %"pI"d"
+ " bytes needed)"),
+ pure_bytes_used + pure_bytes_used_before_overflow);
}
address. Return NULL if not found. */
static char *
-find_string_data_in_pure (data, nbytes)
- const char *data;
- int nbytes;
+find_string_data_in_pure (const char *data, ptrdiff_t nbytes)
{
- int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
+ int i;
+ ptrdiff_t skip, bm_skip[256], last_char_skip, infinity, start, start_max;
const unsigned char *p;
char *non_lisp_beg;
- if (pure_bytes_used_non_lisp < nbytes + 1)
+ if (pure_bytes_used_non_lisp <= nbytes)
return NULL;
/* Set up the Boyer-Moore table. */
string; then the string is not protected from gc. */
Lisp_Object
-make_pure_string (data, nchars, nbytes, multibyte)
- const char *data;
- int nchars, nbytes;
- int multibyte;
+make_pure_string (const char *data,
+ ptrdiff_t nchars, ptrdiff_t nbytes, int multibyte)
{
Lisp_Object string;
struct Lisp_String *s;
s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
- s->data = find_string_data_in_pure (data, nbytes);
+ s->data = (unsigned char *) find_string_data_in_pure (data, nbytes);
if (s->data == NULL)
{
s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
- bcopy (data, s->data, nbytes);
+ memcpy (s->data, data, nbytes);
s->data[nbytes] = '\0';
}
s->size = nchars;
return string;
}
-/* Return a string a string allocated in pure space. Do not allocate
- the string data, just point to DATA. */
+/* Return a string allocated in pure space. Do not
+ allocate the string data, just point to DATA. */
Lisp_Object
-make_pure_c_string (const char *data)
+make_pure_c_string (const char *data, ptrdiff_t nchars)
{
Lisp_Object string;
struct Lisp_String *s;
- int nchars = strlen (data);
s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
s->size = nchars;
of CAR as car and CDR as cdr. */
Lisp_Object
-pure_cons (car, cdr)
- Lisp_Object car, cdr;
+pure_cons (Lisp_Object car, Lisp_Object cdr)
{
register Lisp_Object new;
struct Lisp_Cons *p;
/* Value is a float object with value NUM allocated from pure space. */
static Lisp_Object
-make_pure_float (num)
- double num;
+make_pure_float (double num)
{
register Lisp_Object new;
struct Lisp_Float *p;
/* Return a vector with room for LEN Lisp_Objects allocated from
pure space. */
-Lisp_Object
-make_pure_vector (len)
- EMACS_INT len;
+static Lisp_Object
+make_pure_vector (ptrdiff_t len)
{
Lisp_Object new;
struct Lisp_Vector *p;
- size_t size = sizeof *p + (len - 1) * sizeof (Lisp_Object);
+ size_t size = (offsetof (struct Lisp_Vector, contents)
+ + len * sizeof (Lisp_Object));
p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
XSETVECTOR (new, p);
doc: /* Make a copy of object OBJ in pure storage.
Recursively copies contents of vectors and cons cells.
Does not copy symbols. Copies strings without text properties. */)
- (obj)
- register Lisp_Object obj;
+ (register Lisp_Object obj)
{
if (NILP (Vpurify_flag))
return obj;
if (PURE_POINTER_P (XPNTR (obj)))
return obj;
+ if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
+ {
+ Lisp_Object tmp = Fgethash (obj, Vpurify_flag, Qnil);
+ if (!NILP (tmp))
+ return tmp;
+ }
+
if (CONSP (obj))
- return pure_cons (XCAR (obj), XCDR (obj));
+ obj = pure_cons (XCAR (obj), XCDR (obj));
else if (FLOATP (obj))
- return make_pure_float (XFLOAT_DATA (obj));
+ obj = make_pure_float (XFLOAT_DATA (obj));
else if (STRINGP (obj))
- return make_pure_string (SDATA (obj), SCHARS (obj),
- SBYTES (obj),
- STRING_MULTIBYTE (obj));
+ obj = make_pure_string (SSDATA (obj), SCHARS (obj),
+ SBYTES (obj),
+ STRING_MULTIBYTE (obj));
else if (COMPILEDP (obj) || VECTORP (obj))
{
register struct Lisp_Vector *vec;
- register int i;
- EMACS_INT size;
+ register ptrdiff_t i;
+ ptrdiff_t size;
- size = XVECTOR_SIZE (obj);
+ size = ASIZE (obj);
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
vec = XVECTOR (make_pure_vector (size));
for (i = 0; i < size; i++)
- vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
+ vec->contents[i] = Fpurecopy (AREF (obj, i));
if (COMPILEDP (obj))
{
XSETPVECTYPE (vec, PVEC_COMPILED);
}
else
XSETVECTOR (obj, vec);
- return obj;
}
else if (MARKERP (obj))
error ("Attempt to copy a marker to pure storage");
+ else
+ /* Not purified, don't hash-cons. */
+ return obj;
+
+ if (HASH_TABLE_P (Vpurify_flag)) /* Hash consing. */
+ Fputhash (obj, obj, Vpurify_flag);
return obj;
}
VARADDRESS. */
void
-staticpro (varaddress)
- Lisp_Object *varaddress;
+staticpro (Lisp_Object *varaddress)
{
staticvec[staticidx++] = varaddress;
if (staticidx >= NSTATICS)
/* Temporarily prevent garbage collection. */
-int
-inhibit_garbage_collection ()
+ptrdiff_t
+inhibit_garbage_collection (void)
{
- int count = SPECPDL_INDEX ();
- int nbits = min (VALBITS, BITS_PER_INT);
+ ptrdiff_t count = SPECPDL_INDEX ();
- specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));
+ specbind (Qgc_cons_threshold, make_number (MOST_POSITIVE_FIXNUM));
return count;
}
`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
`garbage-collect' normally returns a list with info on amount of space in use:
((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
- (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
+ (USED-MISCS . FREE-MISCS) USED-STRING-CHARS USED-VECTOR-SLOTS
(USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
(USED-STRINGS . FREE-STRINGS))
However, if there was overflow in pure space, `garbage-collect'
-returns nil, because real GC can't be done. */)
- ()
+returns nil, because real GC can't be done.
+See Info node `(elisp)Garbage Collection'. */)
+ (void)
{
register struct specbinding *bind;
- struct catchtag *catch;
- struct handler *handler;
char stack_top_variable;
- register int i;
+ ptrdiff_t i;
int message_p;
Lisp_Object total[8];
- int count = SPECPDL_INDEX ();
+ ptrdiff_t count = SPECPDL_INDEX ();
EMACS_TIME t1, t2, t3;
if (abort_on_gc)
turned off in that buffer. Calling truncate_undo_list on
Qt tends to return NULL, which effectively turns undo back on.
So don't call truncate_undo_list if undo_list is Qt. */
- if (! NILP (nextb->name) && ! EQ (nextb->undo_list, Qt))
+ if (! NILP (nextb->BUFFER_INTERNAL_FIELD (name))
+ && ! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
truncate_undo_list (nextb);
/* Shrink buffer gaps, but skip indirect and dead buffers. */
- if (nextb->base_buffer == 0 && !NILP (nextb->name)
+ if (nextb->base_buffer == 0 && !NILP (nextb->BUFFER_INTERNAL_FIELD (name))
&& ! nextb->text->inhibit_shrinking)
{
/* If a buffer's gap size is more than 10% of the buffer
#if MAX_SAVE_STACK > 0
if (NILP (Vpurify_flag))
{
- i = &stack_top_variable - stack_bottom;
- if (i < 0) i = -i;
- if (i < MAX_SAVE_STACK)
+ char *stack;
+ ptrdiff_t stack_size;
+ if (&stack_top_variable < stack_bottom)
+ {
+ stack = &stack_top_variable;
+ stack_size = stack_bottom - &stack_top_variable;
+ }
+ else
+ {
+ stack = stack_bottom;
+ stack_size = &stack_top_variable - stack_bottom;
+ }
+ if (stack_size <= MAX_SAVE_STACK)
{
- if (stack_copy == 0)
- stack_copy = (char *) xmalloc (stack_copy_size = i);
- else if (stack_copy_size < i)
- stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i));
- if (stack_copy)
+ if (stack_copy_size < stack_size)
{
- if ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0)
- bcopy (stack_bottom, stack_copy, i);
- else
- bcopy (&stack_top_variable, stack_copy, i);
+ stack_copy = xrealloc (stack_copy, stack_size);
+ stack_copy_size = stack_size;
}
+ memcpy (stack_copy, stack, stack_size);
}
}
#endif /* MAX_SAVE_STACK > 0 */
#ifdef USE_GTK
{
- extern void xg_mark_data ();
+ extern void xg_mark_data (void);
xg_mark_data ();
}
#endif
for (i = 0; i < tail->nvars; i++)
mark_object (tail->var[i]);
}
-#endif
-
mark_byte_stack ();
+ {
+ struct catchtag *catch;
+ struct handler *handler;
+
for (catch = catchlist; catch; catch = catch->next)
{
mark_object (catch->tag);
mark_object (handler->handler);
mark_object (handler->var);
}
+ }
mark_backtrace ();
+#endif
#ifdef HAVE_WINDOW_SYSTEM
mark_fringe_data ();
turned off in that buffer. Calling truncate_undo_list on
Qt tends to return NULL, which effectively turns undo back on.
So don't call truncate_undo_list if undo_list is Qt. */
- if (! EQ (nextb->undo_list, Qt))
+ if (! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
{
Lisp_Object tail, prev;
- tail = nextb->undo_list;
+ tail = nextb->BUFFER_INTERNAL_FIELD (undo_list);
prev = Qnil;
while (CONSP (tail))
{
&& !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
{
if (NILP (prev))
- nextb->undo_list = tail = XCDR (tail);
+ nextb->BUFFER_INTERNAL_FIELD (undo_list) = tail = XCDR (tail);
else
{
tail = XCDR (tail);
}
/* Now that we have stripped the elements that need not be in the
undo_list any more, we can finally mark the list. */
- mark_object (nextb->undo_list);
+ mark_object (nextb->BUFFER_INTERNAL_FIELD (undo_list));
nextb = nextb->header.next.buffer;
}
if (gc_cons_threshold < 10000)
gc_cons_threshold = 10000;
+ gc_relative_threshold = 0;
if (FLOATP (Vgc_cons_percentage))
{ /* Set gc_cons_combined_threshold. */
- EMACS_INT total = 0;
-
- total += total_conses * sizeof (struct Lisp_Cons);
- total += total_symbols * sizeof (struct Lisp_Symbol);
- total += total_markers * sizeof (union Lisp_Misc);
- total += total_string_size;
- total += total_vector_size * sizeof (Lisp_Object);
- total += total_floats * sizeof (struct Lisp_Float);
- total += total_intervals * sizeof (struct interval);
- total += total_strings * sizeof (struct Lisp_String);
-
- gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
+ double tot = 0;
+
+ tot += total_conses * sizeof (struct Lisp_Cons);
+ tot += total_symbols * sizeof (struct Lisp_Symbol);
+ tot += total_markers * sizeof (union Lisp_Misc);
+ tot += total_string_size;
+ tot += total_vector_size * sizeof (Lisp_Object);
+ tot += total_floats * sizeof (struct Lisp_Float);
+ tot += total_intervals * sizeof (struct interval);
+ tot += total_strings * sizeof (struct Lisp_String);
+
+ tot *= XFLOAT_DATA (Vgc_cons_percentage);
+ if (0 < tot)
+ {
+ if (tot < TYPE_MAXIMUM (EMACS_INT))
+ gc_relative_threshold = tot;
+ else
+ gc_relative_threshold = TYPE_MAXIMUM (EMACS_INT);
+ }
}
- else
- gc_relative_threshold = 0;
if (garbage_collection_messages)
{
if (!NILP (Vpost_gc_hook))
{
- int count = inhibit_garbage_collection ();
+ ptrdiff_t gc_count = inhibit_garbage_collection ();
safe_run_hooks (Qpost_gc_hook);
- unbind_to (count, Qnil);
+ unbind_to (gc_count, Qnil);
}
/* Accumulate statistics. */
- EMACS_GET_TIME (t2);
- EMACS_SUB_TIME (t3, t2, t1);
if (FLOATP (Vgc_elapsed))
- Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) +
- EMACS_SECS (t3) +
- EMACS_USECS (t3) * 1.0e-6);
+ {
+ EMACS_GET_TIME (t2);
+ EMACS_SUB_TIME (t3, t2, t1);
+ Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed)
+ + EMACS_TIME_TO_DOUBLE (t3));
+ }
+
gcs_done++;
return Flist (sizeof total / sizeof *total, total);
only interesting objects referenced from glyphs are strings. */
static void
-mark_glyph_matrix (matrix)
- struct glyph_matrix *matrix;
+mark_glyph_matrix (struct glyph_matrix *matrix)
{
struct glyph_row *row = matrix->rows;
struct glyph_row *end = row + matrix->nrows;
/* Mark Lisp faces in the face cache C. */
static void
-mark_face_cache (c)
- struct face_cache *c;
+mark_face_cache (struct face_cache *c)
{
if (c)
{
#define LAST_MARKED_SIZE 500
static Lisp_Object last_marked[LAST_MARKED_SIZE];
-int last_marked_index;
+static int last_marked_index;
/* For debugging--call abort when we cdr down this many
links of a list, in mark_object. In debugging,
the call to abort will hit a breakpoint.
Normally this is zero and the check never goes off. */
-static int mark_object_loop_halt;
+ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE;
static void
-mark_vectorlike (ptr)
- struct Lisp_Vector *ptr;
+mark_vectorlike (struct Lisp_Vector *ptr)
{
- register EMACS_UINT size = ptr->header.size;
- register int i;
+ ptrdiff_t size = ptr->header.size;
+ ptrdiff_t i;
eassert (!VECTOR_MARKED_P (ptr));
- VECTOR_MARK (ptr); /* Else mark it */
+ VECTOR_MARK (ptr); /* Else mark it. */
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
/* Note that this size is not the memory-footprint size, but only
the number of Lisp_Object fields that we should trace.
The distinction is used e.g. by Lisp_Process which places extra
- non-Lisp_Object fields at the end of the structure. */
- for (i = 0; i < size; i++) /* and then mark its elements */
+ non-Lisp_Object fields at the end of the structure... */
+ for (i = 0; i < size; i++) /* ...and then mark its elements. */
mark_object (ptr->contents[i]);
}
symbols. */
static void
-mark_char_table (ptr)
- struct Lisp_Vector *ptr;
+mark_char_table (struct Lisp_Vector *ptr)
{
- register EMACS_UINT size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
- register int i;
+ int size = ptr->header.size & PSEUDOVECTOR_SIZE_MASK;
+ int i;
eassert (!VECTOR_MARKED_P (ptr));
VECTOR_MARK (ptr);
{
Lisp_Object val = ptr->contents[i];
- if (INTEGERP (val) || SYMBOLP (val) && XSYMBOL (val)->gcmarkbit)
+ if (INTEGERP (val) || (SYMBOLP (val) && XSYMBOL (val)->gcmarkbit))
continue;
if (SUB_CHAR_TABLE_P (val))
{
}
}
+/* Mark the chain of overlays starting at PTR. */
+
+static void
+mark_overlay (struct Lisp_Overlay *ptr)
+{
+ for (; ptr && !ptr->gcmarkbit; ptr = ptr->next)
+ {
+ ptr->gcmarkbit = 1;
+ mark_object (ptr->start);
+ mark_object (ptr->end);
+ mark_object (ptr->plist);
+ }
+}
+
+/* Mark Lisp_Objects and special pointers in BUFFER. */
+
+static void
+mark_buffer (struct buffer *buffer)
+{
+ /* This is handled much like other pseudovectors... */
+ mark_vectorlike ((struct Lisp_Vector *) buffer);
+
+ /* ...but there are some buffer-specific things. */
+
+ MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
+
+ /* For now, we just don't mark the undo_list. It's done later in
+ a special way just before the sweep phase, and after stripping
+ some of its elements that are not needed any more. */
+
+ mark_overlay (buffer->overlays_before);
+ mark_overlay (buffer->overlays_after);
+
+ /* If this is an indirect buffer, mark its base buffer. */
+ if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
+ mark_buffer (buffer->base_buffer);
+}
+
+/* Determine type of generic Lisp_Object and mark it accordingly. */
+
void
-mark_object (arg)
- Lisp_Object arg;
+mark_object (Lisp_Object arg)
{
register Lisp_Object obj = arg;
#ifdef GC_CHECK_MARKED_OBJECTS
void *po;
struct mem_node *m;
#endif
- int cdr_count = 0;
+ ptrdiff_t cdr_count = 0;
loop:
#else /* not GC_CHECK_MARKED_OBJECTS */
-#define CHECK_ALLOCATED() (void) 0
#define CHECK_LIVE(LIVEP) (void) 0
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
if (STRING_MARKED_P (ptr))
break;
CHECK_ALLOCATED_AND_LIVE (live_string_p);
- MARK_INTERVAL_TREE (ptr->intervals);
MARK_STRING (ptr);
+ MARK_INTERVAL_TREE (ptr->intervals);
#ifdef GC_CHECK_STRING_BYTES
/* Check that the string size recorded in the string is the
- same as the one recorded in the sdata structure. */
+ same as the one recorded in the sdata structure. */
CHECK_STRING_BYTES (ptr);
#endif /* GC_CHECK_STRING_BYTES */
}
break;
case Lisp_Vectorlike:
- if (VECTOR_MARKED_P (XVECTOR (obj)))
- break;
+ {
+ register struct Lisp_Vector *ptr = XVECTOR (obj);
+ register ptrdiff_t pvectype;
+
+ if (VECTOR_MARKED_P (ptr))
+ break;
+
#ifdef GC_CHECK_MARKED_OBJECTS
- m = mem_find (po);
- if (m == MEM_NIL && !SUBRP (obj)
- && po != &buffer_defaults
- && po != &buffer_local_symbols)
- abort ();
+ m = mem_find (po);
+ if (m == MEM_NIL && !SUBRP (obj)
+ && po != &buffer_defaults
+ && po != &buffer_local_symbols)
+ abort ();
#endif /* GC_CHECK_MARKED_OBJECTS */
- if (BUFFERP (obj))
- {
+ if (ptr->header.size & PSEUDOVECTOR_FLAG)
+ pvectype = ((ptr->header.size & PVEC_TYPE_MASK)
+ >> PSEUDOVECTOR_SIZE_BITS);
+ else
+ pvectype = 0;
+
+ if (pvectype != PVEC_SUBR && pvectype != PVEC_BUFFER)
+ CHECK_LIVE (live_vector_p);
+
+ switch (pvectype)
+ {
+ case PVEC_BUFFER:
#ifdef GC_CHECK_MARKED_OBJECTS
- if (po != &buffer_defaults && po != &buffer_local_symbols)
+ if (po != &buffer_defaults && po != &buffer_local_symbols)
+ {
+ struct buffer *b = all_buffers;
+ for (; b && b != po; b = b->header.next.buffer)
+ ;
+ if (b == NULL)
+ abort ();
+ }
+#endif /* GC_CHECK_MARKED_OBJECTS */
+ mark_buffer ((struct buffer *) ptr);
+ 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;
+ }
+ }
+ break;
+
+ case PVEC_FRAME:
{
- struct buffer *b;
- for (b = all_buffers; b && b != po; b = b->header.next.buffer)
- ;
- if (b == NULL)
- abort ();
+ mark_vectorlike (ptr);
+ mark_face_cache (((struct frame *) ptr)->face_cache);
}
-#endif /* GC_CHECK_MARKED_OBJECTS */
- mark_buffer (obj);
- }
- else if (SUBRP (obj))
- break;
- else if (COMPILEDP (obj))
- /* We could treat this just like a vector, but it is better to
- save the COMPILED_CONSTANTS element for last and avoid
- recursion there. */
- {
- register struct Lisp_Vector *ptr = XVECTOR (obj);
- register EMACS_UINT size = ptr->header.size;
- register int i;
+ break;
- CHECK_LIVE (live_vector_p);
- VECTOR_MARK (ptr); /* Else mark it */
- size &= PSEUDOVECTOR_SIZE_MASK;
- for (i = 0; i < size; i++) /* and then mark its elements */
+ case PVEC_WINDOW:
{
- if (i != COMPILED_CONSTANTS)
- mark_object (ptr->contents[i]);
+ struct window *w = (struct window *) ptr;
+
+ mark_vectorlike (ptr);
+ /* Mark glyphs for leaf windows. Marking window
+ matrices is sufficient because frame matrices
+ use the same glyph memory. */
+ if (NILP (w->hchild) && NILP (w->vchild) && w->current_matrix)
+ {
+ mark_glyph_matrix (w->current_matrix);
+ mark_glyph_matrix (w->desired_matrix);
+ }
}
- obj = ptr->contents[COMPILED_CONSTANTS];
- goto loop;
- }
- else if (FRAMEP (obj))
- {
- register struct frame *ptr = XFRAME (obj);
- mark_vectorlike (XVECTOR (obj));
- mark_face_cache (ptr->face_cache);
- }
- else if (WINDOWP (obj))
- {
- register struct Lisp_Vector *ptr = XVECTOR (obj);
- struct window *w = XWINDOW (obj);
- mark_vectorlike (ptr);
- /* Mark glyphs for leaf windows. Marking window matrices is
- sufficient because frame matrices use the same glyph
- memory. */
- if (NILP (w->hchild)
- && NILP (w->vchild)
- && w->current_matrix)
+ break;
+
+ case PVEC_HASH_TABLE:
{
- mark_glyph_matrix (w->current_matrix);
- mark_glyph_matrix (w->desired_matrix);
+ struct Lisp_Hash_Table *h = (struct Lisp_Hash_Table *) ptr;
+
+ mark_vectorlike (ptr);
+ /* If hash table is not weak, mark all keys and values.
+ For weak tables, mark only the vector. */
+ if (NILP (h->weak))
+ mark_object (h->key_and_value);
+ else
+ VECTOR_MARK (XVECTOR (h->key_and_value));
}
- }
- else if (HASH_TABLE_P (obj))
- {
- struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
- mark_vectorlike ((struct Lisp_Vector *)h);
- /* If hash table is not weak, mark all keys and values.
- For weak tables, mark only the vector. */
- if (NILP (h->weak))
- mark_object (h->key_and_value);
- else
- VECTOR_MARK (XVECTOR (h->key_and_value));
- }
- else if (CHAR_TABLE_P (obj))
- mark_char_table (XVECTOR (obj));
- else
- mark_vectorlike (XVECTOR (obj));
+ break;
+
+ case PVEC_CHAR_TABLE:
+ mark_char_table (ptr);
+ break;
+
+ case PVEC_BOOL_VECTOR:
+ /* No Lisp_Objects to mark in a bool vector. */
+ VECTOR_MARK (ptr);
+ break;
+
+ case PVEC_SUBR:
+ break;
+
+ case PVEC_FREE:
+ abort ();
+
+ default:
+ mark_vectorlike (ptr);
+ }
+ }
break;
case Lisp_Symbol:
break;
CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
ptr->gcmarkbit = 1;
- mark_object (ptr->value);
mark_object (ptr->function);
mark_object (ptr->plist);
-
+ switch (ptr->redirect)
+ {
+ case SYMBOL_PLAINVAL: mark_object (SYMBOL_VAL (ptr)); break;
+ case SYMBOL_VARALIAS:
+ {
+ Lisp_Object tem;
+ XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
+ mark_object (tem);
+ break;
+ }
+ case SYMBOL_LOCALIZED:
+ {
+ struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
+ /* If the value is forwarded to a buffer or keyboard field,
+ these are marked when we see the corresponding object.
+ And if it's forwarded to a C variable, either it's not
+ a Lisp_Object var, or it's staticpro'd already. */
+ mark_object (blv->where);
+ mark_object (blv->valcell);
+ mark_object (blv->defcell);
+ break;
+ }
+ case SYMBOL_FORWARDED:
+ /* If the value is forwarded to a buffer or keyboard field,
+ these are marked when we see the corresponding object.
+ And if it's forwarded to a C variable, either it's not
+ a Lisp_Object var, or it's staticpro'd already. */
+ break;
+ default: abort ();
+ }
if (!PURE_POINTER_P (XSTRING (ptr->xname)))
MARK_STRING (XSTRING (ptr->xname));
MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
- /* Note that we do not mark the obarray of the symbol.
- It is safe not to do so because nothing accesses that
- slot except to check whether it is nil. */
ptr = ptr->next;
if (ptr)
{
- ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */
+ ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun. */
XSETSYMBOL (obj, ptrx);
goto loop;
}
case Lisp_Misc:
CHECK_ALLOCATED_AND_LIVE (live_misc_p);
+
if (XMISCANY (obj)->gcmarkbit)
break;
- XMISCANY (obj)->gcmarkbit = 1;
switch (XMISCTYPE (obj))
{
- case Lisp_Misc_Buffer_Local_Value:
- {
- register struct Lisp_Buffer_Local_Value *ptr
- = XBUFFER_LOCAL_VALUE (obj);
- /* If the cdr is nil, avoid recursion for the car. */
- if (EQ (ptr->cdr, Qnil))
- {
- obj = ptr->realvalue;
- goto loop;
- }
- mark_object (ptr->realvalue);
- mark_object (ptr->buffer);
- mark_object (ptr->frame);
- obj = ptr->cdr;
- goto loop;
- }
-
case Lisp_Misc_Marker:
/* DO NOT mark thru the marker's chain.
The buffer's markers chain does not preserve markers from gc;
instead, markers are removed from the chain when freed by gc. */
- break;
-
- case Lisp_Misc_Intfwd:
- case Lisp_Misc_Boolfwd:
- case Lisp_Misc_Objfwd:
- case Lisp_Misc_Buffer_Objfwd:
- case Lisp_Misc_Kboard_Objfwd:
- /* Don't bother with Lisp_Buffer_Objfwd,
- since all markable slots in current buffer marked anyway. */
- /* Don't need to do Lisp_Objfwd, since the places they point
- are protected with staticpro. */
+ XMISCANY (obj)->gcmarkbit = 1;
break;
case Lisp_Misc_Save_Value:
+ XMISCANY (obj)->gcmarkbit = 1;
#if GC_MARK_STACK
{
register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
if (ptr->dogc)
{
Lisp_Object *p = (Lisp_Object *) ptr->pointer;
- int nelt;
+ ptrdiff_t nelt;
for (nelt = ptr->integer; nelt > 0; nelt--, p++)
mark_maybe_object (*p);
}
break;
case Lisp_Misc_Overlay:
- {
- struct Lisp_Overlay *ptr = XOVERLAY (obj);
- mark_object (ptr->start);
- mark_object (ptr->end);
- mark_object (ptr->plist);
- if (ptr->next)
- {
- XSETMISC (obj, ptr->next);
- goto loop;
- }
- }
+ mark_overlay (XOVERLAY (obj));
break;
default:
#undef CHECK_ALLOCATED
#undef CHECK_ALLOCATED_AND_LIVE
}
-
-/* Mark the pointers in a buffer structure. */
-
-static void
-mark_buffer (buf)
- Lisp_Object buf;
-{
- register struct buffer *buffer = XBUFFER (buf);
- register Lisp_Object *ptr, tmp;
- Lisp_Object base_buffer;
-
- eassert (!VECTOR_MARKED_P (buffer));
- VECTOR_MARK (buffer);
-
- MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
-
- /* For now, we just don't mark the undo_list. It's done later in
- a special way just before the sweep phase, and after stripping
- some of its elements that are not needed any more. */
-
- if (buffer->overlays_before)
- {
- XSETMISC (tmp, buffer->overlays_before);
- mark_object (tmp);
- }
- if (buffer->overlays_after)
- {
- XSETMISC (tmp, buffer->overlays_after);
- mark_object (tmp);
- }
-
- /* buffer-local Lisp variables start at `undo_list',
- tho only the ones from `name' on are GC'd normally. */
- for (ptr = &buffer->name;
- (char *)ptr < (char *)buffer + sizeof (struct buffer);
- ptr++)
- mark_object (*ptr);
-
- /* If this is an indirect buffer, mark its base buffer. */
- if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
- {
- XSETBUFFER (base_buffer, buffer->base_buffer);
- mark_buffer (base_buffer);
- }
-}
-
/* Mark the Lisp pointers in the terminal objects.
- Called by the Fgarbage_collector. */
+ Called by Fgarbage_collect. */
static void
mark_terminals (void)
either marked or does not need to be marked to survive. */
int
-survives_gc_p (obj)
- Lisp_Object obj;
+survives_gc_p (Lisp_Object obj)
{
int survives_p;
/* Sweep: find all structures not marked, and free them. */
static void
-gc_sweep ()
+gc_sweep (void)
{
/* Remove or mark entries in weak hash tables.
This must be done before any object is unmarked. */
register struct cons_block *cblk;
struct cons_block **cprev = &cons_block;
register int lim = cons_block_index;
- register int num_free = 0, num_used = 0;
+ EMACS_INT num_free = 0, num_used = 0;
cons_free_list = 0;
int ilim = (lim + BITS_PER_INT - 1) / BITS_PER_INT;
/* Scan the mark bits an int at a time. */
- for (i = 0; i <= ilim; i++)
+ for (i = 0; i < ilim; i++)
{
if (cblk->gcmarkbits[i] == -1)
{
/* Unhook from the free list. */
cons_free_list = cblk->conses[0].u.chain;
lisp_align_free (cblk);
- n_cons_blocks--;
}
else
{
register struct float_block *fblk;
struct float_block **fprev = &float_block;
register int lim = float_block_index;
- register int num_free = 0, num_used = 0;
+ EMACS_INT num_free = 0, num_used = 0;
float_free_list = 0;
/* Unhook from the free list. */
float_free_list = fblk->floats[0].u.chain;
lisp_align_free (fblk);
- n_float_blocks--;
}
else
{
register struct interval_block *iblk;
struct interval_block **iprev = &interval_block;
register int lim = interval_block_index;
- register int num_free = 0, num_used = 0;
+ EMACS_INT num_free = 0, num_used = 0;
interval_free_list = 0;
/* Unhook from the free list. */
interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
lisp_free (iblk);
- n_interval_blocks--;
}
else
{
register struct symbol_block *sblk;
struct symbol_block **sprev = &symbol_block;
register int lim = symbol_block_index;
- register int num_free = 0, num_used = 0;
+ EMACS_INT num_free = 0, num_used = 0;
symbol_free_list = NULL;
for (sblk = symbol_block; sblk; sblk = *sprev)
{
int this_free = 0;
- struct Lisp_Symbol *sym = sblk->symbols;
- struct Lisp_Symbol *end = sym + lim;
+ union aligned_Lisp_Symbol *sym = sblk->symbols;
+ union aligned_Lisp_Symbol *end = sym + lim;
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. */
- int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
+ int pure_p = PURE_POINTER_P (XSTRING (sym->s.xname));
- if (!sym->gcmarkbit && !pure_p)
+ if (!sym->s.gcmarkbit && !pure_p)
{
- sym->next = symbol_free_list;
- symbol_free_list = sym;
+ 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
{
++num_used;
if (!pure_p)
- UNMARK_STRING (XSTRING (sym->xname));
- sym->gcmarkbit = 0;
+ UNMARK_STRING (XSTRING (sym->s.xname));
+ sym->s.gcmarkbit = 0;
}
}
{
*sprev = sblk->next;
/* Unhook from the free list. */
- symbol_free_list = sblk->symbols[0].next;
+ symbol_free_list = sblk->symbols[0].s.next;
lisp_free (sblk);
- n_symbol_blocks--;
}
else
{
register struct marker_block *mblk;
struct marker_block **mprev = &marker_block;
register int lim = marker_block_index;
- register int num_free = 0, num_used = 0;
+ EMACS_INT num_free = 0, num_used = 0;
marker_free_list = 0;
for (i = 0; i < lim; i++)
{
- if (!mblk->markers[i].u_any.gcmarkbit)
+ if (!mblk->markers[i].m.u_any.gcmarkbit)
{
- if (mblk->markers[i].u_any.type == Lisp_Misc_Marker)
- unchain_marker (&mblk->markers[i].u_marker);
+ 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].u_marker.type = Lisp_Misc_Free;
- mblk->markers[i].u_free.chain = marker_free_list;
- marker_free_list = &mblk->markers[i];
+ 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].u_any.gcmarkbit = 0;
+ mblk->markers[i].m.u_any.gcmarkbit = 0;
}
}
lim = MARKER_BLOCK_SIZE;
{
*mprev = mblk->next;
/* Unhook from the free list. */
- marker_free_list = mblk->markers[0].u_free.chain;
+ marker_free_list = mblk->markers[0].m.u_free.chain;
lisp_free (mblk);
- n_marker_blocks--;
}
else
{
}
}
- /* Free all unmarked vectors */
- {
- register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
- total_vector_size = 0;
-
- while (vector)
- if (!VECTOR_MARKED_P (vector))
- {
- if (prev)
- prev->header.next = vector->header.next;
- else
- all_vectors = vector->header.next.vector;
- next = vector->header.next.vector;
- lisp_free (vector);
- n_vectors--;
- vector = next;
-
- }
- else
- {
- VECTOR_UNMARK (vector);
- if (vector->header.size & PSEUDOVECTOR_FLAG)
- total_vector_size += PSEUDOVECTOR_SIZE_MASK & vector->header.size;
- else
- total_vector_size += vector->header.size;
- prev = vector, vector = vector->header.next.vector;
- }
- }
+ sweep_vectors ();
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive)
doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
This may be helpful in debugging Emacs's memory usage.
We divide the value by 1024 to make sure it fits in a Lisp integer. */)
- ()
+ (void)
{
Lisp_Object end;
- XSETINT (end, (EMACS_INT) sbrk (0) / 1024);
+ XSETINT (end, (intptr_t) (char *) sbrk (0) / 1024);
return end;
}
MISCS include overlays, markers, and some internal types.
Frames, windows, buffers, and subprocesses count as vectors
(but the contents of a buffer's text do not count here). */)
- ()
+ (void)
{
Lisp_Object consed[8];
return Flist (8, consed);
}
+/* Find at most FIND_MAX symbols which have OBJ as their value or
+ function. This is used in gdbinit's `xwhichsymbols' command. */
+
+Lisp_Object
+which_symbols (Lisp_Object obj, EMACS_INT find_max)
+{
+ struct symbol_block *sblk;
+ ptrdiff_t gc_count = inhibit_garbage_collection ();
+ Lisp_Object found = Qnil;
+
+ if (! DEADP (obj))
+ {
+ for (sblk = symbol_block; sblk; sblk = sblk->next)
+ {
+ union aligned_Lisp_Symbol *aligned_sym = sblk->symbols;
+ int bn;
+
+ 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)))
+ {
+ found = Fcons (tem, found);
+ if (--find_max == 0)
+ goto out;
+ }
+ }
+ }
+ }
+
+ out:
+ unbind_to (gc_count, Qnil);
+ return found;
+}
+
+#ifdef ENABLE_CHECKING
int suppress_checking;
void
-die (msg, file, line)
- const char *msg;
- const char *file;
- int line;
+die (const char *msg, const char *file, int line)
{
fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
file, line, msg);
abort ();
}
+#endif
\f
/* Initialization */
void
-init_alloc_once ()
+init_alloc_once (void)
{
/* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
purebeg = PUREBEG;
Vdead = make_pure_string ("DEAD", 4, 4, 0);
#endif
- all_vectors = 0;
ignore_warnings = 1;
#ifdef DOUG_LEA_MALLOC
mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
init_marker ();
init_float ();
init_intervals ();
+ init_vectors ();
init_weak_hash_tables ();
#ifdef REL_ALLOC
consing_since_gc = 0;
gc_cons_threshold = 100000 * sizeof (Lisp_Object);
gc_relative_threshold = 0;
-
-#ifdef VIRT_ADDR_VARIES
- malloc_sbrk_unused = 1<<22; /* A large number */
- malloc_sbrk_used = 100000; /* as reasonable as any number */
-#endif /* VIRT_ADDR_VARIES */
}
void
-init_alloc ()
+init_alloc (void)
{
gcprolist = 0;
byte_stack_list = 0;
}
void
-syms_of_alloc ()
+syms_of_alloc (void)
{
- DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
- doc: /* *Number of bytes of consing between garbage collections.
+ DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
+ doc: /* Number of bytes of consing between garbage collections.
Garbage collection can happen automatically once this many bytes have been
allocated since the last garbage collection. All data types count.
prevent garbage collection during a part of the program.
See also `gc-cons-percentage'. */);
- DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage,
- doc: /* *Portion of the heap used for allocation.
+ DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage,
+ doc: /* Portion of the heap used for allocation.
Garbage collection can happen automatically once this portion of the heap
has been allocated since the last garbage collection.
If this portion is smaller than `gc-cons-threshold', this is ignored. */);
Vgc_cons_percentage = make_float (0.1);
- DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
- doc: /* Number of bytes of sharable Lisp data allocated so far. */);
+ DEFVAR_INT ("pure-bytes-used", pure_bytes_used,
+ doc: /* Number of bytes of shareable Lisp data allocated so far. */);
- DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
+ DEFVAR_INT ("cons-cells-consed", cons_cells_consed,
doc: /* Number of cons cells that have been consed so far. */);
- DEFVAR_INT ("floats-consed", &floats_consed,
+ DEFVAR_INT ("floats-consed", floats_consed,
doc: /* Number of floats that have been consed so far. */);
- DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
+ DEFVAR_INT ("vector-cells-consed", vector_cells_consed,
doc: /* Number of vector cells that have been consed so far. */);
- DEFVAR_INT ("symbols-consed", &symbols_consed,
+ DEFVAR_INT ("symbols-consed", symbols_consed,
doc: /* Number of symbols that have been consed so far. */);
- DEFVAR_INT ("string-chars-consed", &string_chars_consed,
+ DEFVAR_INT ("string-chars-consed", string_chars_consed,
doc: /* Number of string characters that have been consed so far. */);
- DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
- doc: /* Number of miscellaneous objects that have been consed so far. */);
+ DEFVAR_INT ("misc-objects-consed", misc_objects_consed,
+ doc: /* Number of miscellaneous objects that have been consed so far.
+These include markers and overlays, plus certain objects not visible
+to users. */);
- DEFVAR_INT ("intervals-consed", &intervals_consed,
+ DEFVAR_INT ("intervals-consed", intervals_consed,
doc: /* Number of intervals that have been consed so far. */);
- DEFVAR_INT ("strings-consed", &strings_consed,
+ DEFVAR_INT ("strings-consed", strings_consed,
doc: /* Number of strings that have been consed so far. */);
- DEFVAR_LISP ("purify-flag", &Vpurify_flag,
+ DEFVAR_LISP ("purify-flag", Vpurify_flag,
doc: /* Non-nil means loading Lisp code in order to dump an executable.
-This means that certain objects should be allocated in shared (pure) space. */);
+This means that certain objects should be allocated in shared (pure) space.
+It can also be set to a hash-table, in which case this table is used to
+do hash-consing of the objects allocated to pure space. */);
- DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
+ DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages,
doc: /* Non-nil means display messages at start and end of garbage collection. */);
garbage_collection_messages = 0;
- DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook,
+ DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook,
doc: /* Hook run after garbage collection has finished. */);
Vpost_gc_hook = Qnil;
- Qpost_gc_hook = intern_c_string ("post-gc-hook");
- staticpro (&Qpost_gc_hook);
+ DEFSYM (Qpost_gc_hook, "post-gc-hook");
- DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
+ DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data,
doc: /* Precomputed `signal' argument for memory-full error. */);
/* We build this in advance because if we wait until we need it, we might
not be able to allocate the memory to hold it. */
Vmemory_signal_data
= pure_cons (Qerror,
- pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil));
+ pure_cons (build_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil));
- DEFVAR_LISP ("memory-full", &Vmemory_full,
+ DEFVAR_LISP ("memory-full", Vmemory_full,
doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
Vmemory_full = Qnil;
- staticpro (&Qgc_cons_threshold);
- Qgc_cons_threshold = intern_c_string ("gc-cons-threshold");
+ DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
+ DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");
- staticpro (&Qchar_table_extra_slots);
- Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
-
- DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
+ DEFVAR_LISP ("gc-elapsed", Vgc_elapsed,
doc: /* Accumulated time elapsed in garbage collections.
The time is in seconds as a floating point value. */);
- DEFVAR_INT ("gcs-done", &gcs_done,
+ DEFVAR_INT ("gcs-done", gcs_done,
doc: /* Accumulated number of garbage collections done. */);
defsubr (&Scons);
defsubr (&Sgc_status);
#endif
}
-
-/* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
- (do not change this comment) */
HCoop / bpt / emacs.git / blobdiff