comparison src/alloc.c @ 91073:4bc33ffdda1a

Merge from emacs--devo--0 Patches applied: * emacs--devo--0 (patch 902-908) - Update from CVS - Merge from emacs--rel--22 * emacs--rel--22 (patch 131-137) - Update from CVS - Merge from gnus--rel--5.10 * gnus--rel--5.10 (patch 261-262) - Update from CVS Revision: [e-mail]/emacs--unicode--0--patch-278

91072:74ab3ea909f9

/* Points to memory space allocated as "spare", to be freed if we run
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */

char *spare_memory[7];

/* Amount of spare memory to keep in large reserve block.  */

#define SPARE_MEMORY (1 << 14)

#define MAX_SAVE_STACK 16000
#endif

/* Buffer in which we save a copy of the C stack at each GC.  */

char *stack_copy;
int stack_copy_size;

/* Non-zero means ignore malloc warnings.  Set during initialization.
   Currently not used.  */

int ignore_warnings;

Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;

/* Hook run after GC has finished.  */

#endif

/* A unique object in pure space used to make some Lisp objects
   on free lists recognizable in O(1).  */

Lisp_Object Vdead;

#ifdef GC_MALLOC_CHECK

enum mem_type allocated_mem_type;
int dont_register_blocks;

#endif /* GC_MALLOC_CHECK */

/* A node in the red-black tree describing allocated memory containing
   Lisp data.  Each such block is recorded with its start and end

struct gcpro *gcprolist;

/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */

#define NSTATICS 0x600
Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};

/* Index of next unused slot in staticvec.  */

int staticidx = 0;

static POINTER_TYPE *pure_alloc P_ ((size_t, int));


/* Value is SZ rounded up to the next multiple of ALIGNMENT.

};

/* Current interval block.  Its `next' pointer points to older
   blocks.  */

struct interval_block *interval_block;

/* Index in interval_block above of the next unused interval
   structure.  */

static int interval_block_index;

INTERVAL interval_free_list;

/* Total number of interval blocks now in use.  */

int n_interval_blocks;


/* Initialize interval allocation.  */

static void

#define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)

/* Initialize string allocation.  Called from init_alloc_once.  */

void
init_strings ()
{
  total_strings = total_free_strings = total_string_size = 0;
  oldest_sblock = current_sblock = large_sblocks = NULL;
  string_blocks = 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)


/* Like GC_STRING_BYTES, but with debugging check.  */

  return nbytes;
}

/* Check validity of Lisp strings' string_bytes member in B.  */

