/* 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
+ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
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
#undef GC_MALLOC_CHECK
#endif
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#else
+#ifndef HAVE_UNISTD_H
extern POINTER_TYPE *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
#endif /* not DOUG_LEA_MALLOC */
-#if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
+#if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
+#ifdef HAVE_GTK_AND_PTHREAD
/* When GTK uses the file chooser dialog, different backends can be loaded
dynamically. One such a backend is the Gnome VFS backend that gets loaded
} \
while (0)
-#else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
+#else /* ! defined HAVE_GTK_AND_PTHREAD */
#define BLOCK_INPUT_ALLOC BLOCK_INPUT
#define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
-#endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
-
-/* Value of _bytes_used, when spare_memory was freed. */
-
-static __malloc_size_t bytes_used_when_full;
-
-static __malloc_size_t bytes_used_when_reconsidered;
+#endif /* ! defined HAVE_GTK_AND_PTHREAD */
+#endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
#define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
#define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
-/* Value is the number of bytes/chars of S, a pointer to a struct
- Lisp_String. This must be used instead of STRING_BYTES (S) or
- S->size during GC, because S->size contains the mark bit for
+/* Value is the number of bytes of S, a pointer to a struct Lisp_String.
+ Be careful during GC, because S->size contains the mark bit for
strings. */
#define GC_STRING_BYTES(S) (STRING_BYTES (S))
-#define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
+
+/* Global variables. */
+struct emacs_globals globals;
/* Number of bytes of consing done since the last gc. */
int consing_since_gc;
-/* Count the amount of consing of various sorts of space. */
-
-EMACS_INT cons_cells_consed;
-EMACS_INT floats_consed;
-EMACS_INT vector_cells_consed;
-EMACS_INT symbols_consed;
-EMACS_INT string_chars_consed;
-EMACS_INT misc_objects_consed;
-EMACS_INT intervals_consed;
-EMACS_INT strings_consed;
-
-/* Minimum number of bytes of consing since GC before next GC. */
-
-EMACS_INT gc_cons_threshold;
-
/* Similar minimum, computed from Vgc_cons_percentage. */
EMACS_INT gc_relative_threshold;
-static Lisp_Object Vgc_cons_percentage;
-
/* Minimum number of bytes of consing since GC before next GC,
when memory is full. */
int abort_on_gc;
-/* Nonzero means display messages at beginning and end of GC. */
-
-int garbage_collection_messages;
-
-#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 char *spare_memory[7];
+#ifndef SYSTEM_MALLOC
/* Amount of spare memory to keep in large reserve block. */
#define SPARE_MEMORY (1 << 14)
+#endif
/* Number of extra blocks malloc should get when it needs more core. */
static int malloc_hysteresis;
-/* Non-nil means defun should do purecopy on the function definition. */
-
-Lisp_Object Vpurify_flag;
-
-/* Non-nil means we are handling a memory-full error. */
-
-Lisp_Object Vmemory_full;
-
-#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
remapping on more recent systems because this is less important
nowadays than in the days of small memories and timesharing. */
+#ifndef VIRT_ADDR_VARIES
+static
+#endif
EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
#define PUREBEG (char *) pure
-#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;
&& ((PNTR_COMPARISON_TYPE) (P) \
>= (PNTR_COMPARISON_TYPE) purebeg))
-/* Total number of bytes allocated in pure storage. */
-
-EMACS_INT pure_bytes_used;
-
/* Index in pure at which next pure Lisp object will be allocated.. */
static EMACS_INT pure_bytes_used_lisp;
/* 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 size_t stack_copy_size;
+#endif
/* Non-zero means ignore malloc warnings. Set during initialization.
Currently not used. */
static int ignore_warnings;
-Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
+static Lisp_Object Qgc_cons_threshold;
+Lisp_Object Qchar_table_extra_slots;
/* Hook run after GC has finished. */
-Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
-
-Lisp_Object Vgc_elapsed; /* accumulated elapsed time in GC */
-EMACS_INT gcs_done; /* accumulated GCs */
-
-static 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 Lisp_Object Qpost_gc_hook;
-#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));
+static void mark_buffer (Lisp_Object);
+static void mark_terminals (void);
+static void gc_sweep (void);
+static void mark_glyph_matrix (struct glyph_matrix *);
+static void mark_face_cache (struct face_cache *);
-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);
/* When scanning the C stack for live Lisp objects, Emacs keeps track
of what memory allocated via lisp_malloc is intended for what
MEM_TYPE_VECTORLIKE
};
-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 POINTER_TYPE *lisp_align_malloc (size_t, enum mem_type);
+static POINTER_TYPE *lisp_malloc (size_t, enum mem_type);
#if GC_MARK_STACK || defined 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 (EMACS_INT);
+static void lisp_free (POINTER_TYPE *);
+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 *, int);
+static void mem_init (void);
+static struct mem_node *mem_insert (void *, void *, enum mem_type);
+static void mem_insert_fixup (struct mem_node *);
+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 */
static int staticidx = 0;
-static POINTER_TYPE *pure_alloc P_ ((size_t, int));
+static POINTER_TYPE *pure_alloc (size_t, int);
/* Value is SZ rounded up to the next multiple of ALIGNMENT.
/* 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 (void)
{
/* If buffers use the relocating allocator, no need to free
spare_memory, because we may have plenty of malloc space left
/* Like malloc, but wraps allocated block with header and trailer. */
POINTER_TYPE *
-overrun_check_malloc (size)
- size_t size;
+overrun_check_malloc (size_t size)
{
register unsigned char *val;
size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
val = (unsigned char *) malloc (size + overhead);
if (val && check_depth == 1)
{
- bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
+ memcpy (val, xmalloc_overrun_check_header,
+ 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 + size, xmalloc_overrun_check_trailer,
+ XMALLOC_OVERRUN_CHECK_SIZE);
}
--check_depth;
return (POINTER_TYPE *)val;
with header and trailer. */
POINTER_TYPE *
-overrun_check_realloc (block, size)
- POINTER_TYPE *block;
- size_t size;
+overrun_check_realloc (POINTER_TYPE *block, size_t size)
{
- register unsigned char *val = (unsigned char *)block;
+ register unsigned char *val = (unsigned char *) block;
size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
if (val
&& 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_CHECK_SIZE - 4) == 0)
{
size_t osize = XMALLOC_GET_SIZE (val);
- if (bcmp (xmalloc_overrun_check_trailer,
- val + osize,
- XMALLOC_OVERRUN_CHECK_SIZE))
+ if (memcmp (xmalloc_overrun_check_trailer, val + osize,
+ XMALLOC_OVERRUN_CHECK_SIZE))
abort ();
- bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
+ memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
val -= XMALLOC_OVERRUN_CHECK_SIZE;
- bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
+ memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE);
}
val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
if (val && check_depth == 1)
{
- bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
+ memcpy (val, xmalloc_overrun_check_header,
+ 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 + size, xmalloc_overrun_check_trailer,
+ XMALLOC_OVERRUN_CHECK_SIZE);
}
--check_depth;
return (POINTER_TYPE *)val;
/* Like free, but checks block for overrun. */
void
-overrun_check_free (block)
- POINTER_TYPE *block;
+overrun_check_free (POINTER_TYPE *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_CHECK_SIZE - 4) == 0)
{
size_t osize = XMALLOC_GET_SIZE (val);
- if (bcmp (xmalloc_overrun_check_trailer,
- val + osize,
- XMALLOC_OVERRUN_CHECK_SIZE))
+ 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);
#else
- bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
+ memset (val + osize, 0, XMALLOC_OVERRUN_CHECK_SIZE);
val -= XMALLOC_OVERRUN_CHECK_SIZE;
- bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
+ memset (val, 0, XMALLOC_OVERRUN_CHECK_SIZE);
#endif
}
/* Like malloc but check for no memory and block interrupt input.. */
POINTER_TYPE *
-xmalloc (size)
- size_t size;
+xmalloc (size_t size)
{
register POINTER_TYPE *val;
/* Like realloc but check for no memory and block interrupt input.. */
POINTER_TYPE *
-xrealloc (block, size)
- POINTER_TYPE *block;
- size_t size;
+xrealloc (POINTER_TYPE *block, size_t size)
{
register POINTER_TYPE *val;
/* Like free but block interrupt input. */
void
-xfree (block)
- POINTER_TYPE *block;
+xfree (POINTER_TYPE *block)
{
if (!block)
return;
/* 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);
+ 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);
#endif
static POINTER_TYPE *
-lisp_malloc (nbytes, type)
- size_t nbytes;
- enum mem_type type;
+lisp_malloc (size_t nbytes, enum mem_type type)
{
register void *val;
call to lisp_malloc. */
static void
-lisp_free (block)
- POINTER_TYPE *block;
+lisp_free (POINTER_TYPE *block)
{
MALLOC_BLOCK_INPUT;
free (block);
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;
+lisp_align_malloc (size_t nbytes, enum mem_type type)
{
void *base, *val;
struct ablocks *abase;
}
static void
-lisp_align_free (block)
- POINTER_TYPE *block;
+lisp_align_free (POINTER_TYPE *block)
{
struct ablock *ablock = block;
struct ablocks *abase = ABLOCK_ABASE (ablock);
a call to lisp_malloc. */
struct buffer *
-allocate_buffer ()
+allocate_buffer (void)
{
struct buffer *b
= (struct buffer *) lisp_malloc (sizeof (struct buffer),
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
+
+static __malloc_size_t bytes_used_when_reconsidered;
+
+/* Value of _bytes_used, when spare_memory was freed. */
+
+static __malloc_size_t bytes_used_when_full;
/* This function is used as the hook for free to call. */
static void
-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;
/* 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;
/* Called from main to set up malloc to use our hooks. */
void
-uninterrupt_malloc ()
+uninterrupt_malloc (void)
{
#ifdef HAVE_GTK_AND_PTHREAD
#ifdef DOUG_LEA_MALLOC
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 */
/* List of free intervals. */
-INTERVAL interval_free_list;
+static INTERVAL interval_free_list;
/* Total number of interval blocks now in use. */
/* Initialize interval allocation. */
static void
-init_intervals ()
+init_intervals (void)
{
interval_block = NULL;
interval_block_index = INTERVAL_BLOCK_SIZE;
/* Return a new interval. */
INTERVAL
-make_interval ()
+make_interval (void)
{
INTERVAL val;
/* 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,
can't create number objects in macros. */
#ifndef make_number
Lisp_Object
-make_number (n)
- EMACS_INT n;
+make_number (EMACS_INT n)
{
Lisp_Object obj;
obj.s.val = n;
/* 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
/* 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;
static int check_string_bytes_count;
-static void check_string_bytes P_ ((int));
-static void check_sblock P_ ((struct sblock *));
+static void check_string_bytes (int);
+static void check_sblock (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;
+EMACS_INT
+string_bytes (struct Lisp_String *s)
{
- int nbytes = (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
+ EMACS_INT 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)))
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
- int nbytes;
+ EMACS_INT nbytes;
/* Check that the string size recorded in the string is the
same as the one recorded in the sdata structure. */
s = string_free_list;
while (s != NULL)
{
- if ((unsigned)s < 1024)
+ if ((unsigned long)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;
int i;
b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
- bzero (b, sizeof *b);
+ memset (b, 0, sizeof *b);
b->next = string_blocks;
string_blocks = b;
++n_string_blocks;
MALLOC_UNBLOCK_INPUT;
/* Probably not strictly necessary, but play it safe. */
- bzero (s, sizeof *s);
+ memset (s, 0, sizeof *s);
--total_free_strings;
++total_strings;
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 sblock *b;
- int needed, old_nbytes;
+ EMACS_INT needed, old_nbytes;
/* Determine the number of bytes needed to store NBYTES bytes
of string data. */
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 (data + needed, string_overrun_cookie, GC_STRING_OVERRUN_COOKIE_SIZE);
#endif
/* If S had already data assigned, mark that as free by setting its
/* Sweep and compact strings. */
static void
-sweep_strings ()
+sweep_strings (void)
{
struct string_block *b, *next;
struct string_block *live_blocks = NULL;
/* 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;
{
/* Compute the next FROM here because copying below may
overwrite data we need to compute it. */
- int nbytes;
+ EMACS_INT 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
if (from != to)
{
xassert (tb != b || to <= from);
- safe_bcopy ((char *) from, (char *) to, nbytes + GC_STRING_EXTRA);
+ memmove (to, from, nbytes + GC_STRING_EXTRA);
to->string->data = SDATA_DATA (to);
}
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);
{
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 > MOST_POSITIVE_FIXNUM / len)
+ error ("Maximum string size exceeded");
+ 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;
+ EMACS_INT length_in_chars, length_in_elts;
+ int bits_per_value;
CHECK_NATNUM (length);
multibyte, depending on the contents. */
Lisp_Object
-make_string (contents, nbytes)
- const char *contents;
- int nbytes;
+make_string (const char *contents, EMACS_INT nbytes)
{
register Lisp_Object val;
- int nchars, multibyte_nbytes;
+ EMACS_INT nchars, multibyte_nbytes;
- parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
+ parse_str_as_multibyte ((const unsigned char *) contents, nbytes,
+ &nchars, &multibyte_nbytes);
if (nbytes == nchars || nbytes != multibyte_nbytes)
/* CONTENTS contains no multibyte sequences or contains an invalid
multibyte sequence. We must make unibyte string. */
/* 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, EMACS_INT 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,
+ EMACS_INT nchars, EMACS_INT 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,
+ EMACS_INT nchars, EMACS_INT 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,
+ EMACS_INT nchars, EMACS_INT 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;
data warrants. */
Lisp_Object
-build_string (str)
- const char *str;
+build_string (const char *str)
{
return make_string (str, strlen (str));
}
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;
/* Current float_block. */
-struct float_block *float_block;
+static struct float_block *float_block;
/* Index of first unused Lisp_Float in the current float_block. */
-int float_block_index;
+static int float_block_index;
/* Total number of float blocks now in use. */
-int n_float_blocks;
+static int n_float_blocks;
/* Free-list of Lisp_Floats. */
-struct Lisp_Float *float_free_list;
+static struct Lisp_Float *float_free_list;
/* Initialize float allocation. */
static void
-init_float ()
+init_float (void)
{
float_block = NULL;
float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
}
-/* 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;
new = (struct float_block *) 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++;
/* Current cons_block. */
-struct cons_block *cons_block;
+static struct cons_block *cons_block;
/* Index of first unused Lisp_Cons in the current block. */
-int cons_block_index;
+static int cons_block_index;
/* Free-list of Lisp_Cons structures. */
-struct Lisp_Cons *cons_free_list;
+static struct Lisp_Cons *cons_free_list;
/* Total number of cons blocks now in use. */
/* 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. */
/* 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;
register struct cons_block *new;
new = (struct cons_block *) lisp_align_malloc (sizeof *new,
MEM_TYPE_CONS);
- bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
+ memset (new->gcmarkbits, 0, sizeof new->gcmarkbits);
new->next = cons_block;
cons_block = new;
cons_block_index = 0;
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;
+ (size_t nargs, register 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);
with room for LEN Lisp_Objects. */
static struct Lisp_Vector *
-allocate_vectorlike (len)
- EMACS_INT len;
+allocate_vectorlike (EMACS_INT len)
{
struct Lisp_Vector *p;
size_t nbytes;
/* Allocate a vector with NSLOTS slots. */
struct Lisp_Vector *
-allocate_vector (nslots)
- EMACS_INT nslots;
+allocate_vector (EMACS_INT nslots)
{
struct Lisp_Vector *v = allocate_vectorlike (nslots);
v->size = nslots;
/* 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, EMACS_INT tag)
{
struct Lisp_Vector *v = allocate_vectorlike (memlen);
EMACS_INT i;
struct window *
-allocate_window ()
+allocate_window (void)
{
return ALLOCATE_PSEUDOVECTOR(struct window, current_matrix, PVEC_WINDOW);
}
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)));
+ memset (&t->next_terminal, 0,
+ (char*) (t + 1) - (char*) &t->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)));
+ memset (&f->face_cache, 0,
+ (char *) (f + 1) - (char *) &f->face_cache);
return f;
}
struct Lisp_Process *
-allocate_process ()
+allocate_process (void)
{
return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
}
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 EMACS_INT i;
register struct Lisp_Vector *p;
CHECK_NATNUM (length);
sizei = XFASTINT (length);
p = allocate_vector (sizei);
- for (index = 0; index < sizei; index++)
- p->contents[index] = init;
+ for (i = 0; i < sizei; i++)
+ p->contents[i] = init;
XSETVECTOR (vector, p);
return vector;
doc: /* Return a newly created vector with specified arguments as elements.
Any number of arguments, even zero arguments, are allowed.
usage: (vector &rest OBJECTS) */)
- (nargs, args)
- register int nargs;
- Lisp_Object *args;
+ (register size_t nargs, Lisp_Object *args)
{
register Lisp_Object len, val;
- register int index;
+ register size_t i;
register struct Lisp_Vector *p;
XSETFASTINT (len, nargs);
val = Fmake_vector (len, Qnil);
p = XVECTOR (val);
- for (index = 0; index < nargs; index++)
- p->contents[index] = args[index];
+ for (i = 0; i < nargs; i++)
+ p->contents[i] = args[i];
return val;
}
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
doc: /* Create a byte-code object with specified arguments as elements.
-The arguments should be the arglist, bytecode-string, constant vector,
-stack size, (optional) doc string, and (optional) interactive spec.
+The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
+vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
+and (optional) INTERACTIVE-SPEC.
The first four arguments are required; at most six have any
significance.
+The ARGLIST can be either like the one of `lambda', in which case the arguments
+will be dynamically bound before executing the byte code, or it can be an
+integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
+minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
+of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
+argument to catch the left-over arguments. If such an integer is used, the
+arguments will not be dynamically bound but will be instead pushed on the
+stack before executing the byte-code.
usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
- (nargs, args)
- register int nargs;
- Lisp_Object *args;
+ (register size_t nargs, Lisp_Object *args)
{
register Lisp_Object len, val;
- register int index;
+ register size_t i;
register struct Lisp_Vector *p;
XSETFASTINT (len, nargs);
args[1] = Fstring_as_unibyte (args[1]);
p = XVECTOR (val);
- for (index = 0; index < nargs; index++)
+ for (i = 0; i < nargs; i++)
{
if (!NILP (Vpurify_flag))
- args[index] = Fpurecopy (args[index]);
- p->contents[index] = args[index];
+ args[i] = Fpurecopy (args[i]);
+ p->contents[i] = args[i];
}
XSETPVECTYPE (p, PVEC_COMPILED);
XSETCOMPILED (val, p);
/* Initialize symbol allocation. */
static void
-init_symbol ()
+init_symbol (void)
{
symbol_block = NULL;
symbol_block_index = SYMBOL_BLOCK_SIZE;
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;
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;
static int n_marker_blocks;
static void
-init_marker ()
+init_marker (void)
{
marker_block = NULL;
marker_block_index = MARKER_BLOCK_SIZE;
/* Return a newly allocated Lisp_Misc object, with no substructure. */
Lisp_Object
-allocate_misc ()
+allocate_misc (void)
{
Lisp_Object val;
/* 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, int 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;
/* 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;
/* Called if malloc returns zero. */
void
-memory_full ()
+memory_full (void)
{
int i;
/* Record the space now used. When it decreases substantially,
we can refill the memory reserve. */
-#ifndef SYSTEM_MALLOC
+#if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
bytes_used_when_full = BYTES_USED;
#endif
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)
/* 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;
MEM_NIL if there is no node in the tree containing START. */
static INLINE struct mem_node *
-mem_find (start)
- void *start;
+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;
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)
{
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;
+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. */
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;
+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,
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;
+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,
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;
+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. */
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;
+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,
M is a pointer to the mem_block for P. */
static INLINE int
-live_vector_p (m, p)
- struct mem_node *m;
- void *p;
+live_vector_p (struct mem_node *m, void *p)
{
return (p == m->start && m->type == MEM_TYPE_VECTORLIKE);
}
pointer to the mem_block for P. */
static INLINE int
-live_buffer_p (m, p)
- struct mem_node *m;
- void *p;
+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 */
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;
/* Mark OBJ if we can prove it's a Lisp_Object. */
static INLINE void
-mark_maybe_object (obj)
- Lisp_Object obj;
+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)
{
marked. */
static INLINE void
-mark_maybe_pointer (p)
- void *p;
+mark_maybe_pointer (void *p)
{
struct mem_node *m;
or END+OFFSET..START. */
static void
-mark_memory (start, end, offset)
- void *start, *end;
- int offset;
+mark_memory (void *start, void *end, int offset)
{
Lisp_Object *p;
void **pp;
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;
+ size_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;
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.
equally on the stack. */
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
/* 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);
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
allocated. TYPE < 0 means it's not used for a Lisp object. */
static POINTER_TYPE *
-pure_alloc (size, type)
- size_t size;
- int type;
+pure_alloc (size_t size, int type)
{
POINTER_TYPE *result;
#ifdef USE_LSB_TAG
/* 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)",
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, EMACS_INT nbytes)
{
- int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
+ int i;
+ EMACS_INT skip, bm_skip[256], last_char_skip, infinity, start, start_max;
const unsigned char *p;
char *non_lisp_beg;
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,
+ EMACS_INT nchars, EMACS_INT 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;
{
Lisp_Object string;
struct Lisp_String *s;
- int nchars = strlen (data);
+ EMACS_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;
pure space. */
Lisp_Object
-make_pure_vector (len)
- EMACS_INT len;
+make_pure_vector (EMACS_INT len)
{
Lisp_Object new;
struct Lisp_Vector *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;
+ register EMACS_INT i;
EMACS_INT size;
size = XVECTOR (obj)->size;
}
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 ()
+inhibit_garbage_collection (void)
{
int count = SPECPDL_INDEX ();
int nbits = min (VALBITS, BITS_PER_INT);
(USED-STRINGS . FREE-STRINGS))
However, if there was overflow in pure space, `garbage-collect'
returns nil, because real GC can't be done. */)
- ()
+ (void)
{
register struct specbinding *bind;
- struct catchtag *catch;
- struct handler *handler;
char stack_top_variable;
- register int i;
+ register size_t i;
int message_p;
Lisp_Object total[8];
int count = SPECPDL_INDEX ();
turned off in that buffer. Calling truncate_undo_list on
Qt tends to return NULL, which effectively turns undo back on.
So don't call truncate_undo_list if undo_list is Qt. */
- if (! NILP (nextb->name) && ! EQ (nextb->undo_list, Qt))
+ if (! NILP (nextb->BUFFER_INTERNAL_FIELD (name)) && ! EQ (nextb->BUFFER_INTERNAL_FIELD (undo_list), Qt))
truncate_undo_list (nextb);
/* Shrink buffer gaps, but skip indirect and dead buffers. */
- if (nextb->base_buffer == 0 && !NILP (nextb->name)
+ if (nextb->base_buffer == 0 && !NILP (nextb->BUFFER_INTERNAL_FIELD (name))
&& ! nextb->text->inhibit_shrinking)
{
/* If a buffer's gap size is more than 10% of the buffer
#if MAX_SAVE_STACK > 0
if (NILP (Vpurify_flag))
{
- i = &stack_top_variable - stack_bottom;
- if (i < 0) i = -i;
- if (i < MAX_SAVE_STACK)
+ char *stack;
+ size_t stack_size;
+ if (&stack_top_variable < stack_bottom)
{
- 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)
+ 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_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 = (char *) 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->next;
}
if (FLOATP (Vgc_cons_percentage))
{ /* Set gc_cons_combined_threshold. */
- EMACS_INT total = 0;
-
- total += total_conses * sizeof (struct Lisp_Cons);
- total += total_symbols * sizeof (struct Lisp_Symbol);
- total += total_markers * sizeof (union Lisp_Misc);
- total += total_string_size;
- total += total_vector_size * sizeof (Lisp_Object);
- total += total_floats * sizeof (struct Lisp_Float);
- total += total_intervals * sizeof (struct interval);
- total += total_strings * sizeof (struct Lisp_String);
-
- gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
+ EMACS_INT tot = 0;
+
+ tot += total_conses * sizeof (struct Lisp_Cons);
+ tot += total_symbols * sizeof (struct Lisp_Symbol);
+ tot += total_markers * sizeof (union Lisp_Misc);
+ tot += total_string_size;
+ tot += total_vector_size * sizeof (Lisp_Object);
+ tot += total_floats * sizeof (struct Lisp_Float);
+ tot += total_intervals * sizeof (struct interval);
+ tot += total_strings * sizeof (struct Lisp_String);
+
+ gc_relative_threshold = tot * XFLOAT_DATA (Vgc_cons_percentage);
}
else
gc_relative_threshold = 0;
if (!NILP (Vpost_gc_hook))
{
- int count = inhibit_garbage_collection ();
+ int gc_count = inhibit_garbage_collection ();
safe_run_hooks (Qpost_gc_hook);
- unbind_to (count, Qnil);
+ unbind_to (gc_count, Qnil);
}
/* Accumulate statistics. */
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;
+static size_t mark_object_loop_halt;
static void
-mark_vectorlike (ptr)
- struct Lisp_Vector *ptr;
+mark_vectorlike (struct Lisp_Vector *ptr)
{
- register EMACS_INT size = ptr->size;
- register int i;
+ register EMACS_UINT size = ptr->size;
+ register EMACS_UINT i;
eassert (!VECTOR_MARKED_P (ptr));
VECTOR_MARK (ptr); /* Else mark it */
symbols. */
static void
-mark_char_table (ptr)
- struct Lisp_Vector *ptr;
+mark_char_table (struct Lisp_Vector *ptr)
{
- register EMACS_INT size = ptr->size & PSEUDOVECTOR_SIZE_MASK;
- register int i;
+ register EMACS_UINT size = ptr->size & PSEUDOVECTOR_SIZE_MASK;
+ register EMACS_UINT 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))
{
}
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;
+ size_t cdr_count = 0;
loop:
#else /* not GC_CHECK_MARKED_OBJECTS */
-#define CHECK_ALLOCATED() (void) 0
#define CHECK_LIVE(LIVEP) (void) 0
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
recursion there. */
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
- register EMACS_INT size = ptr->size;
- register int i;
+ register EMACS_UINT size = ptr->size;
+ register EMACS_UINT i;
CHECK_LIVE (live_vector_p);
VECTOR_MARK (ptr); /* Else mark it */
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)
{
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.
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. */
- break;
-
case Lisp_Misc_Save_Value:
#if GC_MARK_STACK
{
/* Mark the pointers in a buffer structure. */
static void
-mark_buffer (buf)
- Lisp_Object buf;
+mark_buffer (Lisp_Object buf)
{
register struct buffer *buffer = XBUFFER (buf);
register Lisp_Object *ptr, tmp;
/* buffer-local Lisp variables start at `undo_list',
tho only the ones from `name' on are GC'd normally. */
- for (ptr = &buffer->name;
+ for (ptr = &buffer->BUFFER_INTERNAL_FIELD (name);
(char *)ptr < (char *)buffer + sizeof (struct buffer);
ptr++)
mark_object (*ptr);
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. */
if (!sym->gcmarkbit && !pure_p)
{
+ if (sym->redirect == SYMBOL_LOCALIZED)
+ xfree (SYMBOL_BLV (sym));
sym->next = symbol_free_list;
symbol_free_list = sym;
#if GC_MARK_STACK
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, (EMACS_INT) (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);
}
+#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;
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,
+ DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
doc: /* *Number of bytes of consing between garbage collections.
Garbage collection can happen automatically once this many bytes have been
allocated since the last garbage collection. All data types count.
prevent garbage collection during a part of the program.
See also `gc-cons-percentage'. */);
- DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage,
+ DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage,
doc: /* *Portion of the heap used for allocation.
Garbage collection can happen automatically once this portion of the heap
has been allocated since the last garbage collection.
If this portion is smaller than `gc-cons-threshold', this is ignored. */);
Vgc_cons_percentage = make_float (0.1);
- DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
+ DEFVAR_INT ("pure-bytes-used", pure_bytes_used,
doc: /* Number of bytes of sharable Lisp data allocated so far. */);
- DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
+ DEFVAR_INT ("cons-cells-consed", cons_cells_consed,
doc: /* Number of cons cells that have been consed so far. */);
- DEFVAR_INT ("floats-consed", &floats_consed,
+ DEFVAR_INT ("floats-consed", floats_consed,
doc: /* Number of floats that have been consed so far. */);
- DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
+ DEFVAR_INT ("vector-cells-consed", vector_cells_consed,
doc: /* Number of vector cells that have been consed so far. */);
- DEFVAR_INT ("symbols-consed", &symbols_consed,
+ DEFVAR_INT ("symbols-consed", symbols_consed,
doc: /* Number of symbols that have been consed so far. */);
- DEFVAR_INT ("string-chars-consed", &string_chars_consed,
+ DEFVAR_INT ("string-chars-consed", string_chars_consed,
doc: /* Number of string characters that have been consed so far. */);
- DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
+ DEFVAR_INT ("misc-objects-consed", misc_objects_consed,
doc: /* Number of miscellaneous objects that have been consed so far. */);
- DEFVAR_INT ("intervals-consed", &intervals_consed,
+ DEFVAR_INT ("intervals-consed", intervals_consed,
doc: /* Number of intervals that have been consed so far. */);
- DEFVAR_INT ("strings-consed", &strings_consed,
+ DEFVAR_INT ("strings-consed", strings_consed,
doc: /* Number of strings that have been consed so far. */);
- DEFVAR_LISP ("purify-flag", &Vpurify_flag,
+ DEFVAR_LISP ("purify-flag", Vpurify_flag,
doc: /* Non-nil means loading Lisp code in order to dump an executable.
-This means that certain objects should be allocated in shared (pure) space. */);
+This means that certain objects should be allocated in shared (pure) space.
+It can also be set to a hash-table, in which case this table is used to
+do hash-consing of the objects allocated to pure space. */);
- DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
+ DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages,
doc: /* Non-nil means display messages at start and end of garbage collection. */);
garbage_collection_messages = 0;
- DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook,
+ DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook,
doc: /* Hook run after garbage collection has finished. */);
Vpost_gc_hook = Qnil;
Qpost_gc_hook = intern_c_string ("post-gc-hook");
staticpro (&Qpost_gc_hook);
- DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
+ DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data,
doc: /* Precomputed `signal' argument for memory-full error. */);
/* We build this in advance because if we wait until we need it, we might
not be able to allocate the memory to hold it. */
= pure_cons (Qerror,
pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil));
- DEFVAR_LISP ("memory-full", &Vmemory_full,
+ DEFVAR_LISP ("memory-full", Vmemory_full,
doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
Vmemory_full = Qnil;
staticpro (&Qchar_table_extra_slots);
Qchar_table_extra_slots = intern_c_string ("char-table-extra-slots");
- DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
+ DEFVAR_LISP ("gc-elapsed", Vgc_elapsed,
doc: /* Accumulated time elapsed in garbage collections.
The time is in seconds as a floating point value. */);
- DEFVAR_INT ("gcs-done", &gcs_done,
+ DEFVAR_INT ("gcs-done", gcs_done,
doc: /* Accumulated number of garbage collections done. */);
defsubr (&Scons);
defsubr (&Sgc_status);
#endif
}
-
-/* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
- (do not change this comment) */
HCoop / bpt / emacs.git / blobdiff