comparison src/alloc.c @ 83397:693e794b57bf

Merged from [e-mail]--gnu-2005 (patch 149-151, 629-641) Patches applied: * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-629 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-630 Merge from gnus--rel--5.10 * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-631 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-632 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-633 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-634 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-635 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-636 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-637 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-638 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-639 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-640 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-641 Update from CVS * [e-mail]--gnu-2005/gnus--rel--5.10--patch-149 Merge from emacs--cvs-trunk--0 * [e-mail]--gnu-2005/gnus--rel--5.10--patch-150 Update from CVS * [e-mail]--gnu-2005/gnus--rel--5.10--patch-151 Update from CVS git-archimport-id: [e-mail]--2004/emacs--multi-tty--0--patch-437

83396:201f610eb492

/* Value of _bytes_used, when spare_memory was freed.  */

static __malloc_size_t bytes_used_when_full;

/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

#define MARK_STRING(S)		((S)->size |= ARRAY_MARK_FLAG)
#define UNMARK_STRING(S)	((S)->size &= ~ARRAY_MARK_FLAG)

EMACS_INT gc_relative_threshold;

static Lisp_Object Vgc_cons_percentage;

/* Nonzero during GC.  */

int gc_in_progress;

/* Nonzero means abort if try to GC.

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;

/* Points to memory space allocated as "spare", to be freed if we run
   out of memory.  */

static char *spare_memory;

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

#define SPARE_MEMORY (1 << 14)

/* Number of extra blocks malloc should get when it needs more core.  */

  MEM_TYPE_PROCESS,
  MEM_TYPE_HASH_TABLE,
  MEM_TYPE_FRAME,
  MEM_TYPE_WINDOW
};

#if GC_MARK_STACK || defined GC_MALLOC_CHECK

#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
#include <stdio.h>		/* For fprintf.  */

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 /* GC_MARK_STACK || GC_MALLOC_CHECK */

  pending_malloc_warning = 0;
}


#ifdef DOUG_LEA_MALLOC
#  define BYTES_USED (mallinfo ().arena)
#else
#  define BYTES_USED _bytes_used
#endif


/* Called if malloc returns zero.  */

void
memory_full ()
{
  Vmemory_full = Qt;

#ifndef SYSTEM_MALLOC
  bytes_used_when_full = BYTES_USED;
#endif

  /* The first time we get here, free the spare memory.  */
  if (spare_memory)
    {
      free (spare_memory);
      spare_memory = 0;
    }

  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
  while (1)
    Fsignal (Qnil, Vmemory_signal_data);
}

DEFUN ("memory-full-p", Fmemory_full_p, Smemory_full_p, 0, 0, 0,
       doc: /* t if memory is nearly full, nil otherwise.  */)
  ()
{
  return (spare_memory ? Qnil : Qt);
}

/* If we released our reserve (due to running out of memory),
   and we have a fair amount free once again,
   try to set aside another reserve in case we run out once more.

   This is called when a relocatable block is freed in ralloc.c.  */

void
refill_memory_reserve ()
{
#ifndef SYSTEM_MALLOC
  if (spare_memory == 0)
    spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);
#endif
}

/* Called if we can't allocate relocatable space for a buffer.  */

void
buffer_memory_full ()

     malloc.  */

#ifndef REL_ALLOC
  memory_full ();
#endif

  Vmemory_full = Qt;

  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
  while (1)
    Fsignal (Qnil, Vmemory_signal_data);

     POINTER_TYPE *block;
{
  BLOCK_INPUT;
  free (block);
  UNBLOCK_INPUT;
}


/* Like strdup, but uses xmalloc.  */

static void
emacs_blocked_free (ptr, ptr2)
     void *ptr;
     const void *ptr2;
{
  BLOCK_INPUT_ALLOC;

#ifdef GC_MALLOC_CHECK
  if (ptr)
    {

  free (ptr);

  /* If we released our reserve (due to running out of memory),
     and we have a fair amount free once again,
     try to set aside another reserve in case we run out once more.  */
  if (spare_memory == 0
      /* Verify there is enough space that even with the malloc
	 hysteresis this call won't run out again.
	 The code here is correct as long as SPARE_MEMORY
	 is substantially larger than the block size malloc uses.  */
      && (bytes_used_when_full
	  > BYTES_USED + max (malloc_hysteresis, 4) * SPARE_MEMORY))
    spare_memory = (char *) malloc ((size_t) SPARE_MEMORY);

  __free_hook = emacs_blocked_free;
  UNBLOCK_INPUT_ALLOC;
}

    return result;
  }
}



/************************************************************************
			   C Stack Marking
 ************************************************************************/

  malloc_hysteresis = 32;
#else
  malloc_hysteresis = 0;