void
check_sblock (b)
     struct sblock *b;
{
  struct sdata *from, *end, *from_end;

/* Check validity of Lisp strings' string_bytes member.  ALL_P
   non-zero means check all strings, otherwise check only most
   recently allocated strings.  Used for hunting a bug.  */

void
check_string_bytes (all_p)
     int all_p;
{
  if (all_p)
    {

struct Lisp_Float *float_free_list;


/* Initialize float allocation.  */

void
init_float ()
{
  float_block = NULL;
  float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block.   */
  float_free_list = 0;

}


/* Explicitly free a float cell by putting it on the free-list.  */

void
free_float (ptr)
     struct Lisp_Float *ptr;
{
  ptr->u.chain = float_free_list;
  float_free_list = ptr;

struct Lisp_Cons *cons_free_list;

/* Total number of cons blocks now in use.  */

int n_cons_blocks;


/* Initialize cons allocation.  */

void
init_cons ()
{
  cons_block = NULL;
  cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block.  */
  cons_free_list = 0;

			   Vector Allocation
 ***********************************************************************/

/* Singly-linked list of all vectors.  */

struct Lisp_Vector *all_vectors;

/* Total number of vector-like objects now in use.  */

int n_vectors;


/* Value is a pointer to a newly allocated Lisp_Vector structure
   with room for LEN Lisp_Objects.  */

};

/* Current symbol block and index of first unused Lisp_Symbol
   structure in it.  */

struct symbol_block *symbol_block;
int symbol_block_index;

/* List of free symbols.  */

struct Lisp_Symbol *symbol_free_list;

/* Total number of symbol blocks now in use.  */

int n_symbol_blocks;


/* Initialize symbol allocation.  */

void
init_symbol ()
{
  symbol_block = NULL;
  symbol_block_index = SYMBOL_BLOCK_SIZE;
  symbol_free_list = 0;

  /* Place `markers' first, to preserve alignment.  */
  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;

/* Total number of marker blocks now in use.  */

int n_marker_blocks;

void
init_marker ()
{
  marker_block = NULL;
  marker_block_index = MARKER_BLOCK_SIZE;
  marker_free_list = 0;

#endif /* GC_MARK_STACK != 0 */


/* Determine whether it is safe to access memory at address P.  */
int
valid_pointer_p (p)
     void *p;
{
#ifdef WINDOWSNT
  return w32_valid_pointer_p (p, 16);

}


/* Value is a float object with value NUM allocated from pure space.  */

Lisp_Object
make_pure_float (num)
     double num;
{
  register Lisp_Object new;
  struct Lisp_Float *p;

/* Mark reference to a Lisp_Object.
   If the object referred to has not been seen yet, recursively mark
   all the references contained in it.  */

#define LAST_MARKED_SIZE 500
Lisp_Object last_marked[LAST_MARKED_SIZE];
int last_marked_index;

/* For debugging--call abort when we cdr down this many
   links of a list, in mark_object.  In debugging,
   the call to abort will hit a breakpoint.
   Normally this is zero and the check never goes off.  */
int mark_object_loop_halt;

/* Return non-zero if the object was not yet marked.  */
static int
mark_vectorlike (ptr)
     struct Lisp_Vector *ptr;

  if (VECTOR_MARKED_P (ptr))
    return 0;			/* Already marked */
  VECTOR_MARK (ptr);		/* Else mark it */
  if (size & PSEUDOVECTOR_FLAG)
    size &= PSEUDOVECTOR_SIZE_MASK;
  
  /* Note that this size is not the memory-footprint size, but only
     the number of Lisp_Object fields that we should trace.
     The distinction is used e.g. by Lisp_Process which places extra
     non-Lisp_Object fields at the end of the structure.  */
  for (i = 0; i < size; i++) /* and then mark its elements */

  return Flist (8, consed);
}

int suppress_checking;
void
die (msg, file, line)
     const char *msg;
     const char *file;
     int line;

91073:4bc33ffdda1a

/* Points to memory space allocated as "spare", to be freed if we run
   out of memory.  We keep one large block, four cons-blocks, and
   two string blocks.  */

static char *spare_memory[7];

/* Amount of spare memory to keep in large reserve block.  */

#define SPARE_MEMORY (1 << 14)

#define MAX_SAVE_STACK 16000
#endif

/* Buffer in which we save a copy of the C stack at each GC.  */

static char *stack_copy;
static int stack_copy_size;

/* Non-zero means ignore malloc warnings.  Set during initialization.
   Currently not used.  */

static int ignore_warnings;

Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;

/* Hook run after GC has finished.  */

#endif

/* A unique object in pure space used to make some Lisp objects
   on free lists recognizable in O(1).  */

static Lisp_Object Vdead;

#ifdef GC_MALLOC_CHECK

enum mem_type allocated_mem_type;
static int dont_register_blocks;

#endif /* GC_MALLOC_CHECK */

/* A node in the red-black tree describing allocated memory containing
   Lisp data.  Each such block is recorded with its start and end

struct gcpro *gcprolist;

/* Addresses of staticpro'd variables.  Initialize it to a nonzero
   value; otherwise some compilers put it into BSS.  */

#define NSTATICS 1280
static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};

/* Index of next unused slot in staticvec.  */

static int staticidx = 0;

static POINTER_TYPE *pure_alloc P_ ((size_t, int));


/* Value is SZ rounded up to the next multiple of ALIGNMENT.

};

/* Current interval block.  Its `next' pointer points to older
   blocks.  */

static struct interval_block *interval_block;

/* Index in interval_block above of the next unused interval
   structure.  */

static int interval_block_index;

INTERVAL interval_free_list;

/* Total number of interval blocks now in use.  */

static int n_interval_blocks;


/* Initialize interval allocation.  */

static void

#define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)

/* Initialize string allocation.  Called from init_alloc_once.  */

static void
init_strings ()
{
  total_strings = total_free_strings = total_string_size = 0;
  oldest_sblock = current_sblock = large_sblocks = NULL;
  string_blocks = NULL;

#ifdef GC_CHECK_STRING_BYTES

static int check_string_bytes_count;

static void check_string_bytes P_ ((int));
static void check_sblock P_ ((struct sblock *));

#define CHECK_STRING_BYTES(S)	STRING_BYTES (S)


/* Like GC_STRING_BYTES, but with debugging check.  */

  return nbytes;
}

/* Check validity of Lisp strings' string_bytes member in B.  */

static void
check_sblock (b)
     struct sblock *b;
{
  struct sdata *from, *end, *from_end;

/* Check validity of Lisp strings' string_bytes member.  ALL_P
   non-zero means check all strings, otherwise check only most
   recently allocated strings.  Used for hunting a bug.  */

static void
check_string_bytes (all_p)
     int all_p;
{
  if (all_p)
    {

struct Lisp_Float *float_free_list;


/* Initialize float allocation.  */

static void
init_float ()
{
  float_block = NULL;
  float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block.   */
  float_free_list = 0;

}


/* Explicitly free a float cell by putting it on the free-list.  */

static void
free_float (ptr)
     struct Lisp_Float *ptr;
{
  ptr->u.chain = float_free_list;
  float_free_list = ptr;

struct Lisp_Cons *cons_free_list;

/* Total number of cons blocks now in use.  */

static int n_cons_blocks;


/* Initialize cons allocation.  */

static void
init_cons ()
{
  cons_block = NULL;
  cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block.  */
  cons_free_list = 0;

			   Vector Allocation
 ***********************************************************************/

/* Singly-linked list of all vectors.  */

static struct Lisp_Vector *all_vectors;

/* Total number of vector-like objects now in use.  */

static int n_vectors;


/* Value is a pointer to a newly allocated Lisp_Vector structure
   with room for LEN Lisp_Objects.  */

};

/* Current symbol block and index of first unused Lisp_Symbol
   structure in it.  */

static struct symbol_block *symbol_block;
static int symbol_block_index;

/* List of free symbols.  */

static struct Lisp_Symbol *symbol_free_list;

/* Total number of symbol blocks now in use.  */

static int n_symbol_blocks;


/* Initialize symbol allocation.  */

static void
init_symbol ()
{
  symbol_block = NULL;
  symbol_block_index = SYMBOL_BLOCK_SIZE;
  symbol_free_list = 0;

  /* Place `markers' first, to preserve alignment.  */
  union Lisp_Misc markers[MARKER_BLOCK_SIZE];
  struct marker_block *next;
};

static struct marker_block *marker_block;
static int marker_block_index;

static union Lisp_Misc *marker_free_list;

/* Total number of marker blocks now in use.  */

static int n_marker_blocks;

static void
init_marker ()
{
  marker_block = NULL;
  marker_block_index = MARKER_BLOCK_SIZE;
  marker_free_list = 0;

#endif /* GC_MARK_STACK != 0 */


/* Determine whether it is safe to access memory at address P.  */
static int
valid_pointer_p (p)
     void *p;
{
#ifdef WINDOWSNT
  return w32_valid_pointer_p (p, 16);

}


/* Value is a float object with value NUM allocated from pure space.  */

static Lisp_Object
make_pure_float (num)
     double num;
{
  register Lisp_Object new;
  struct Lisp_Float *p;

/* Mark reference to a Lisp_Object.
   If the object referred to has not been seen yet, recursively mark
   all the references contained in it.  */

#define LAST_MARKED_SIZE 500
static Lisp_Object last_marked[LAST_MARKED_SIZE];
int last_marked_index;

/* For debugging--call abort when we cdr down this many
   links of a list, in mark_object.  In debugging,
   the call to abort will hit a breakpoint.
   Normally this is zero and the check never goes off.  */
static int mark_object_loop_halt;

/* Return non-zero if the object was not yet marked.  */
static int
mark_vectorlike (ptr)
     struct Lisp_Vector *ptr;

  if (VECTOR_MARKED_P (ptr))
    return 0;			/* Already marked */
  VECTOR_MARK (ptr);		/* Else mark it */
  if (size & PSEUDOVECTOR_FLAG)
    size &= PSEUDOVECTOR_SIZE_MASK;

  /* Note that this size is not the memory-footprint size, but only
     the number of Lisp_Object fields that we should trace.
     The distinction is used e.g. by Lisp_Process which places extra
     non-Lisp_Object fields at the end of the structure.  */
  for (i = 0; i < size; i++) /* and then mark its elements */

  return Flist (8, consed);
}

int suppress_checking;

void
die (msg, file, line)
     const char *msg;
     const char *file;
     int line;