#include <config.h>
#include <stdio.h>
#include <limits.h>
#ifdef STDC_HEADERS
#include <stddef.h>
#endif
#ifdef ALLOC_DEBUG
#undef INLINE
#endif
#include <signal.h>
#ifdef HAVE_GTK_AND_PTHREAD
#include <pthread.h>
#endif
#undef HIDE_LISP_IMPLEMENTATION
#include "lisp.h"
#include "process.h"
#include "intervals.h"
#include "puresize.h"
#include "buffer.h"
#include "window.h"
#include "keyboard.h"
#include "frame.h"
#include "blockinput.h"
#include "charset.h"
#include "syssignal.h"
#include <setjmp.h>
#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
#undef GC_MALLOC_CHECK
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
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
#ifdef DOUG_LEA_MALLOC
#include <malloc.h>
#ifndef __malloc_size_t
#define __malloc_size_t int
#endif
#define MMAP_MAX_AREAS 100000000
#else
#define __malloc_size_t size_t
extern __malloc_size_t _bytes_used;
extern __malloc_size_t __malloc_extra_blocks;
#endif
#if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
static pthread_mutex_t alloc_mutex;
#define BLOCK_INPUT_ALLOC \
do \
{ \
if (pthread_equal (pthread_self (), main_thread)) \
BLOCK_INPUT; \
pthread_mutex_lock (&alloc_mutex); \
} \
while (0)
#define UNBLOCK_INPUT_ALLOC \
do \
{ \
pthread_mutex_unlock (&alloc_mutex); \
if (pthread_equal (pthread_self (), main_thread)) \
UNBLOCK_INPUT; \
} \
while (0)
#else
#define BLOCK_INPUT_ALLOC BLOCK_INPUT
#define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
#endif
static __malloc_size_t bytes_used_when_full;
static __malloc_size_t bytes_used_when_reconsidered;
#define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
#define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
#define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
#define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
#define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
#define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
#define GC_STRING_BYTES(S) (STRING_BYTES (S))
#define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
int consing_since_gc;
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;
EMACS_INT gc_cons_threshold;
EMACS_INT gc_relative_threshold;
static Lisp_Object Vgc_cons_percentage;
EMACS_INT memory_full_cons_threshold;
int gc_in_progress;
int abort_on_gc;
int garbage_collection_messages;
#ifndef VIRT_ADDR_VARIES
extern
#endif
int malloc_sbrk_used;
#ifndef VIRT_ADDR_VARIES
extern
#endif
int malloc_sbrk_unused;
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;
char *spare_memory[7];
#define SPARE_MEMORY (1 << 14)
static int malloc_hysteresis;
Lisp_Object Vpurify_flag;
Lisp_Object Vmemory_full;
#ifndef HAVE_SHM
EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {1,};
#define PUREBEG (char *) pure
#else
#define pure PURE_SEG_BITS
#define PUREBEG (char *)PURE_SEG_BITS
#endif
static char *purebeg;
static size_t pure_size;
static size_t pure_bytes_used_before_overflow;
#define PURE_POINTER_P(P) \
(((PNTR_COMPARISON_TYPE) (P) \
< (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
&& ((PNTR_COMPARISON_TYPE) (P) \
>= (PNTR_COMPARISON_TYPE) purebeg))
EMACS_INT pure_bytes_used;
static EMACS_INT pure_bytes_used_lisp;
static EMACS_INT pure_bytes_used_non_lisp;
char *pending_malloc_warning;
Lisp_Object Vmemory_signal_data;
#ifndef MAX_SAVE_STACK
#define MAX_SAVE_STACK 16000
#endif
char *stack_copy;
int stack_copy_size;
int ignore_warnings;
Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
Lisp_Object Vgc_elapsed;
EMACS_INT gcs_done;
static void mark_buffer P_ ((Lisp_Object));
extern void mark_kboards 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 *));
#ifdef HAVE_WINDOW_SYSTEM
extern void mark_fringe_data P_ ((void));
static void mark_image P_ ((struct image *));
static void mark_image_cache P_ ((struct frame *));
#endif
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;
enum mem_type
{
MEM_TYPE_NON_LISP,
MEM_TYPE_BUFFER,
MEM_TYPE_CONS,
MEM_TYPE_STRING,
MEM_TYPE_MISC,
MEM_TYPE_SYMBOL,
MEM_TYPE_FLOAT,
MEM_TYPE_VECTOR,
MEM_TYPE_PROCESS,
MEM_TYPE_HASH_TABLE,
MEM_TYPE_FRAME,
MEM_TYPE_WINDOW
};
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 ();
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
#include <stdio.h>
#endif
Lisp_Object Vdead;
#ifdef GC_MALLOC_CHECK
enum mem_type allocated_mem_type;
int dont_register_blocks;
#endif
struct mem_node
{
struct mem_node *left, *right;
struct mem_node *parent;
void *start, *end;
enum {MEM_BLACK, MEM_RED} color;
enum mem_type type;
};
Lisp_Object *stack_base;
static struct mem_node *mem_root;
static void *min_heap_address, *max_heap_address;
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, enum mem_type));
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 *));
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
static void check_gcpros P_ ((void));
#endif
#endif
struct gcpro *gcprolist;
#define NSTATICS 1280
Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
int staticidx = 0;
static POINTER_TYPE *pure_alloc P_ ((size_t, int));
#define ALIGN(ptr, ALIGNMENT) \
((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
& ~((ALIGNMENT) - 1)))
void
malloc_warning (str)
char *str;
{
pending_malloc_warning = str;
}
void
display_malloc_warning ()
{
call3 (intern ("display-warning"),
intern ("alloc"),
build_string (pending_malloc_warning),
intern ("emergency"));
pending_malloc_warning = 0;
}
#ifdef DOUG_LEA_MALLOC
# define BYTES_USED (mallinfo ().uordblks)
#else
# define BYTES_USED _bytes_used
#endif
void
buffer_memory_full ()
{
#ifndef REL_ALLOC
memory_full ();
#endif
xsignal (Qnil, Vmemory_signal_data);
}
#ifdef XMALLOC_OVERRUN_CHECK
#define XMALLOC_OVERRUN_CHECK_SIZE 16
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 };
#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))
#define XMALLOC_GET_SIZE(ptr) \
(size_t)((unsigned)(ptr[-1]) | \
((unsigned)(ptr[-2]) << 8) | \
((unsigned)(ptr[-3]) << 16) | \
((unsigned)(ptr[-4]) << 24))
static int check_depth;
POINTER_TYPE *
overrun_check_malloc (size)
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);
val += XMALLOC_OVERRUN_CHECK_SIZE;
XMALLOC_PUT_SIZE(val, size);
bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
}
--check_depth;
return (POINTER_TYPE *)val;
}
POINTER_TYPE *
overrun_check_realloc (block, size)
POINTER_TYPE *block;
size_t size;
{
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)
{
size_t osize = XMALLOC_GET_SIZE (val);
if (bcmp (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);
}
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);
val += XMALLOC_OVERRUN_CHECK_SIZE;
XMALLOC_PUT_SIZE(val, size);
bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
}
--check_depth;
return (POINTER_TYPE *)val;
}
void
overrun_check_free (block)
POINTER_TYPE *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)
{
size_t osize = XMALLOC_GET_SIZE (val);
if (bcmp (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);
val -= XMALLOC_OVERRUN_CHECK_SIZE;
bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
#endif
}
free (val);
--check_depth;
}
#undef malloc
#undef realloc
#undef free
#define malloc overrun_check_malloc
#define realloc overrun_check_realloc
#define free overrun_check_free
#endif
POINTER_TYPE *
xmalloc (size)
size_t size;
{
register POINTER_TYPE *val;
BLOCK_INPUT;
val = (POINTER_TYPE *) malloc (size);
UNBLOCK_INPUT;
if (!val && size)
memory_full ();
return val;
}
POINTER_TYPE *
xrealloc (block, size)
POINTER_TYPE *block;
size_t size;
{
register POINTER_TYPE *val;
BLOCK_INPUT;
if (! block)
val = (POINTER_TYPE *) malloc (size);
else
val = (POINTER_TYPE *) realloc (block, size);
UNBLOCK_INPUT;
if (!val && size) memory_full ();
return val;
}
void
xfree (block)
POINTER_TYPE *block;
{
BLOCK_INPUT;
free (block);
UNBLOCK_INPUT;
}
char *
xstrdup (s)
const char *s;
{
size_t len = strlen (s) + 1;
char *p = (char *) xmalloc (len);
bcopy (s, p, len);
return p;
}
Lisp_Object
safe_alloca_unwind (arg)
Lisp_Object arg;
{
register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);
p->dogc = 0;
xfree (p->pointer);
p->pointer = 0;
free_misc (arg);
return Qnil;
}
#ifndef USE_LSB_TAG
static void *lisp_malloc_loser;
#endif
static POINTER_TYPE *
lisp_malloc (nbytes, type)
size_t nbytes;
enum mem_type type;
{
register void *val;
BLOCK_INPUT;
#ifdef GC_MALLOC_CHECK
allocated_mem_type = type;
#endif
val = (void *) malloc (nbytes);
#ifndef USE_LSB_TAG
if (val && type != MEM_TYPE_NON_LISP)
{
Lisp_Object tem;
XSETCONS (tem, (char *) val + nbytes - 1);
if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
{
lisp_malloc_loser = val;
free (val);
val = 0;
}
}
#endif
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
if (val && type != MEM_TYPE_NON_LISP)
mem_insert (val, (char *) val + nbytes, type);
#endif
UNBLOCK_INPUT;
if (!val && nbytes)
memory_full ();
return val;
}
static void
lisp_free (block)
POINTER_TYPE *block;
{
BLOCK_INPUT;
free (block);
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
mem_delete (mem_find (block));
#endif
UNBLOCK_INPUT;
}
#if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
#define USE_POSIX_MEMALIGN 1
#endif
#define BLOCK_ALIGN (1 << 10)
#define BLOCK_PADDING 0
#define BLOCK_BYTES \
(BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
#define ABLOCKS_SIZE 16
struct ablock
{
union
{
char payload[BLOCK_BYTES];
struct ablock *next_free;
} x;
struct ablocks *abase;
#if BLOCK_PADDING
char padding[BLOCK_PADDING];
#endif
};
struct ablocks
{
struct ablock blocks[ABLOCKS_SIZE];
};
#define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
#define ABLOCK_ABASE(block) \
(((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
? (struct ablocks *)(block) \
: (block)->abase)
#define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
#ifdef USE_POSIX_MEMALIGN
#define ABLOCKS_BASE(abase) (abase)
#else
#define ABLOCKS_BASE(abase) \
(1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
#endif
static struct ablock *free_ablock;
static POINTER_TYPE *
lisp_align_malloc (nbytes, type)
size_t nbytes;
enum mem_type type;
{
void *base, *val;
struct ablocks *abase;
eassert (nbytes <= BLOCK_BYTES);
BLOCK_INPUT;
#ifdef GC_MALLOC_CHECK
allocated_mem_type = type;
#endif
if (!free_ablock)
{
int i;
EMACS_INT aligned;
#ifdef DOUG_LEA_MALLOC
mallopt (M_MMAP_MAX, 0);
#endif
#ifdef USE_POSIX_MEMALIGN
{
int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
if (err)
base = NULL;
abase = base;
}
#else
base = malloc (ABLOCKS_BYTES);
abase = ALIGN (base, BLOCK_ALIGN);
#endif
if (base == 0)
{
UNBLOCK_INPUT;
memory_full ();
}
aligned = (base == abase);
if (!aligned)
((void**)abase)[-1] = base;
#ifdef DOUG_LEA_MALLOC
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
#ifndef USE_LSB_TAG
if (type != MEM_TYPE_NON_LISP)
{
Lisp_Object tem;
char *end = (char *) base + ABLOCKS_BYTES - 1;
XSETCONS (tem, end);
if ((char *) XCONS (tem) != end)
{
lisp_malloc_loser = base;
free (base);
UNBLOCK_INPUT;
memory_full ();
}
}
#endif
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;
eassert (0 == ((EMACS_UINT)abase) % BLOCK_ALIGN);
eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase);
eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
eassert (ABLOCKS_BASE (abase) == base);
eassert (aligned == (long) ABLOCKS_BUSY (abase));
}
abase = ABLOCK_ABASE (free_ablock);
ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (long) 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)
mem_insert (val, (char *) val + nbytes, type);
#endif
UNBLOCK_INPUT;
if (!val && nbytes)
memory_full ();
eassert (0 == ((EMACS_UINT)val) % BLOCK_ALIGN);
return val;
}
static void
lisp_align_free (block)
POINTER_TYPE *block;
{
struct ablock *ablock = block;
struct ablocks *abase = ABLOCK_ABASE (ablock);
BLOCK_INPUT;
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
mem_delete (mem_find (block));
#endif
ablock->x.next_free = free_ablock;
free_ablock = ablock;
ABLOCKS_BUSY (abase) = (struct ablocks *) (-2 + (long) ABLOCKS_BUSY (abase));
if (2 > (long) ABLOCKS_BUSY (abase))
{
int i = 0, aligned = (long) ABLOCKS_BUSY (abase);
struct ablock **tem = &free_ablock;
struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
while (*tem)
{
if (*tem >= (struct ablock *) abase && *tem < atop)
{
i++;
*tem = (*tem)->x.next_free;
}
else
tem = &(*tem)->x.next_free;
}
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);
#endif
free (ABLOCKS_BASE (abase));
}
UNBLOCK_INPUT;
}
struct buffer *
allocate_buffer ()
{
struct buffer *b
= (struct buffer *) lisp_malloc (sizeof (struct buffer),
MEM_TYPE_BUFFER);
return b;
}
#ifndef SYSTEM_MALLOC
#ifndef SYNC_INPUT
#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 *));
#endif
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
emacs_blocked_free (ptr, ptr2)
void *ptr;
const void *ptr2;
{
EMACS_INT bytes_used_now;
BLOCK_INPUT_ALLOC;
#ifdef GC_MALLOC_CHECK
if (ptr)
{
struct mem_node *m;
m = mem_find (ptr);
if (m == MEM_NIL || m->start != ptr)
{
fprintf (stderr,
"Freeing `%p' which wasn't allocated with malloc\n", ptr);
abort ();
}
else
{
mem_delete (m);
}
}
#endif
__free_hook = old_free_hook;
free (ptr);
if (! NILP (Vmemory_full)
&& (bytes_used_when_full
> ((bytes_used_when_reconsidered = BYTES_USED)
+ max (malloc_hysteresis, 4) * SPARE_MEMORY)))
refill_memory_reserve ();
__free_hook = emacs_blocked_free;
UNBLOCK_INPUT_ALLOC;
}
static void *
emacs_blocked_malloc (size, ptr)
size_t size;
const void *ptr;
{
void *value;
BLOCK_INPUT_ALLOC;
__malloc_hook = old_malloc_hook;
#ifdef DOUG_LEA_MALLOC
mallopt (M_TOP_PAD, malloc_hysteresis * 4096);
#else
__malloc_extra_blocks = malloc_hysteresis;
#endif
value = (void *) malloc (size);
#ifdef GC_MALLOC_CHECK
{
struct mem_node *m = mem_find (value);
if (m != MEM_NIL)
{
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",
m->start, m->end, (char *) m->end - (char *) m->start,
m->type);
abort ();
}
if (!dont_register_blocks)
{
mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
allocated_mem_type = MEM_TYPE_NON_LISP;
}
}
#endif
__malloc_hook = emacs_blocked_malloc;
UNBLOCK_INPUT_ALLOC;
return value;
}
static void *
emacs_blocked_realloc (ptr, size, ptr2)
void *ptr;
size_t size;
const void *ptr2;
{
void *value;
BLOCK_INPUT_ALLOC;
__realloc_hook = old_realloc_hook;
#ifdef GC_MALLOC_CHECK
if (ptr)
{
struct mem_node *m = mem_find (ptr);
if (m == MEM_NIL || m->start != ptr)
{
fprintf (stderr,
"Realloc of %p which wasn't allocated with malloc\n",
ptr);
abort ();
}
mem_delete (m);
}
dont_register_blocks = 1;
#endif
value = (void *) realloc (ptr, size);
#ifdef GC_MALLOC_CHECK
dont_register_blocks = 0;
{
struct mem_node *m = mem_find (value);
if (m != MEM_NIL)
{
fprintf (stderr, "Realloc returns memory that is already in use\n");
abort ();
}
mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
}
#endif
__realloc_hook = emacs_blocked_realloc;
UNBLOCK_INPUT_ALLOC;
return value;
}
#ifdef HAVE_GTK_AND_PTHREAD
void
reset_malloc_hooks ()
{
__free_hook = 0;
__malloc_hook = 0;
__realloc_hook = 0;
}
#endif
void
uninterrupt_malloc ()
{
#ifdef HAVE_GTK_AND_PTHREAD
pthread_mutexattr_t attr;
pthread_mutexattr_init (&attr);
pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
pthread_mutex_init (&alloc_mutex, &attr);
#endif
if (__free_hook != emacs_blocked_free)
old_free_hook = __free_hook;
__free_hook = emacs_blocked_free;
if (__malloc_hook != emacs_blocked_malloc)
old_malloc_hook = __malloc_hook;
__malloc_hook = emacs_blocked_malloc;
if (__realloc_hook != emacs_blocked_realloc)
old_realloc_hook = __realloc_hook;
__realloc_hook = emacs_blocked_realloc;
}
#endif
#endif
#define INTERVAL_BLOCK_SIZE \
((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
struct interval_block
{
struct interval intervals[INTERVAL_BLOCK_SIZE];
struct interval_block *next;
};
struct interval_block *interval_block;
static int interval_block_index;
static int total_free_intervals, total_intervals;
INTERVAL interval_free_list;
int n_interval_blocks;
static void
init_intervals ()
{
interval_block = NULL;
interval_block_index = INTERVAL_BLOCK_SIZE;
interval_free_list = 0;
n_interval_blocks = 0;
}
INTERVAL
make_interval ()
{
INTERVAL val;
#ifndef SYNC_INPUT
BLOCK_INPUT;
#endif
if (interval_free_list)
{
val = interval_free_list;
interval_free_list = INTERVAL_PARENT (interval_free_list);
}
else
{
if (interval_block_index == INTERVAL_BLOCK_SIZE)
{
register struct interval_block *newi;
newi = (struct interval_block *) 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++];
}
#ifndef SYNC_INPUT
UNBLOCK_INPUT;
#endif
consing_since_gc += sizeof (struct interval);
intervals_consed++;
RESET_INTERVAL (val);
val->gcmarkbit = 0;
return val;
}
static void
mark_interval (i, dummy)
register INTERVAL i;
Lisp_Object dummy;
{
eassert (!i->gcmarkbit);
i->gcmarkbit = 1;
mark_object (i->plist);
}
static void
mark_interval_tree (tree)
register INTERVAL tree;
{
traverse_intervals_noorder (tree, mark_interval, Qnil);
}
#define MARK_INTERVAL_TREE(i) \
do { \
if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
mark_interval_tree (i); \
} while (0)
#define UNMARK_BALANCE_INTERVALS(i) \
do { \
if (! NULL_INTERVAL_P (i)) \
(i) = balance_intervals (i); \
} while (0)
#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
#define SBLOCK_SIZE 8188
#define LARGE_STRING_BYTES 1024
struct sdata
{
struct Lisp_String *string;
#ifdef GC_CHECK_STRING_BYTES
EMACS_INT nbytes;
unsigned char data[1];
#define SDATA_NBYTES(S) (S)->nbytes
#define SDATA_DATA(S) (S)->data
#else
union
{
unsigned char data[1];
EMACS_INT nbytes;
} u;
#define SDATA_NBYTES(S) (S)->u.nbytes
#define SDATA_DATA(S) (S)->u.data
#endif
};
struct sblock
{
struct sblock *next;
struct sdata *next_free;
struct sdata first_data;
};
#define STRING_BLOCK_SIZE \
((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
struct string_block
{
struct Lisp_String strings[STRING_BLOCK_SIZE];
struct string_block *next;
};
static struct sblock *oldest_sblock, *current_sblock;
static struct sblock *large_sblocks;
static struct string_block *string_blocks;
static int n_string_blocks;
static struct Lisp_String *string_free_list;
static int total_strings, total_free_strings;
static int total_string_size;
#define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
#ifdef GC_CHECK_STRING_BYTES
#define SDATA_OF_STRING(S) \
((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
- sizeof (EMACS_INT)))
#else
#define SDATA_OF_STRING(S) \
((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
#endif
#ifdef GC_CHECK_STRING_OVERRUN
#define GC_STRING_OVERRUN_COOKIE_SIZE 4
static char string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
{ 0xde, 0xad, 0xbe, 0xef };
#else
#define GC_STRING_OVERRUN_COOKIE_SIZE 0
#endif
#ifdef GC_CHECK_STRING_BYTES
#define SDATA_SIZE(NBYTES) \
((sizeof (struct Lisp_String *) \
+ (NBYTES) + 1 \
+ sizeof (EMACS_INT) \
+ sizeof (EMACS_INT) - 1) \
& ~(sizeof (EMACS_INT) - 1))
#else
#define SDATA_SIZE(NBYTES) \
((sizeof (struct Lisp_String *) \
+ (NBYTES) + 1 \
+ sizeof (EMACS_INT) - 1) \
& ~(sizeof (EMACS_INT) - 1))
#endif
#define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
void
init_strings ()
{
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;
}
#ifdef GC_CHECK_STRING_BYTES
static int check_string_bytes_count;
void check_string_bytes P_ ((int));
void check_sblock P_ ((struct sblock *));
#define CHECK_STRING_BYTES(S) STRING_BYTES (S)
int
string_bytes (s)
struct Lisp_String *s;
{
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)))
abort ();
return nbytes;
}
void
check_sblock (b)
struct sblock *b;
{
struct sdata *from, *end, *from_end;
end = b->next_free;
for (from = &b->first_data; from < end; from = from_end)
{
int nbytes;
if (from->string)
CHECK_STRING_BYTES (from->string);
if (from->string)
nbytes = GC_STRING_BYTES (from->string);
else
nbytes = SDATA_NBYTES (from);
nbytes = SDATA_SIZE (nbytes);
from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
}
}
void
check_string_bytes (all_p)
int all_p;
{
if (all_p)
{
struct sblock *b;
for (b = large_sblocks; b; b = b->next)
{
struct Lisp_String *s = b->first_data.string;
if (s)
CHECK_STRING_BYTES (s);
}
for (b = oldest_sblock; b; b = b->next)
check_sblock (b);
}
else
check_sblock (current_sblock);
}
#endif
#ifdef GC_CHECK_STRING_FREE_LIST
static void
check_string_free_list ()
{
struct Lisp_String *s;
s = string_free_list;
while (s != NULL)
{
if ((unsigned)s < 1024)
abort();
s = NEXT_FREE_LISP_STRING (s);
}
}
#else
#define check_string_free_list()
#endif
static struct Lisp_String *
allocate_string ()
{
struct Lisp_String *s;
#ifndef SYNC_INPUT
BLOCK_INPUT;
#endif
if (string_free_list == NULL)
{
struct string_block *b;
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;
NEXT_FREE_LISP_STRING (s) = string_free_list;
string_free_list = s;
}
total_free_strings += STRING_BLOCK_SIZE;
}
check_string_free_list ();
s = string_free_list;
string_free_list = NEXT_FREE_LISP_STRING (s);
#ifndef SYNC_INPUT
UNBLOCK_INPUT;
#endif
bzero (s, sizeof *s);
--total_free_strings;
++total_strings;
++strings_consed;
consing_since_gc += sizeof *s;
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive
#ifdef MAC_OS8
&& current_sblock
#endif
)
{
if (++check_string_bytes_count == 200)
{
check_string_bytes_count = 0;
check_string_bytes (1);
}
else
check_string_bytes (0);
}
#endif
return s;
}
void
allocate_string_data (s, nchars, nbytes)
struct Lisp_String *s;
int nchars, nbytes;
{
struct sdata *data, *old_data;
struct sblock *b;
int needed, old_nbytes;
needed = SDATA_SIZE (nbytes);
old_data = s->data ? SDATA_OF_STRING (s) : NULL;
old_nbytes = GC_STRING_BYTES (s);
#ifndef SYNC_INPUT
BLOCK_INPUT;
#endif
if (nbytes > LARGE_STRING_BYTES)
{
size_t size = sizeof *b - sizeof (struct sdata) + needed;
#ifdef DOUG_LEA_MALLOC
BLOCK_INPUT;
mallopt (M_MMAP_MAX, 0);
UNBLOCK_INPUT;
#endif
b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
#ifdef DOUG_LEA_MALLOC
BLOCK_INPUT;
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
UNBLOCK_INPUT;
#endif
b->next_free = &b->first_data;
b->first_data.string = NULL;
b->next = large_sblocks;
large_sblocks = b;
}
else if (current_sblock == NULL
|| (((char *) current_sblock + SBLOCK_SIZE
- (char *) current_sblock->next_free)
< (needed + GC_STRING_EXTRA)))
{
b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
b->next_free = &b->first_data;
b->first_data.string = NULL;
b->next = NULL;
if (current_sblock)
current_sblock->next = b;
else
oldest_sblock = b;
current_sblock = b;
}
else
b = current_sblock;
data = b->next_free;
b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
#ifndef SYNC_INPUT
UNBLOCK_INPUT;
#endif
data->string = s;
s->data = SDATA_DATA (data);
#ifdef GC_CHECK_STRING_BYTES
SDATA_NBYTES (data) = nbytes;
#endif
s->size = nchars;
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);
#endif
if (old_data)
{
SDATA_NBYTES (old_data) = old_nbytes;
old_data->string = NULL;
}
consing_since_gc += needed;
}
static void
sweep_strings ()
{
struct string_block *b, *next;
struct string_block *live_blocks = NULL;
string_free_list = NULL;
total_strings = total_free_strings = 0;
total_string_size = 0;
for (b = string_blocks; b; b = next)
{
int i, nfree = 0;
struct Lisp_String *free_list_before = string_free_list;
next = b->next;
for (i = 0; i < STRING_BLOCK_SIZE; ++i)
{
struct Lisp_String *s = b->strings + i;
if (s->data)
{
if (STRING_MARKED_P (s))
{
UNMARK_STRING (s);
if (!NULL_INTERVAL_P (s->intervals))
UNMARK_BALANCE_INTERVALS (s->intervals);
++total_strings;
total_string_size += STRING_BYTES (s);
}
else
{
struct sdata *data = SDATA_OF_STRING (s);
#ifdef GC_CHECK_STRING_BYTES
if (GC_STRING_BYTES (s) != SDATA_NBYTES (data))
abort ();
#else
data->u.nbytes = GC_STRING_BYTES (s);
#endif
data->string = NULL;
s->data = NULL;
NEXT_FREE_LISP_STRING (s) = string_free_list;
string_free_list = s;
++nfree;
}
}
else
{
NEXT_FREE_LISP_STRING (s) = string_free_list;
string_free_list = s;
++nfree;
}
}
if (nfree == STRING_BLOCK_SIZE
&& total_free_strings > STRING_BLOCK_SIZE)
{
lisp_free (b);
--n_string_blocks;
string_free_list = free_list_before;
}
else
{
total_free_strings += nfree;
b->next = live_blocks;
live_blocks = b;
}
}
check_string_free_list ();
string_blocks = live_blocks;
free_large_strings ();
compact_small_strings ();
check_string_free_list ();
}
static void
free_large_strings ()
{
struct sblock *b, *next;
struct sblock *live_blocks = NULL;
for (b = large_sblocks; b; b = next)
{
next = b->next;
if (b->first_data.string == NULL)
lisp_free (b);
else
{
b->next = live_blocks;
live_blocks = b;
}
}
large_sblocks = live_blocks;
}
static void
compact_small_strings ()
{
struct sblock *b, *tb, *next;
struct sdata *from, *to, *end, *tb_end;
struct sdata *to_end, *from_end;
tb = oldest_sblock;
tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
to = &tb->first_data;
for (b = oldest_sblock; b; b = b->next)
{
end = b->next_free;
xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
for (from = &b->first_data; from < end; from = from_end)
{
int nbytes;
#ifdef GC_CHECK_STRING_BYTES
if (from->string
&& GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
abort ();
#endif
if (from->string)
nbytes = GC_STRING_BYTES (from->string);
else
nbytes = SDATA_NBYTES (from);
if (nbytes > LARGE_STRING_BYTES)
abort ();
nbytes = SDATA_SIZE (nbytes);
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))
abort ();
#endif
if (from->string)
{
to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
if (to_end > tb_end)
{
tb->next_free = to;
tb = tb->next;
tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
to = &tb->first_data;
to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
}
if (from != to)
{
xassert (tb != b || to <= from);
safe_bcopy ((char *) from, (char *) to, nbytes + GC_STRING_EXTRA);
to->string->data = SDATA_DATA (to);
}
to = to_end;
}
}
}
for (b = tb->next; b; b = next)
{
next = b->next;
lisp_free (b);
}
tb->next_free = to;
tb->next = NULL;
current_sblock = tb;
}
DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
doc: )
(length, init)
Lisp_Object length, init;
{
register Lisp_Object val;
register unsigned char *p, *end;
int c, nbytes;
CHECK_NATNUM (length);
CHECK_NUMBER (init);
c = XINT (init);
if (SINGLE_BYTE_CHAR_P (c))
{
nbytes = XINT (length);
val = make_uninit_string (nbytes);
p = SDATA (val);
end = p + SCHARS (val);
while (p != end)
*p++ = c;
}
else
{
unsigned char str[MAX_MULTIBYTE_LENGTH];
int len = CHAR_STRING (c, str);
nbytes = len * XINT (length);
val = make_uninit_multibyte_string (XINT (length), nbytes);
p = SDATA (val);
end = p + nbytes;
while (p != end)
{
bcopy (str, p, len);
p += len;
}
}
*p = 0;
return val;
}
DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
doc: )
(length, init)
Lisp_Object length, init;
{
register Lisp_Object val;
struct Lisp_Bool_Vector *p;
int real_init, i;
int length_in_chars, length_in_elts, 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);
val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
p = XBOOL_VECTOR (val);
p->vector_size = 0;
XSETBOOL_VECTOR (val, p);
p->size = XFASTINT (length);
real_init = (NILP (init) ? 0 : -1);
for (i = 0; i < length_in_chars ; i++)
p->data[i] = real_init;
if (XINT (length) != length_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
XBOOL_VECTOR (val)->data[length_in_chars - 1]
&= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
return val;
}
Lisp_Object
make_string (contents, nbytes)
const char *contents;
int nbytes;
{
register Lisp_Object val;
int nchars, multibyte_nbytes;
parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
if (nbytes == nchars || nbytes != multibyte_nbytes)
val = make_unibyte_string (contents, nbytes);
else
val = make_multibyte_string (contents, nchars, nbytes);
return val;
}
Lisp_Object
make_unibyte_string (contents, length)
const char *contents;
int length;
{
register Lisp_Object val;
val = make_uninit_string (length);
bcopy (contents, SDATA (val), length);
STRING_SET_UNIBYTE (val);
return val;
}
Lisp_Object
make_multibyte_string (contents, nchars, nbytes)
const char *contents;
int nchars, nbytes;
{
register Lisp_Object val;
val = make_uninit_multibyte_string (nchars, nbytes);
bcopy (contents, SDATA (val), nbytes);
return val;
}
Lisp_Object
make_string_from_bytes (contents, nchars, nbytes)
const char *contents;
int nchars, nbytes;
{
register Lisp_Object val;
val = make_uninit_multibyte_string (nchars, nbytes);
bcopy (contents, SDATA (val), nbytes);
if (SBYTES (val) == SCHARS (val))
STRING_SET_UNIBYTE (val);
return val;
}
Lisp_Object
make_specified_string (contents, nchars, nbytes, multibyte)
const char *contents;
int nchars, nbytes;
int multibyte;
{
register Lisp_Object val;
if (nchars < 0)
{
if (multibyte)
nchars = multibyte_chars_in_text (contents, nbytes);
else
nchars = nbytes;
}
val = make_uninit_multibyte_string (nchars, nbytes);
bcopy (contents, SDATA (val), nbytes);
if (!multibyte)
STRING_SET_UNIBYTE (val);
return val;
}
Lisp_Object
build_string (str)
const char *str;
{
return make_string (str, strlen (str));
}
Lisp_Object
make_uninit_string (length)
int length;
{
Lisp_Object val;
val = make_uninit_multibyte_string (length, length);
STRING_SET_UNIBYTE (val);
return val;
}
Lisp_Object
make_uninit_multibyte_string (nchars, nbytes)
int nchars, nbytes;
{
Lisp_Object string;
struct Lisp_String *s;
if (nchars < 0)
abort ();
s = allocate_string ();
allocate_string_data (s, nchars, nbytes);
XSETSTRING (string, s);
string_chars_consed += nbytes;
return string;
}
#define FLOAT_BLOCK_SIZE \
(((BLOCK_BYTES - sizeof (struct float_block *) \
\
- (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
/ (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
#define GETMARKBIT(block,n) \
(((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
>> ((n) % (sizeof(int) * CHAR_BIT))) \
& 1)
#define SETMARKBIT(block,n) \
(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)))
#define FLOAT_BLOCK(fptr) \
((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
#define FLOAT_INDEX(fptr) \
((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
struct float_block
{
struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
struct float_block *next;
};
#define FLOAT_MARKED_P(fptr) \
GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
#define FLOAT_MARK(fptr) \
SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
#define FLOAT_UNMARK(fptr) \
UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
struct float_block *float_block;
int float_block_index;
int n_float_blocks;
struct Lisp_Float *float_free_list;
void
init_float ()
{
float_block = NULL;
float_block_index = FLOAT_BLOCK_SIZE;
float_free_list = 0;
n_float_blocks = 0;
}
void
free_float (ptr)
struct Lisp_Float *ptr;
{
ptr->u.chain = float_free_list;
float_free_list = ptr;
}
Lisp_Object
make_float (float_value)
double float_value;
{
register Lisp_Object val;
#ifndef SYNC_INPUT
BLOCK_INPUT;
#endif
if (float_free_list)
{
XSETFLOAT (val, float_free_list);
float_free_list = float_free_list->u.chain;
}
else
{
if (float_block_index == FLOAT_BLOCK_SIZE)
{
register struct float_block *new;
new = (struct float_block *) lisp_align_malloc (sizeof *new,
MEM_TYPE_FLOAT);
new->next = float_block;
bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
float_block = new;
float_block_index = 0;
n_float_blocks++;
}
XSETFLOAT (val, &float_block->floats[float_block_index]);
float_block_index++;
}
#ifndef SYNC_INPUT
UNBLOCK_INPUT;
#endif
XFLOAT_DATA (val) = float_value;
eassert (!FLOAT_MARKED_P (XFLOAT (val)));
consing_since_gc += sizeof (struct Lisp_Float);
floats_consed++;
return val;
}
#define CONS_BLOCK_SIZE \
(((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
/ (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
#define CONS_BLOCK(fptr) \
((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
#define CONS_INDEX(fptr) \
((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
struct cons_block
{
struct Lisp_Cons conses[CONS_BLOCK_SIZE];
int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
struct cons_block *next;
};
#define CONS_MARKED_P(fptr) \
GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
#define CONS_MARK(fptr) \
SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
#define CONS_UNMARK(fptr) \
UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
struct cons_block *cons_block;
int cons_block_index;
struct Lisp_Cons *cons_free_list;
int n_cons_blocks;
void
init_cons ()
{
cons_block = NULL;
cons_block_index = CONS_BLOCK_SIZE;
cons_free_list = 0;
n_cons_blocks = 0;
}
void
free_cons (ptr)
struct Lisp_Cons *ptr;
{
ptr->u.chain = cons_free_list;
#if GC_MARK_STACK
ptr->car = Vdead;
#endif
cons_free_list = ptr;
}
DEFUN ("cons", Fcons, Scons, 2, 2, 0,
doc: )
(car, cdr)
Lisp_Object car, cdr;
{
register Lisp_Object val;
#ifndef SYNC_INPUT
BLOCK_INPUT;
#endif
if (cons_free_list)
{
XSETCONS (val, cons_free_list);
cons_free_list = cons_free_list->u.chain;
}
else
{
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);
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++;
}
#ifndef SYNC_INPUT
UNBLOCK_INPUT;
#endif
XSETCAR (val, car);
XSETCDR (val, cdr);
eassert (!CONS_MARKED_P (XCONS (val)));
consing_since_gc += sizeof (struct Lisp_Cons);
cons_cells_consed++;
return val;
}
void
check_cons_list ()
{
#ifdef GC_CHECK_CONS_LIST
struct Lisp_Cons *tail = cons_free_list;
while (tail)
tail = tail->u.chain;
#endif
}
Lisp_Object
list1 (arg1)
Lisp_Object arg1;
{
return Fcons (arg1, Qnil);
}
Lisp_Object
list2 (arg1, arg2)
Lisp_Object arg1, arg2;
{
return Fcons (arg1, Fcons (arg2, Qnil));
}
Lisp_Object
list3 (arg1, arg2, arg3)
Lisp_Object arg1, arg2, arg3;
{
return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
}
Lisp_Object
list4 (arg1, arg2, arg3, arg4)
Lisp_Object arg1, arg2, arg3, 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;
{
return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
Fcons (arg5, Qnil)))));
}
DEFUN ("list", Flist, Slist, 0, MANY, 0,
doc: )
(nargs, args)
int nargs;
register Lisp_Object *args;
{
register Lisp_Object val;
val = Qnil;
while (nargs > 0)
{
nargs--;
val = Fcons (args[nargs], val);
}
return val;
}
DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
doc: )
(length, init)
register Lisp_Object length, init;
{
register Lisp_Object val;
register int size;
CHECK_NATNUM (length);
size = XFASTINT (length);
val = Qnil;
while (size > 0)
{
val = Fcons (init, val);
--size;
if (size > 0)
{
val = Fcons (init, val);
--size;
if (size > 0)
{
val = Fcons (init, val);
--size;
if (size > 0)
{
val = Fcons (init, val);
--size;
if (size > 0)
{
val = Fcons (init, val);
--size;
}
}
}
}
QUIT;
}
return val;
}
struct Lisp_Vector *all_vectors;
int n_vectors;
static struct Lisp_Vector *
allocate_vectorlike (len, type)
EMACS_INT len;
enum mem_type type;
{
struct Lisp_Vector *p;
size_t nbytes;
#ifdef DOUG_LEA_MALLOC
BLOCK_INPUT;
mallopt (M_MMAP_MAX, 0);
UNBLOCK_INPUT;
#endif
nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);
#ifdef DOUG_LEA_MALLOC
BLOCK_INPUT;
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
UNBLOCK_INPUT;
#endif
consing_since_gc += nbytes;
vector_cells_consed += len;
#ifndef SYNC_INPUT
BLOCK_INPUT;
#endif
p->next = all_vectors;
all_vectors = p;
#ifndef SYNC_INPUT
UNBLOCK_INPUT;
#endif
++n_vectors;
return p;
}
struct Lisp_Vector *
allocate_vector (nslots)
EMACS_INT nslots;
{
struct Lisp_Vector *v = allocate_vectorlike (nslots, MEM_TYPE_VECTOR);
v->size = nslots;
return v;
}
struct Lisp_Hash_Table *
allocate_hash_table ()
{
EMACS_INT len = VECSIZE (struct Lisp_Hash_Table);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE);
EMACS_INT i;
v->size = len;
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
return (struct Lisp_Hash_Table *) v;
}
struct window *
allocate_window ()
{
EMACS_INT len = VECSIZE (struct window);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW);
EMACS_INT i;
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
v->size = len;
return (struct window *) v;
}
struct frame *
allocate_frame ()
{
EMACS_INT len = VECSIZE (struct frame);
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME);
EMACS_INT i;
for (i = 0; i < len; ++i)
v->contents[i] = make_number (0);
v->size = len;
return (struct frame *) v;
}
struct Lisp_Process *
allocate_process ()
{
EMACS_INT memlen = VECSIZE (struct Lisp_Process);
EMACS_INT lisplen = PSEUDOVECSIZE (struct Lisp_Process, pid);
struct Lisp_Vector *v = allocate_vectorlike (memlen, MEM_TYPE_PROCESS);
EMACS_INT i;
for (i = 0; i < lisplen; ++i)
v->contents[i] = Qnil;
v->size = lisplen;
return (struct Lisp_Process *) v;
}
struct Lisp_Vector *
allocate_other_vector (len)
EMACS_INT len;
{
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR);
EMACS_INT i;
for (i = 0; i < len; ++i)
v->contents[i] = Qnil;
v->size = len;
return v;
}
DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
doc: )
(length, init)
register Lisp_Object length, init;
{
Lisp_Object vector;
register EMACS_INT sizei;
register int index;
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;
XSETVECTOR (vector, p);
return vector;
}
DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
doc: )
(purpose, init)
register Lisp_Object purpose, init;
{
Lisp_Object vector;
Lisp_Object n;
CHECK_SYMBOL (purpose);
n = Fget (purpose, Qchar_table_extra_slots);
CHECK_NUMBER (n);
if (XINT (n) < 0 || XINT (n) > 10)
args_out_of_range (n, Qnil);
vector = Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS + XINT (n)),
init);
XCHAR_TABLE (vector)->top = Qt;
XCHAR_TABLE (vector)->parent = Qnil;
XCHAR_TABLE (vector)->purpose = purpose;
XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
return vector;
}
Lisp_Object
make_sub_char_table (init)
Lisp_Object init;
{
Lisp_Object vector
= Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), init);
XCHAR_TABLE (vector)->top = Qnil;
XCHAR_TABLE (vector)->defalt = Qnil;
XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
return vector;
}
DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
doc: )
(nargs, args)
register int nargs;
Lisp_Object *args;
{
register Lisp_Object len, val;
register int index;
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];
return val;
}
DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
doc: )
(nargs, args)
register int nargs;
Lisp_Object *args;
{
register Lisp_Object len, val;
register int index;
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);
if (STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
args[1] = Fstring_as_unibyte (args[1]);
p = XVECTOR (val);
for (index = 0; index < nargs; index++)
{
if (!NILP (Vpurify_flag))
args[index] = Fpurecopy (args[index]);
p->contents[index] = args[index];
}
XSETCOMPILED (val, p);
return val;
}
#define SYMBOL_BLOCK_SIZE \
((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
struct symbol_block
{
struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
struct symbol_block *next;
};
struct symbol_block *symbol_block;
int symbol_block_index;
struct Lisp_Symbol *symbol_free_list;
int n_symbol_blocks;
void
init_symbol ()
{
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: )
(name)
Lisp_Object name;
{
register Lisp_Object val;
register struct Lisp_Symbol *p;
CHECK_STRING (name);
#ifndef SYNC_INPUT
BLOCK_INPUT;
#endif
if (symbol_free_list)
{
XSETSYMBOL (val, symbol_free_list);
symbol_free_list = symbol_free_list->next;
}
else
{
if (symbol_block_index == SYMBOL_BLOCK_SIZE)
{
struct symbol_block *new;
new = (struct symbol_block *) 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]);
symbol_block_index++;
}
#ifndef SYNC_INPUT
UNBLOCK_INPUT;
#endif
p = XSYMBOL (val);
p->xname = name;
p->plist = Qnil;
p->value = Qunbound;
p->function = Qunbound;
p->next = NULL;
p->gcmarkbit = 0;
p->interned = SYMBOL_UNINTERNED;
p->constant = 0;
p->indirect_variable = 0;
consing_since_gc += sizeof (struct Lisp_Symbol);
symbols_consed++;
return val;
}
#define MARKER_BLOCK_SIZE \
((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
struct marker_block
{
union Lisp_Misc markers[MARKER_BLOCK_SIZE];
struct marker_block *next;
};
struct marker_block *marker_block;
int marker_block_index;
union Lisp_Misc *marker_free_list;
int n_marker_blocks;
void
init_marker ()
{
marker_block = NULL;
marker_block_index = MARKER_BLOCK_SIZE;
marker_free_list = 0;
n_marker_blocks = 0;
}
Lisp_Object
allocate_misc ()
{
Lisp_Object val;
#ifndef SYNC_INPUT
BLOCK_INPUT;
#endif
if (marker_free_list)
{
XSETMISC (val, marker_free_list);
marker_free_list = marker_free_list->u_free.chain;
}
else
{
if (marker_block_index == MARKER_BLOCK_SIZE)
{
struct marker_block *new;
new = (struct marker_block *) 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]);
marker_block_index++;
}
#ifndef SYNC_INPUT
UNBLOCK_INPUT;
#endif
--total_free_markers;
consing_since_gc += sizeof (union Lisp_Misc);
misc_objects_consed++;
XMARKER (val)->gcmarkbit = 0;
return val;
}
void
free_misc (misc)
Lisp_Object misc;
{
XMISC (misc)->u_marker.type = Lisp_Misc_Free;
XMISC (misc)->u_free.chain = marker_free_list;
marker_free_list = XMISC (misc);
total_free_markers++;
}
Lisp_Object
make_save_value (pointer, integer)
void *pointer;
int integer;
{
register Lisp_Object val;
register struct Lisp_Save_Value *p;
val = allocate_misc ();
XMISCTYPE (val) = Lisp_Misc_Save_Value;
p = XSAVE_VALUE (val);
p->pointer = pointer;
p->integer = integer;
p->dogc = 0;
return val;
}
DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
doc: )
()
{
register Lisp_Object val;
register struct Lisp_Marker *p;
val = allocate_misc ();
XMISCTYPE (val) = Lisp_Misc_Marker;
p = XMARKER (val);
p->buffer = 0;
p->bytepos = 0;
p->charpos = 0;
p->next = NULL;
p->insertion_type = 0;
return val;
}
void
free_marker (marker)
Lisp_Object marker;
{
unchain_marker (XMARKER (marker));
free_misc (marker);
}
Lisp_Object
make_event_array (nargs, args)
register int nargs;
Lisp_Object *args;
{
int i;
for (i = 0; i < nargs; i++)
if (!INTEGERP (args[i])
|| (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
return Fvector (nargs, args);
{
Lisp_Object result;
result = Fmake_string (make_number (nargs), make_number (0));
for (i = 0; i < nargs; i++)
{
SSET (result, i, XINT (args[i]));
if (XINT (args[i]) & CHAR_META)
SSET (result, i, SREF (result, i) | 0x80);
}
return result;
}
}
void
memory_full ()
{
int i;
Vmemory_full = Qt;
memory_full_cons_threshold = sizeof (struct cons_block);
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;
}
#ifndef SYSTEM_MALLOC
bytes_used_when_full = BYTES_USED;
#endif
xsignal (Qnil, Vmemory_signal_data);
}
void
refill_memory_reserve ()
{
#ifndef SYSTEM_MALLOC
if (spare_memory[0] == 0)
spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
if (spare_memory[1] == 0)
spare_memory[1] = (char *) 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);
if (spare_memory[3] == 0)
spare_memory[3] = (char *) 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);
if (spare_memory[5] == 0)
spare_memory[5] = (char *) 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);
if (spare_memory[0] && spare_memory[1] && spare_memory[5])
Vmemory_full = Qnil;
#endif
}
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
static void
mem_init ()
{
mem_z.left = mem_z.right = MEM_NIL;
mem_z.parent = NULL;
mem_z.color = MEM_BLACK;
mem_z.start = mem_z.end = NULL;
mem_root = MEM_NIL;
}
static INLINE struct mem_node *
mem_find (start)
void *start;
{
struct mem_node *p;
if (start < min_heap_address || start > max_heap_address)
return MEM_NIL;
mem_z.start = start;
mem_z.end = (char *) start + 1;
p = mem_root;
while (start < p->start || start >= p->end)
p = start < p->start ? p->left : p->right;
return p;
}
static struct mem_node *
mem_insert (start, end, type)
void *start, *end;
enum mem_type type;
{
struct mem_node *c, *parent, *x;
if (min_heap_address == NULL || start < min_heap_address)
min_heap_address = start;
if (max_heap_address == NULL || end > max_heap_address)
max_heap_address = end;
c = mem_root;
parent = NULL;
#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
while (c != MEM_NIL)
{
if (start >= c->start && start < c->end)
abort ();
parent = c;
c = start < c->start ? c->left : c->right;
}
#else
while (c != MEM_NIL)
{
parent = c;
c = start < c->start ? c->left : c->right;
}
#endif
#ifdef GC_MALLOC_CHECK
x = (struct mem_node *) _malloc_internal (sizeof *x);
if (x == NULL)
abort ();
#else
x = (struct mem_node *) xmalloc (sizeof *x);
#endif
x->start = start;
x->end = end;
x->type = type;
x->parent = parent;
x->left = x->right = MEM_NIL;
x->color = MEM_RED;
if (parent)
{
if (start < parent->start)
parent->left = x;
else
parent->right = x;
}
else
mem_root = x;
mem_insert_fixup (x);
return x;
}
static void
mem_insert_fixup (x)
struct mem_node *x;
{
while (x != mem_root && x->parent->color == MEM_RED)
{
if (x->parent == x->parent->parent->left)
{
struct mem_node *y = x->parent->parent->right;
if (y->color == MEM_RED)
{
x->parent->color = MEM_BLACK;
y->color = MEM_BLACK;
x->parent->parent->color = MEM_RED;
x = x->parent->parent;
}
else
{
if (x == x->parent->right)
{
x = x->parent;
mem_rotate_left (x);
}
x->parent->color = MEM_BLACK;
x->parent->parent->color = MEM_RED;
mem_rotate_right (x->parent->parent);
}
}
else
{
struct mem_node *y = x->parent->parent->left;
if (y->color == MEM_RED)
{
x->parent->color = MEM_BLACK;
y->color = MEM_BLACK;
x->parent->parent->color = MEM_RED;
x = x->parent->parent;
}
else
{
if (x == x->parent->left)
{
x = x->parent;
mem_rotate_right (x);
}
x->parent->color = MEM_BLACK;
x->parent->parent->color = MEM_RED;
mem_rotate_left (x->parent->parent);
}
}
}
mem_root->color = MEM_BLACK;
}
static void
mem_rotate_left (x)
struct mem_node *x;
{
struct mem_node *y;
y = x->right;
x->right = y->left;
if (y->left != MEM_NIL)
y->left->parent = x;
if (y != MEM_NIL)
y->parent = x->parent;
if (x->parent)
{
if (x == x->parent->left)
x->parent->left = y;
else
x->parent->right = y;
}
else
mem_root = y;
y->left = x;
if (x != MEM_NIL)
x->parent = y;
}
static void
mem_rotate_right (x)
struct mem_node *x;
{
struct mem_node *y = x->left;
x->left = y->right;
if (y->right != MEM_NIL)
y->right->parent = x;
if (y != MEM_NIL)
y->parent = x->parent;
if (x->parent)
{
if (x == x->parent->right)
x->parent->right = y;
else
x->parent->left = y;
}
else
mem_root = y;
y->right = x;
if (x != MEM_NIL)
x->parent = y;
}
static void
mem_delete (z)
struct mem_node *z;
{
struct mem_node *x, *y;
if (!z || z == MEM_NIL)
return;
if (z->left == MEM_NIL || z->right == MEM_NIL)
y = z;
else
{
y = z->right;
while (y->left != MEM_NIL)
y = y->left;
}
if (y->left != MEM_NIL)
x = y->left;
else
x = y->right;
x->parent = y->parent;
if (y->parent)
{
if (y == y->parent->left)
y->parent->left = x;
else
y->parent->right = x;
}
else
mem_root = x;
if (y != z)
{
z->start = y->start;
z->end = y->end;
z->type = y->type;
}
if (y->color == MEM_BLACK)
mem_delete_fixup (x);
#ifdef GC_MALLOC_CHECK
_free_internal (y);
#else
xfree (y);
#endif
}
static void
mem_delete_fixup (x)
struct mem_node *x;
{
while (x != mem_root && x->color == MEM_BLACK)
{
if (x == x->parent->left)
{
struct mem_node *w = x->parent->right;
if (w->color == MEM_RED)
{
w->color = MEM_BLACK;
x->parent->color = MEM_RED;
mem_rotate_left (x->parent);
w = x->parent->right;
}
if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
{
w->color = MEM_RED;
x = x->parent;
}
else
{
if (w->right->color == MEM_BLACK)
{
w->left->color = MEM_BLACK;
w->color = MEM_RED;
mem_rotate_right (w);
w = x->parent->right;
}
w->color = x->parent->color;
x->parent->color = MEM_BLACK;
w->right->color = MEM_BLACK;
mem_rotate_left (x->parent);
x = mem_root;
}
}
else
{
struct mem_node *w = x->parent->left;
if (w->color == MEM_RED)
{
w->color = MEM_BLACK;
x->parent->color = MEM_RED;
mem_rotate_right (x->parent);
w = x->parent->left;
}
if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
{
w->color = MEM_RED;
x = x->parent;
}
else
{
if (w->left->color == MEM_BLACK)
{
w->right->color = MEM_BLACK;
w->color = MEM_RED;
mem_rotate_left (w);
w = x->parent->left;
}
w->color = x->parent->color;
x->parent->color = MEM_BLACK;
w->left->color = MEM_BLACK;
mem_rotate_right (x->parent);
x = mem_root;
}
}
}
x->color = MEM_BLACK;
}
static INLINE int
live_string_p (m, 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];
return (offset >= 0
&& offset % sizeof b->strings[0] == 0
&& offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
&& ((struct Lisp_String *) p)->data != NULL);
}
else
return 0;
}
static INLINE int
live_cons_p (m, 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];
return (offset >= 0
&& offset % sizeof b->conses[0] == 0
&& offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
&& (b != cons_block
|| offset / sizeof b->conses[0] < cons_block_index)
&& !EQ (((struct Lisp_Cons *) p)->car, Vdead));
}
else
return 0;
}
static INLINE int
live_symbol_p (m, 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];
return (offset >= 0
&& offset % sizeof b->symbols[0] == 0
&& offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
&& (b != symbol_block
|| offset / sizeof b->symbols[0] < symbol_block_index)
&& !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
}
else
return 0;
}
static INLINE int
live_float_p (m, 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];
return (offset >= 0
&& offset % sizeof b->floats[0] == 0
&& offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
&& (b != float_block
|| offset / sizeof b->floats[0] < float_block_index));
}
else
return 0;
}
static INLINE int
live_misc_p (m, 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];
return (offset >= 0
&& offset % sizeof b->markers[0] == 0
&& offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
&& (b != marker_block
|| offset / sizeof b->markers[0] < marker_block_index)
&& ((union Lisp_Misc *) p)->u_marker.type != Lisp_Misc_Free);
}
else
return 0;
}
static INLINE int
live_vector_p (m, p)
struct mem_node *m;
void *p;
{
return (p == m->start
&& m->type >= MEM_TYPE_VECTOR
&& m->type <= MEM_TYPE_WINDOW);
}
static INLINE int
live_buffer_p (m, p)
struct mem_node *m;
void *p;
{
return (m->type == MEM_TYPE_BUFFER
&& p == m->start
&& !NILP (((struct buffer *) p)->name));
}
#endif
#if GC_MARK_STACK
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
#define MAX_ZOMBIES 10
static Lisp_Object zombies[MAX_ZOMBIES];
static int nzombies;
static int ngcs;
static double avg_zombies;
static int max_live, max_zombies;
static double avg_live;
DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
doc: )
()
{
Lisp_Object args[8], zombie_list = Qnil;
int i;
for (i = 0; i < nzombies; i++)
zombie_list = Fcons (zombies[i], zombie_list);
args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
args[1] = make_number (ngcs);
args[2] = make_float (avg_live);
args[3] = make_float (avg_zombies);
args[4] = make_float (avg_zombies / avg_live / 100);
args[5] = make_number (max_live);
args[6] = make_number (max_zombies);
args[7] = zombie_list;
return Fmessage (8, args);
}
#endif
static INLINE void
mark_maybe_object (obj)
Lisp_Object obj;
{
void *po = (void *) XPNTR (obj);
struct mem_node *m = mem_find (po);
if (m != MEM_NIL)
{
int mark_p = 0;
switch (XGCTYPE (obj))
{
case Lisp_String:
mark_p = (live_string_p (m, po)
&& !STRING_MARKED_P ((struct Lisp_String *) po));
break;
case Lisp_Cons:
mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
break;
case Lisp_Symbol:
mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
break;
case Lisp_Float:
mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
break;
case Lisp_Vectorlike:
if (live_vector_p (m, po))
mark_p = !GC_SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
else if (live_buffer_p (m, po))
mark_p = GC_BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
break;
case Lisp_Misc:
mark_p = (live_misc_p (m, po) && !XMARKER (obj)->gcmarkbit);
break;
case Lisp_Int:
case Lisp_Type_Limit:
break;
}
if (mark_p)
{
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
if (nzombies < MAX_ZOMBIES)
zombies[nzombies] = obj;
++nzombies;
#endif
mark_object (obj);
}
}
}
static INLINE void
mark_maybe_pointer (p)
void *p;
{
struct mem_node *m;
if ((EMACS_INT) p & 1)
return;
m = mem_find (p);
if (m != MEM_NIL)
{
Lisp_Object obj = Qnil;
switch (m->type)
{
case MEM_TYPE_NON_LISP:
break;
case MEM_TYPE_BUFFER:
if (live_buffer_p (m, p) && !VECTOR_MARKED_P((struct buffer *)p))
XSETVECTOR (obj, p);
break;
case MEM_TYPE_CONS:
if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
XSETCONS (obj, p);
break;
case MEM_TYPE_STRING:
if (live_string_p (m, p)
&& !STRING_MARKED_P ((struct Lisp_String *) p))
XSETSTRING (obj, p);
break;
case MEM_TYPE_MISC:
if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
XSETMISC (obj, p);
break;
case MEM_TYPE_SYMBOL:
if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
XSETSYMBOL (obj, p);
break;
case MEM_TYPE_FLOAT:
if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
XSETFLOAT (obj, p);
break;
case MEM_TYPE_VECTOR:
case MEM_TYPE_PROCESS:
case MEM_TYPE_HASH_TABLE:
case MEM_TYPE_FRAME:
case MEM_TYPE_WINDOW:
if (live_vector_p (m, p))
{
Lisp_Object tem;
XSETVECTOR (tem, p);
if (!GC_SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
obj = tem;
}
break;
default:
abort ();
}
if (!GC_NILP (obj))
mark_object (obj);
}
}
static void
mark_memory (start, end, offset)
void *start, *end;
int offset;
{
Lisp_Object *p;
void **pp;
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
nzombies = 0;
#endif
if (end < start)
{
void *tem = start;
start = end;
end = tem;
}
for (p = (Lisp_Object *) ((char *) start + offset); (void *) p < end; ++p)
mark_maybe_object (*p);
for (pp = (void **) ((char *) start + offset); (void *) pp < end; ++pp)
mark_maybe_pointer (*pp);
}
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
static int setjmp_tested_p, longjmps_done;
#define SETJMP_WILL_LIKELY_WORK "\
\n\
Emacs garbage collector has been changed to use conservative stack\n\
marking. Emacs has determined that the method it uses to do the\n\
marking will likely work on your system, but this isn't sure.\n\
\n\
If you are a system-programmer, or can get the help of a local wizard\n\
who is, please take a look at the function mark_stack in alloc.c, and\n\
verify that the methods used are appropriate for your system.\n\
\n\
Please mail the result to <emacs-devel@gnu.org>.\n\
"
#define SETJMP_WILL_NOT_WORK "\
\n\
Emacs garbage collector has been changed to use conservative stack\n\
marking. Emacs has determined that the default method it uses to do the\n\
marking will not work on your system. We will need a system-dependent\n\
solution for your system.\n\
\n\
Please take a look at the function mark_stack in alloc.c, and\n\
try to find a way to make it work on your system.\n\
\n\
Note that you may get false negatives, depending on the compiler.\n\
In particular, you need to use -O with GCC for this test.\n\
\n\
Please mail the result to <emacs-devel@gnu.org>.\n\
"
static void
test_setjmp ()
{
char buf[10];
register int x;
jmp_buf jbuf;
int result = 0;
sprintf (buf, "1");
x = strlen (buf);
x = 2 * x - 1;
setjmp (jbuf);
if (longjmps_done == 1)
{
if (x == 1)
fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
else
{
fprintf (stderr, SETJMP_WILL_NOT_WORK);
exit (1);
}
}
++longjmps_done;
x = 2;
if (longjmps_done == 1)
longjmp (jbuf, 1);
}
#endif
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
static void
check_gcpros ()
{
struct gcpro *p;
int i;
for (p = gcprolist; p; p = p->next)
for (i = 0; i < p->nvars; ++i)
if (!survives_gc_p (p->var[i]))
abort ();
}
#elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
static void
dump_zombies ()
{
int i;
fprintf (stderr, "\nZombies kept alive = %d:\n", nzombies);
for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
{
fprintf (stderr, " %d = ", i);
debug_print (zombies[i]);
}
}
#endif
static void
mark_stack ()
{
int i;
union aligned_jmpbuf {
Lisp_Object o;
jmp_buf j;
} j;
volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
void *end;
#ifdef sparc
asm ("ta 3");
#endif
#ifdef GC_SAVE_REGISTERS_ON_STACK
GC_SAVE_REGISTERS_ON_STACK (end);
#else
#ifndef GC_SETJMP_WORKS
if (!setjmp_tested_p)
{
setjmp_tested_p = 1;
test_setjmp ();
}
#endif
setjmp (j.j);
end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
#endif
#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);
#ifdef GC_MARK_SECONDARY_STACK
GC_MARK_SECONDARY_STACK ();
#endif
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
check_gcpros ();
#endif
}
#endif
int
valid_pointer_p (p)
void *p;
{
#ifdef WINDOWSNT
return w32_valid_pointer_p (p, 16);
#else
int fd;
if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0)
{
int valid = (emacs_write (fd, (char *)p, 16) == 16);
emacs_close (fd);
unlink ("__Valid__Lisp__Object__");
return valid;
}
return -1;
#endif
}
int
valid_lisp_object_p (obj)
Lisp_Object obj;
{
void *p;
#if GC_MARK_STACK
struct mem_node *m;
#endif
if (INTEGERP (obj))
return 1;
p = (void *) XPNTR (obj);
if (PURE_POINTER_P (p))
return 1;
#if !GC_MARK_STACK
return valid_pointer_p (p);
#else
m = mem_find (p);
if (m == MEM_NIL)
{
int valid = valid_pointer_p (p);
if (valid <= 0)
return valid;
if (SUBRP (obj))
return 1;
return 0;
}
switch (m->type)
{
case MEM_TYPE_NON_LISP:
return 0;
case MEM_TYPE_BUFFER:
return live_buffer_p (m, p);
case MEM_TYPE_CONS:
return live_cons_p (m, p);
case MEM_TYPE_STRING:
return live_string_p (m, p);
case MEM_TYPE_MISC:
return live_misc_p (m, p);
case MEM_TYPE_SYMBOL:
return live_symbol_p (m, p);
case MEM_TYPE_FLOAT:
return live_float_p (m, p);
case MEM_TYPE_VECTOR:
case MEM_TYPE_PROCESS:
case MEM_TYPE_HASH_TABLE:
case MEM_TYPE_FRAME:
case MEM_TYPE_WINDOW:
return live_vector_p (m, p);
default:
break;
}
return 0;
#endif
}
static POINTER_TYPE *
pure_alloc (size, type)
size_t size;
int type;
{
POINTER_TYPE *result;
#ifdef USE_LSB_TAG
size_t alignment = (1 << GCTYPEBITS);
#else
size_t alignment = sizeof (EMACS_INT);
if (type == Lisp_Float)
{
#if defined __GNUC__ && __GNUC__ >= 2
alignment = __alignof (struct Lisp_Float);
#else
alignment = sizeof (struct Lisp_Float);
#endif
}
#endif
again:
if (type >= 0)
{
result = ALIGN (purebeg + pure_bytes_used_lisp, alignment);
pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
}
else
{
pure_bytes_used_non_lisp += size;
result = purebeg + pure_size - pure_bytes_used_non_lisp;
}
pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
if (pure_bytes_used <= pure_size)
return result;
purebeg = (char *) xmalloc (10000);
pure_size = 10000;
pure_bytes_used_before_overflow += pure_bytes_used - size;
pure_bytes_used = 0;
pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
goto again;
}
void
check_pure_size ()
{
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));
}
static char *
find_string_data_in_pure (data, nbytes)
char *data;
int nbytes;
{
int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
unsigned char *p;
char *non_lisp_beg;
if (pure_bytes_used_non_lisp < nbytes + 1)
return NULL;
skip = nbytes + 1;
for (i = 0; i < 256; i++)
bm_skip[i] = skip;
p = (unsigned char *) data;
while (--skip > 0)
bm_skip[*p++] = skip;
last_char_skip = bm_skip['\0'];
non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
start_max = pure_bytes_used_non_lisp - (nbytes + 1);
infinity = pure_bytes_used_non_lisp + 1;
bm_skip['\0'] = infinity;
p = (unsigned char *) non_lisp_beg + nbytes;
start = 0;
do
{
do
{
start += bm_skip[*(p + start)];
}
while (start <= start_max);
if (start < infinity)
return NULL;
start -= infinity;
if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
return non_lisp_beg + start;
start += last_char_skip;
}
while (start <= start_max);
return NULL;
}
Lisp_Object
make_pure_string (data, nchars, nbytes, multibyte)
char *data;
int nchars, 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);
if (s->data == NULL)
{
s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
bcopy (data, s->data, nbytes);
s->data[nbytes] = '\0';
}
s->size = nchars;
s->size_byte = multibyte ? nbytes : -1;
s->intervals = NULL_INTERVAL;
XSETSTRING (string, s);
return string;
}
Lisp_Object
pure_cons (car, cdr)
Lisp_Object car, cdr;
{
register Lisp_Object new;
struct Lisp_Cons *p;
p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
XSETCONS (new, p);
XSETCAR (new, Fpurecopy (car));
XSETCDR (new, Fpurecopy (cdr));
return new;
}
Lisp_Object
make_pure_float (num)
double num;
{
register Lisp_Object new;
struct Lisp_Float *p;
p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
XSETFLOAT (new, p);
XFLOAT_DATA (new) = num;
return new;
}
Lisp_Object
make_pure_vector (len)
EMACS_INT len;
{
Lisp_Object new;
struct Lisp_Vector *p;
size_t size = sizeof *p + (len - 1) * sizeof (Lisp_Object);
p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
XSETVECTOR (new, p);
XVECTOR (new)->size = len;
return new;
}
DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
doc: )
(obj)
register Lisp_Object obj;
{
if (NILP (Vpurify_flag))
return obj;
if (PURE_POINTER_P (XPNTR (obj)))
return obj;
if (CONSP (obj))
return pure_cons (XCAR (obj), XCDR (obj));
else if (FLOATP (obj))
return make_pure_float (XFLOAT_DATA (obj));
else if (STRINGP (obj))
return make_pure_string (SDATA (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;
size = XVECTOR (obj)->size;
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]);
if (COMPILEDP (obj))
XSETCOMPILED (obj, vec);
else
XSETVECTOR (obj, vec);
return obj;
}
else if (MARKERP (obj))
error ("Attempt to copy a marker to pure storage");
return obj;
}
void
staticpro (varaddress)
Lisp_Object *varaddress;
{
staticvec[staticidx++] = varaddress;
if (staticidx >= NSTATICS)
abort ();
}
struct catchtag
{
Lisp_Object tag;
Lisp_Object val;
struct catchtag *next;
};
int
inhibit_garbage_collection ()
{
int count = SPECPDL_INDEX ();
int nbits = min (VALBITS, BITS_PER_INT);
specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));
return count;
}
DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
doc: )
()
{
register struct specbinding *bind;
struct catchtag *catch;
struct handler *handler;
char stack_top_variable;
register int i;
int message_p;
Lisp_Object total[8];
int count = SPECPDL_INDEX ();
EMACS_TIME t1, t2, t3;
if (abort_on_gc)
abort ();
if (pure_bytes_used_before_overflow)
return Qnil;
CHECK_CONS_LIST ();
{
register struct buffer *nextb = all_buffers;
while (nextb)
{
if (! NILP (nextb->name) && ! EQ (nextb->undo_list, Qt))
truncate_undo_list (nextb);
if (nextb->base_buffer == 0 && !NILP (nextb->name))
{
int size = min (2000, max (20, (nextb->text->z_byte / 10)));
if (nextb->text->gap_size > size)
{
struct buffer *save_current = current_buffer;
current_buffer = nextb;
make_gap (-(nextb->text->gap_size - size));
current_buffer = save_current;
}
}
nextb = nextb->next;
}
}
EMACS_GET_TIME (t1);
consing_since_gc = 0;
message_p = push_message ();
record_unwind_protect (pop_message_unwind, Qnil);
#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)
{
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 ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0)
bcopy (stack_bottom, stack_copy, i);
else
bcopy (&stack_top_variable, stack_copy, i);
}
}
}
#endif
if (garbage_collection_messages)
message1_nolog ("Garbage collecting...");
BLOCK_INPUT;
shrink_regexp_cache ();
gc_in_progress = 1;
for (i = 0; i < staticidx; i++)
mark_object (*staticvec[i]);
for (bind = specpdl; bind != specpdl_ptr; bind++)
{
mark_object (bind->symbol);
mark_object (bind->old_value);
}
mark_kboards ();
#ifdef USE_GTK
{
extern void xg_mark_data ();
xg_mark_data ();
}
#endif
#if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
|| GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
mark_stack ();
#else
{
register struct gcpro *tail;
for (tail = gcprolist; tail; tail = tail->next)
for (i = 0; i < tail->nvars; i++)
mark_object (tail->var[i]);
}
#endif
mark_byte_stack ();
for (catch = catchlist; catch; catch = catch->next)
{
mark_object (catch->tag);
mark_object (catch->val);
}
for (handler = handlerlist; handler; handler = handler->next)
{
mark_object (handler->handler);
mark_object (handler->var);
}
mark_backtrace ();
#ifdef HAVE_WINDOW_SYSTEM
mark_fringe_data ();
#endif
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
mark_stack ();
#endif
{
register struct buffer *nextb = all_buffers;
while (nextb)
{
if (! EQ (nextb->undo_list, Qt))
{
Lisp_Object tail, prev;
tail = nextb->undo_list;
prev = Qnil;
while (CONSP (tail))
{
if (GC_CONSP (XCAR (tail))
&& GC_MARKERP (XCAR (XCAR (tail)))
&& !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
{
if (NILP (prev))
nextb->undo_list = tail = XCDR (tail);
else
{
tail = XCDR (tail);
XSETCDR (prev, tail);
}
}
else
{
prev = tail;
tail = XCDR (tail);
}
}
}
mark_object (nextb->undo_list);
nextb = nextb->next;
}
}
gc_sweep ();
unmark_byte_stack ();
VECTOR_UNMARK (&buffer_defaults);
VECTOR_UNMARK (&buffer_local_symbols);
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
dump_zombies ();
#endif
UNBLOCK_INPUT;
CHECK_CONS_LIST ();
gc_in_progress = 0;
consing_since_gc = 0;
if (gc_cons_threshold < 10000)
gc_cons_threshold = 10000;
if (FLOATP (Vgc_cons_percentage))
{
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);
}
else
gc_relative_threshold = 0;
if (garbage_collection_messages)
{
if (message_p || minibuf_level > 0)
restore_message ();
else
message1_nolog ("Garbage collecting...done");
}
unbind_to (count, Qnil);
total[0] = Fcons (make_number (total_conses),
make_number (total_free_conses));
total[1] = Fcons (make_number (total_symbols),
make_number (total_free_symbols));
total[2] = Fcons (make_number (total_markers),
make_number (total_free_markers));
total[3] = make_number (total_string_size);
total[4] = make_number (total_vector_size);
total[5] = Fcons (make_number (total_floats),
make_number (total_free_floats));
total[6] = Fcons (make_number (total_intervals),
make_number (total_free_intervals));
total[7] = Fcons (make_number (total_strings),
make_number (total_free_strings));
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
{
double nlive = 0;
for (i = 0; i < 7; ++i)
if (CONSP (total[i]))
nlive += XFASTINT (XCAR (total[i]));
avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
max_live = max (nlive, max_live);
avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
max_zombies = max (nzombies, max_zombies);
++ngcs;
}
#endif
if (!NILP (Vpost_gc_hook))
{
int count = inhibit_garbage_collection ();
safe_run_hooks (Qpost_gc_hook);
unbind_to (count, Qnil);
}
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);
gcs_done++;
return Flist (sizeof total / sizeof *total, total);
}
static void
mark_glyph_matrix (matrix)
struct glyph_matrix *matrix;
{
struct glyph_row *row = matrix->rows;
struct glyph_row *end = row + matrix->nrows;
for (; row < end; ++row)
if (row->enabled_p)
{
int area;
for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
{
struct glyph *glyph = row->glyphs[area];
struct glyph *end_glyph = glyph + row->used[area];
for (; glyph < end_glyph; ++glyph)
if (GC_STRINGP (glyph->object)
&& !STRING_MARKED_P (XSTRING (glyph->object)))
mark_object (glyph->object);
}
}
}
static void
mark_face_cache (c)
struct face_cache *c;
{
if (c)
{
int i, j;
for (i = 0; i < c->used; ++i)
{
struct face *face = FACE_FROM_ID (c->f, i);
if (face)
{
for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
mark_object (face->lface[j]);
}
}
}
}
#ifdef HAVE_WINDOW_SYSTEM
static void
mark_image (img)
struct image *img;
{
mark_object (img->spec);
if (!NILP (img->data.lisp_val))
mark_object (img->data.lisp_val);
}
static void
mark_image_cache (f)
struct frame *f;
{
forall_images_in_image_cache (f, mark_image);
}
#endif
#define LAST_MARKED_SIZE 500
Lisp_Object last_marked[LAST_MARKED_SIZE];
int last_marked_index;
int mark_object_loop_halt;
void
mark_object (arg)
Lisp_Object arg;
{
register Lisp_Object obj = arg;
#ifdef GC_CHECK_MARKED_OBJECTS
void *po;
struct mem_node *m;
#endif
int cdr_count = 0;
loop:
if (PURE_POINTER_P (XPNTR (obj)))
return;
last_marked[last_marked_index++] = obj;
if (last_marked_index == LAST_MARKED_SIZE)
last_marked_index = 0;
#ifdef GC_CHECK_MARKED_OBJECTS
po = (void *) XPNTR (obj);
#define CHECK_ALLOCATED() \
do { \
m = mem_find (po); \
if (m == MEM_NIL) \
abort (); \
} while (0)
#define CHECK_LIVE(LIVEP) \
do { \
if (!LIVEP (m, po)) \
abort (); \
} while (0)
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
do { \
CHECK_ALLOCATED (); \
CHECK_LIVE (LIVEP); \
} while (0) \
#else
#define CHECK_ALLOCATED() (void) 0
#define CHECK_LIVE(LIVEP) (void) 0
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
#endif
switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
{
case Lisp_String:
{
register struct Lisp_String *ptr = XSTRING (obj);
CHECK_ALLOCATED_AND_LIVE (live_string_p);
MARK_INTERVAL_TREE (ptr->intervals);
MARK_STRING (ptr);
#ifdef GC_CHECK_STRING_BYTES
CHECK_STRING_BYTES (ptr);
#endif
}
break;
case Lisp_Vectorlike:
#ifdef GC_CHECK_MARKED_OBJECTS
m = mem_find (po);
if (m == MEM_NIL && !GC_SUBRP (obj)
&& po != &buffer_defaults
&& po != &buffer_local_symbols)
abort ();
#endif
if (GC_BUFFERP (obj))
{
if (!VECTOR_MARKED_P (XBUFFER (obj)))
{
#ifdef GC_CHECK_MARKED_OBJECTS
if (po != &buffer_defaults && po != &buffer_local_symbols)
{
struct buffer *b;
for (b = all_buffers; b && b != po; b = b->next)
;
if (b == NULL)
abort ();
}
#endif
mark_buffer (obj);
}
}
else if (GC_SUBRP (obj))
break;
else if (GC_COMPILEDP (obj))
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
register EMACS_INT size = ptr->size;
register int i;
if (VECTOR_MARKED_P (ptr))
break;
CHECK_LIVE (live_vector_p);
VECTOR_MARK (ptr);
size &= PSEUDOVECTOR_SIZE_MASK;
for (i = 0; i < size; i++)
{
if (i != COMPILED_CONSTANTS)
mark_object (ptr->contents[i]);
}
obj = ptr->contents[COMPILED_CONSTANTS];
goto loop;
}
else if (GC_FRAMEP (obj))
{
register struct frame *ptr = XFRAME (obj);
if (VECTOR_MARKED_P (ptr)) break;
VECTOR_MARK (ptr);
CHECK_LIVE (live_vector_p);
mark_object (ptr->name);
mark_object (ptr->icon_name);
mark_object (ptr->title);
mark_object (ptr->focus_frame);
mark_object (ptr->selected_window);
mark_object (ptr->minibuffer_window);
mark_object (ptr->param_alist);
mark_object (ptr->scroll_bars);
mark_object (ptr->condemned_scroll_bars);
mark_object (ptr->menu_bar_items);
mark_object (ptr->face_alist);
mark_object (ptr->menu_bar_vector);
mark_object (ptr->buffer_predicate);
mark_object (ptr->buffer_list);
mark_object (ptr->menu_bar_window);
mark_object (ptr->tool_bar_window);
mark_face_cache (ptr->face_cache);
#ifdef HAVE_WINDOW_SYSTEM
mark_image_cache (ptr);
mark_object (ptr->tool_bar_items);
mark_object (ptr->desired_tool_bar_string);
mark_object (ptr->current_tool_bar_string);
#endif
}
else if (GC_BOOL_VECTOR_P (obj))
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
if (VECTOR_MARKED_P (ptr))
break;
CHECK_LIVE (live_vector_p);
VECTOR_MARK (ptr);
}
else if (GC_WINDOWP (obj))
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
struct window *w = XWINDOW (obj);
register int i;
if (VECTOR_MARKED_P (ptr))
break;
CHECK_LIVE (live_vector_p);
VECTOR_MARK (ptr);
for (i = 0;
(char *) &ptr->contents[i] < (char *) &w->current_matrix;
i++)
mark_object (ptr->contents[i]);
if (NILP (w->hchild)
&& NILP (w->vchild)
&& w->current_matrix)
{
mark_glyph_matrix (w->current_matrix);
mark_glyph_matrix (w->desired_matrix);
}
}
else if (GC_HASH_TABLE_P (obj))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
if (VECTOR_MARKED_P (h))
break;
CHECK_LIVE (live_vector_p);
VECTOR_MARK (h);
mark_object (h->test);
mark_object (h->weak);
mark_object (h->rehash_size);
mark_object (h->rehash_threshold);
mark_object (h->hash);
mark_object (h->next);
mark_object (h->index);
mark_object (h->user_hash_function);
mark_object (h->user_cmp_function);
if (GC_NILP (h->weak))
mark_object (h->key_and_value);
else
VECTOR_MARK (XVECTOR (h->key_and_value));
}
else
{
register struct Lisp_Vector *ptr = XVECTOR (obj);
register EMACS_INT size = ptr->size;
register int i;
if (VECTOR_MARKED_P (ptr)) break;
CHECK_LIVE (live_vector_p);
VECTOR_MARK (ptr);
if (size & PSEUDOVECTOR_FLAG)
size &= PSEUDOVECTOR_SIZE_MASK;
for (i = 0; i < size; i++)
mark_object (ptr->contents[i]);
}
break;
case Lisp_Symbol:
{
register struct Lisp_Symbol *ptr = XSYMBOL (obj);
struct Lisp_Symbol *ptrx;
if (ptr->gcmarkbit) break;
CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
ptr->gcmarkbit = 1;
mark_object (ptr->value);
mark_object (ptr->function);
mark_object (ptr->plist);
if (!PURE_POINTER_P (XSTRING (ptr->xname)))
MARK_STRING (XSTRING (ptr->xname));
MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
ptr = ptr->next;
if (ptr)
{
ptrx = ptr;
XSETSYMBOL (obj, ptrx);
goto loop;
}
}
break;
case Lisp_Misc:
CHECK_ALLOCATED_AND_LIVE (live_misc_p);
if (XMARKER (obj)->gcmarkbit)
break;
XMARKER (obj)->gcmarkbit = 1;
switch (XMISCTYPE (obj))
{
case Lisp_Misc_Buffer_Local_Value:
case Lisp_Misc_Some_Buffer_Local_Value:
{
register struct Lisp_Buffer_Local_Value *ptr
= XBUFFER_LOCAL_VALUE (obj);
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:
break;
case Lisp_Misc_Intfwd:
case Lisp_Misc_Boolfwd:
case Lisp_Misc_Objfwd:
case Lisp_Misc_Buffer_Objfwd:
case Lisp_Misc_Kboard_Objfwd:
break;
case Lisp_Misc_Save_Value:
#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;
for (nelt = ptr->integer; nelt > 0; nelt--, p++)
mark_maybe_object (*p);
}
}
#endif
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;
}
}
break;
default:
abort ();
}
break;
case Lisp_Cons:
{
register struct Lisp_Cons *ptr = XCONS (obj);
if (CONS_MARKED_P (ptr)) break;
CHECK_ALLOCATED_AND_LIVE (live_cons_p);
CONS_MARK (ptr);
if (EQ (ptr->u.cdr, Qnil))
{
obj = ptr->car;
cdr_count = 0;
goto loop;
}
mark_object (ptr->car);
obj = ptr->u.cdr;
cdr_count++;
if (cdr_count == mark_object_loop_halt)
abort ();
goto loop;
}
case Lisp_Float:
CHECK_ALLOCATED_AND_LIVE (live_float_p);
FLOAT_MARK (XFLOAT (obj));
break;
case Lisp_Int:
break;
default:
abort ();
}
#undef CHECK_LIVE
#undef CHECK_ALLOCATED
#undef CHECK_ALLOCATED_AND_LIVE
}
static void
mark_buffer (buf)
Lisp_Object buf;
{
register struct buffer *buffer = XBUFFER (buf);
register Lisp_Object *ptr, tmp;
Lisp_Object base_buffer;
VECTOR_MARK (buffer);
MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
if (buffer->overlays_before)
{
XSETMISC (tmp, buffer->overlays_before);
mark_object (tmp);
}
if (buffer->overlays_after)
{
XSETMISC (tmp, buffer->overlays_after);
mark_object (tmp);
}
for (ptr = &buffer->name;
(char *)ptr < (char *)buffer + sizeof (struct buffer);
ptr++)
mark_object (*ptr);
if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
{
XSETBUFFER (base_buffer, buffer->base_buffer);
mark_buffer (base_buffer);
}
}
int
survives_gc_p (obj)
Lisp_Object obj;
{
int survives_p;
switch (XGCTYPE (obj))
{
case Lisp_Int:
survives_p = 1;
break;
case Lisp_Symbol:
survives_p = XSYMBOL (obj)->gcmarkbit;
break;
case Lisp_Misc:
survives_p = XMARKER (obj)->gcmarkbit;
break;
case Lisp_String:
survives_p = STRING_MARKED_P (XSTRING (obj));
break;
case Lisp_Vectorlike:
survives_p = GC_SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
break;
case Lisp_Cons:
survives_p = CONS_MARKED_P (XCONS (obj));
break;
case Lisp_Float:
survives_p = FLOAT_MARKED_P (XFLOAT (obj));
break;
default:
abort ();
}
return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
}
static void
gc_sweep ()
{
sweep_weak_hash_tables ();
sweep_strings ();
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive)
check_string_bytes (1);
#endif
{
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;
cons_free_list = 0;
for (cblk = cons_block; cblk; cblk = *cprev)
{
register int i;
int this_free = 0;
for (i = 0; i < lim; i++)
if (!CONS_MARKED_P (&cblk->conses[i]))
{
this_free++;
cblk->conses[i].u.chain = cons_free_list;
cons_free_list = &cblk->conses[i];
#if GC_MARK_STACK
cons_free_list->car = Vdead;
#endif
}
else
{
num_used++;
CONS_UNMARK (&cblk->conses[i]);
}
lim = CONS_BLOCK_SIZE;
if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
{
*cprev = cblk->next;
cons_free_list = cblk->conses[0].u.chain;
lisp_align_free (cblk);
n_cons_blocks--;
}
else
{
num_free += this_free;
cprev = &cblk->next;
}
}
total_conses = num_used;
total_free_conses = num_free;
}
{
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;
float_free_list = 0;
for (fblk = float_block; fblk; fblk = *fprev)
{
register int i;
int this_free = 0;
for (i = 0; i < lim; i++)
if (!FLOAT_MARKED_P (&fblk->floats[i]))
{
this_free++;
fblk->floats[i].u.chain = float_free_list;
float_free_list = &fblk->floats[i];
}
else
{
num_used++;
FLOAT_UNMARK (&fblk->floats[i]);
}
lim = FLOAT_BLOCK_SIZE;
if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
{
*fprev = fblk->next;
float_free_list = fblk->floats[0].u.chain;
lisp_align_free (fblk);
n_float_blocks--;
}
else
{
num_free += this_free;
fprev = &fblk->next;
}
}
total_floats = num_used;
total_free_floats = num_free;
}
{
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;
interval_free_list = 0;
for (iblk = interval_block; iblk; iblk = *iprev)
{
register int i;
int this_free = 0;
for (i = 0; i < lim; i++)
{
if (!iblk->intervals[i].gcmarkbit)
{
SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
interval_free_list = &iblk->intervals[i];
this_free++;
}
else
{
num_used++;
iblk->intervals[i].gcmarkbit = 0;
}
}
lim = INTERVAL_BLOCK_SIZE;
if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
{
*iprev = iblk->next;
interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
lisp_free (iblk);
n_interval_blocks--;
}
else
{
num_free += this_free;
iprev = &iblk->next;
}
}
total_intervals = num_used;
total_free_intervals = num_free;
}
{
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;
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;
for (; sym < end; ++sym)
{
int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
if (!sym->gcmarkbit && !pure_p)
{
sym->next = symbol_free_list;
symbol_free_list = sym;
#if GC_MARK_STACK
symbol_free_list->function = Vdead;
#endif
++this_free;
}
else
{
++num_used;
if (!pure_p)
UNMARK_STRING (XSTRING (sym->xname));
sym->gcmarkbit = 0;
}
}
lim = SYMBOL_BLOCK_SIZE;
if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
{
*sprev = sblk->next;
symbol_free_list = sblk->symbols[0].next;
lisp_free (sblk);
n_symbol_blocks--;
}
else
{
num_free += this_free;
sprev = &sblk->next;
}
}
total_symbols = num_used;
total_free_symbols = num_free;
}
{
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;
marker_free_list = 0;
for (mblk = marker_block; mblk; mblk = *mprev)
{
register int i;
int this_free = 0;
for (i = 0; i < lim; i++)
{
if (!mblk->markers[i].u_marker.gcmarkbit)
{
if (mblk->markers[i].u_marker.type == Lisp_Misc_Marker)
unchain_marker (&mblk->markers[i].u_marker);
mblk->markers[i].u_marker.type = Lisp_Misc_Free;
mblk->markers[i].u_free.chain = marker_free_list;
marker_free_list = &mblk->markers[i];
this_free++;
}
else
{
num_used++;
mblk->markers[i].u_marker.gcmarkbit = 0;
}
}
lim = MARKER_BLOCK_SIZE;
if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
{
*mprev = mblk->next;
marker_free_list = mblk->markers[0].u_free.chain;
lisp_free (mblk);
n_marker_blocks--;
}
else
{
num_free += this_free;
mprev = &mblk->next;
}
}
total_markers = num_used;
total_free_markers = num_free;
}
{
register struct buffer *buffer = all_buffers, *prev = 0, *next;
while (buffer)
if (!VECTOR_MARKED_P (buffer))
{
if (prev)
prev->next = buffer->next;
else
all_buffers = buffer->next;
next = buffer->next;
lisp_free (buffer);
buffer = next;
}
else
{
VECTOR_UNMARK (buffer);
UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
prev = buffer, buffer = buffer->next;
}
}
{
register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
total_vector_size = 0;
while (vector)
if (!VECTOR_MARKED_P (vector))
{
if (prev)
prev->next = vector->next;
else
all_vectors = vector->next;
next = vector->next;
lisp_free (vector);
n_vectors--;
vector = next;
}
else
{
VECTOR_UNMARK (vector);
if (vector->size & PSEUDOVECTOR_FLAG)
total_vector_size += (PSEUDOVECTOR_SIZE_MASK & vector->size);
else
total_vector_size += vector->size;
prev = vector, vector = vector->next;
}
}
#ifdef GC_CHECK_STRING_BYTES
if (!noninteractive)
check_string_bytes (1);
#endif
}
DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
doc: )
()
{
Lisp_Object end;
XSETINT (end, (EMACS_INT) sbrk (0) / 1024);
return end;
}
DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
doc: )
()
{
Lisp_Object consed[8];
consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed));
consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed));
consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed));
consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed));
consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed));
consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed));
consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed));
consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
return Flist (8, consed);
}
int suppress_checking;
void
die (msg, file, line)
const char *msg;
const char *file;
int line;
{
fprintf (stderr, "\r\nEmacs fatal error: %s:%d: %s\r\n",
file, line, msg);
abort ();
}
void
init_alloc_once ()
{
purebeg = PUREBEG;
pure_size = PURESIZE;
pure_bytes_used = 0;
pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
pure_bytes_used_before_overflow = 0;
free_ablock = NULL;
#if GC_MARK_STACK || defined GC_MALLOC_CHECK
mem_init ();
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);
mallopt (M_MMAP_THRESHOLD, 64*1024);
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif
init_strings ();
init_cons ();
init_symbol ();
init_marker ();
init_float ();
init_intervals ();
#ifdef REL_ALLOC
malloc_hysteresis = 32;
#else
malloc_hysteresis = 0;
#endif
refill_memory_reserve ();
ignore_warnings = 0;
gcprolist = 0;
byte_stack_list = 0;
staticidx = 0;
consing_since_gc = 0;
gc_cons_threshold = 100000 * sizeof (Lisp_Object);
gc_relative_threshold = 0;
#ifdef VIRT_ADDR_VARIES
malloc_sbrk_unused = 1<<22;
malloc_sbrk_used = 100000;
#endif
}
void
init_alloc ()
{
gcprolist = 0;
byte_stack_list = 0;
#if GC_MARK_STACK
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
setjmp_tested_p = longjmps_done = 0;
#endif
#endif
Vgc_elapsed = make_float (0.0);
gcs_done = 0;
}
void
syms_of_alloc ()
{
DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
doc: );
DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage,
doc: );
Vgc_cons_percentage = make_float (0.1);
DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
doc: );
DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
doc: );
DEFVAR_INT ("floats-consed", &floats_consed,
doc: );
DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
doc: );
DEFVAR_INT ("symbols-consed", &symbols_consed,
doc: );
DEFVAR_INT ("string-chars-consed", &string_chars_consed,
doc: );
DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
doc: );
DEFVAR_INT ("intervals-consed", &intervals_consed,
doc: );
DEFVAR_INT ("strings-consed", &strings_consed,
doc: );
DEFVAR_LISP ("purify-flag", &Vpurify_flag,
doc: );
DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
doc: );
garbage_collection_messages = 0;
DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook,
doc: );
Vpost_gc_hook = Qnil;
Qpost_gc_hook = intern ("post-gc-hook");
staticpro (&Qpost_gc_hook);
DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
doc: );
Vmemory_signal_data
= list2 (Qerror,
build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
DEFVAR_LISP ("memory-full", &Vmemory_full,
doc: );
Vmemory_full = Qnil;
staticpro (&Qgc_cons_threshold);
Qgc_cons_threshold = intern ("gc-cons-threshold");
staticpro (&Qchar_table_extra_slots);
Qchar_table_extra_slots = intern ("char-table-extra-slots");
DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
doc: );
DEFVAR_INT ("gcs-done", &gcs_done,
doc: );
defsubr (&Scons);
defsubr (&Slist);
defsubr (&Svector);
defsubr (&Smake_byte_code);
defsubr (&Smake_list);
defsubr (&Smake_vector);
defsubr (&Smake_char_table);
defsubr (&Smake_string);
defsubr (&Smake_bool_vector);
defsubr (&Smake_symbol);
defsubr (&Smake_marker);
defsubr (&Spurecopy);
defsubr (&Sgarbage_collect);
defsubr (&Smemory_limit);
defsubr (&Smemory_use_counts);
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
defsubr (&Sgc_status);
#endif
}