#endif

  spare_memory = (char *) malloc (SPARE_MEMORY);

  ignore_warnings = 0;
  gcprolist = 0;
  byte_stack_list = 0;
  staticidx = 0;

  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: /* Non-nil means we are handling a memory-full error.  */);
  Vmemory_full = Qnil;

  staticpro (&Qgc_cons_threshold);
  Qgc_cons_threshold = intern ("gc-cons-threshold");

	       doc: /* Accumulated time elapsed in garbage collections.
The time is in seconds as a floating point value.  */);
  DEFVAR_INT ("gcs-done", &gcs_done,
	      doc: /* Accumulated number of garbage collections done.  */);

  defsubr (&Smemory_full_p);
  defsubr (&Scons);
  defsubr (&Slist);
  defsubr (&Svector);
  defsubr (&Smake_byte_code);
  defsubr (&Smake_list);

83397:693e794b57bf

/* Value of _bytes_used, when spare_memory was freed.  */

static __malloc_size_t bytes_used_when_full;

static __malloc_size_t bytes_used_when_reconsidered;

/* Mark, unmark, query mark bit of a Lisp string.  S must be a pointer
   to a struct Lisp_String.  */

#define MARK_STRING(S)		((S)->size |= ARRAY_MARK_FLAG)
#define UNMARK_STRING(S)	((S)->size &= ~ARRAY_MARK_FLAG)

EMACS_INT gc_relative_threshold;

static Lisp_Object Vgc_cons_percentage;

/* Minimum number of bytes of consing since GC before next GC,
   when memory is full.  */

EMACS_INT memory_full_cons_threshold;

/* Nonzero during GC.  */

int gc_in_progress;

/* Nonzero means abort if try to GC.

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;

/* 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)

/* Number of extra blocks malloc should get when it needs more core.  */

  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>		/* For fprintf.  */

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 /* GC_MARK_STACK || GC_MALLOC_CHECK */

  pending_malloc_warning = 0;
}


#ifdef DOUG_LEA_MALLOC
#  define BYTES_USED (mallinfo ().uordblks)
#else
#  define BYTES_USED _bytes_used
#endif

/* Called if we can't allocate relocatable space for a buffer.  */

void
buffer_memory_full ()

     malloc.  */

#ifndef REL_ALLOC
  memory_full ();
#endif

  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
  while (1)
    Fsignal (Qnil, Vmemory_signal_data);

     POINTER_TYPE *block;
{
  BLOCK_INPUT;
  free (block);
  UNBLOCK_INPUT;
  /* We don't call refill_memory_reserve here
     because that duplicates doing so in emacs_blocked_free
     and the criterion should go there.  */
}


/* Like strdup, but uses xmalloc.  */

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)
    {

  free (ptr);

  /* If we released our reserve (due to running out of memory),
     and we have a fair amount free once again,
     try to set aside another reserve in case we run out once more.  */
  if (! NILP (Vmemory_full)
      /* Verify there is enough space that even with the malloc
	 hysteresis this call won't run out again.
	 The code here is correct as long as SPARE_MEMORY
	 is substantially larger than the block size malloc uses.  */
      && (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;
}

    return result;
  }
}



/************************************************************************
			   Memory Full Handling
 ************************************************************************/


/* Called if malloc returns zero.  */

void
memory_full ()
{
  int i;

  Vmemory_full = Qt;

  memory_full_cons_threshold = sizeof (struct cons_block);

  /* The first time we get here, free the spare memory.  */
  for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
    if (spare_memory[i])
      {
	if (i == 0)
	  free (spare_memory[i]);
	else if (i >= 1 && i <= 4)
	  lisp_align_free (spare_memory[i]);
	else
	  lisp_free (spare_memory[i]);
	spare_memory[i] = 0;
      }

  /* Record the space now used.  When it decreases substantially,
     we can refill the memory reserve.  */
#ifndef SYSTEM_MALLOC
  bytes_used_when_full = BYTES_USED;
#endif

  /* This used to call error, but if we've run out of memory, we could
     get infinite recursion trying to build the string.  */
  while (1)
    Fsignal (Qnil, Vmemory_signal_data);
}

/* If we released our reserve (due to running out of memory),
   and we have a fair amount free once again,
   try to set aside another reserve in case we run out once more.

   This is called when a relocatable block is freed in ralloc.c,
   and also directly from this file, in case we're not using ralloc.c.  */

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
}

/************************************************************************
			   C Stack Marking
 ************************************************************************/

  malloc_hysteresis = 32;
#else
  malloc_hysteresis = 0;
#endif

  refill_memory_reserve ();

  ignore_warnings = 0;
  gcprolist = 0;
  byte_stack_list = 0;
  staticidx = 0;

  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: /* Non-nil means Emacs cannot get much more Lisp memory.  */);
  Vmemory_full = Qnil;

  staticpro (&Qgc_cons_threshold);
  Qgc_cons_threshold = intern ("gc-cons-threshold");

	       doc: /* Accumulated time elapsed in garbage collections.
The time is in seconds as a floating point value.  */);
  DEFVAR_INT ("gcs-done", &gcs_done,
	      doc: /* Accumulated number of garbage collections done.  */);

  defsubr (&Scons);
  defsubr (&Slist);
  defsubr (&Svector);
  defsubr (&Smake_byte_code);
  defsubr (&Smake_list);