comparison src/alloc.c @ 89909:68c22ea6027c

Sync to HEAD

89908:ee1402f7b568

/* Storage allocation and gc for GNU Emacs Lisp interpreter.
   Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001, 2002, 2003
      Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify

#endif

/* Note that this declares bzero on OSF/1.  How dumb.  */

#include <signal.h>

/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
   memory.  Can do this only if using gmalloc.c.  */

#if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
#undef GC_MALLOC_CHECK
#endif

/* This file is part of the core Lisp implementation, and thus must
   deal with the real data structures.  If the Lisp implementation is
   replaced, this file likely will not be used.  */

#include "frame.h"
#include "blockinput.h"
#include "character.h"
#include "syssignal.h"
#include <setjmp.h>

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
extern POINTER_TYPE *sbrk ();

  allocated_mem_type = type;
#endif

  val = (void *) malloc (nbytes);

  /* If the memory just allocated cannot be addressed thru a Lisp
     object's pointer, and it needs to be,
     that's equivalent to running out of memory.  */
  if (val && type != MEM_TYPE_NON_LISP)
    {

	  lisp_malloc_loser = val;
	  free (val);
	  val = 0;
	}
    }

#if GC_MARK_STACK && !defined GC_MALLOC_CHECK
  if (val && type != MEM_TYPE_NON_LISP)
    mem_insert (val, (char *) val + nbytes, type);
#endif

	abase = err ? (base = NULL) : base;
      }
#else
      base = malloc (ABLOCKS_BYTES);
      abase = ALIGN (base, BLOCK_ALIGN);
#endif

      aligned = (base == abase);
      if (!aligned)
	((void**)abase)[-1] = base;

#ifdef DOUG_LEA_MALLOC
      /* Back to a reasonable maximum of mmap'ed areas.  */
      mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif

      /* If the memory just allocated cannot be addressed thru a Lisp
	 object's pointer, and it needs to be, that's equivalent to
	 running out of memory.  */
      if (type != MEM_TYPE_NON_LISP)
	{

	      free (base);
	      UNBLOCK_INPUT;
	      memory_full ();
	    }
	}

      /* Initialize the blocks and put them on the free list.
	 Is `base' was not properly aligned, we can't use the last block.  */
      for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
	{

/* Intervals are allocated in chunks in form of an interval_block
   structure.  */

struct interval_block
{
  struct interval_block *next;
  struct interval intervals[INTERVAL_BLOCK_SIZE];
};

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

/* Structure describing a block from which Lisp_String structures
   are allocated.  */

struct string_block
{
  struct string_block *next;
  struct Lisp_String strings[STRING_BLOCK_SIZE];
};

/* Head and tail of the list of sblock structures holding Lisp string
   data.  We always allocate from current_sblock.  The NEXT pointers
   in the sblock structures go from oldest_sblock to current_sblock.  */

/* We store float cells inside of float_blocks, allocating a new
   float_block with malloc whenever necessary.  Float cells reclaimed
   by GC are put on a free list to be reallocated before allocating
   any new float cells from the latest float_block.  */

#define FLOAT_BLOCK_SIZE \
  (((BLOCK_BYTES - sizeof (struct float_block *)) * 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)))		\

	  register struct float_block *new;

	  new = (struct float_block *) lisp_align_malloc (sizeof *new,
							  MEM_TYPE_FLOAT);
	  new->next = float_block;
	  float_block = new;
	  float_block_index = 0;
	  n_float_blocks++;
	}
      XSETFLOAT (val, &float_block->floats[float_block_index++]);
    }

  XFLOAT_DATA (val) = float_value;
  FLOAT_UNMARK (XFLOAT (val));
  consing_since_gc += sizeof (struct Lisp_Float);
  floats_consed++;
  return val;
}

      if (cons_block_index == CONS_BLOCK_SIZE)
	{
	  register struct cons_block *new;
	  new = (struct cons_block *) lisp_align_malloc (sizeof *new,
							 MEM_TYPE_CONS);
	  new->next = cons_block;
	  cons_block = new;
	  cons_block_index = 0;
	  n_cons_blocks++;
	}
      XSETCONS (val, &cons_block->conses[cons_block_index++]);
    }

  XSETCAR (val, car);
  XSETCDR (val, cdr);
  CONS_UNMARK (XCONS (val));
  consing_since_gc += sizeof (struct Lisp_Cons);
  cons_cells_consed++;
  return val;
}

#ifdef DOUG_LEA_MALLOC
  /* Prevent mmap'ing the chunk.  Lisp data may not be mmap'ed
     because mapped region contents are not preserved in
     a dumped Emacs.  */
  mallopt (M_MMAP_MAX, 0);
#endif

  nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
  p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);

#ifdef DOUG_LEA_MALLOC
  /* Back to a reasonable maximum of mmap'ed areas.  */
  mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif

  consing_since_gc += nbytes;
  vector_cells_consed += len;

#define SYMBOL_BLOCK_SIZE \
  ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))

struct symbol_block
{
  struct symbol_block *next;
  struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
};

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

	  new->next = symbol_block;
	  symbol_block = new;
	  symbol_block_index = 0;
	  n_symbol_blocks++;
	}
      XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]);
    }

  p = XSYMBOL (val);
  p->xname = name;
  p->plist = Qnil;

#define MARKER_BLOCK_SIZE \
  ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))

struct marker_block
{
  struct marker_block *next;
  union Lisp_Misc markers[MARKER_BLOCK_SIZE];
};

struct marker_block *marker_block;
int marker_block_index;

	  new->next = marker_block;
	  marker_block = new;
	  marker_block_index = 0;
	  n_marker_blocks++;
	}
      XSETMISC (val, &marker_block->markers[marker_block_index++]);
    }

  consing_since_gc += sizeof (union Lisp_Misc);
  misc_objects_consed++;
  XMARKER (val)->gcmarkbit = 0;

      /* P must point to the start of a Lisp_String structure, and it
	 must not be on the free-list.  */
      return (offset >= 0
	      && offset % sizeof b->strings[0] == 0
	      && ((struct Lisp_String *) p)->data != NULL);
    }
  else
    return 0;
}

      /* P must point to the start of a Lisp_Cons, not be
	 one of the unused cells in the current cons block,
	 and not be on the free-list.  */
      return (offset >= 0
	      && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
	      && offset % sizeof b->conses[0] == 0
	      && (b != cons_block
		  || offset / sizeof b->conses[0] < cons_block_index)
	      && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
    }
  else

      /* P must point to the start of a Lisp_Symbol, not be
	 one of the unused cells in the current symbol block,
	 and not be on the free-list.  */
      return (offset >= 0
	      && offset % sizeof b->symbols[0] == 0
	      && (b != symbol_block
		  || offset / sizeof b->symbols[0] < symbol_block_index)
	      && !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
    }
  else

      int offset = (char *) p - (char *) &b->floats[0];

      /* P must point to the start of a Lisp_Float and not be
	 one of the unused cells in the current float block.  */
      return (offset >= 0
	      && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
	      && offset % sizeof b->floats[0] == 0
	      && (b != float_block
		  || offset / sizeof b->floats[0] < float_block_index));
    }
  else
    return 0;

      /* P must point to the start of a Lisp_Misc, not be
	 one of the unused cells in the current misc block,
	 and not be on the free-list.  */
      return (offset >= 0
	      && offset % sizeof b->markers[0] == 0
	      && (b != marker_block
		  || offset / sizeof b->markers[0] < marker_block_index)
	      && ((union Lisp_Misc *) p)->u_marker.type != Lisp_Misc_Free);
    }
  else

pure_alloc (size, type)
     size_t size;
     int type;
{
  POINTER_TYPE *result;
  size_t alignment = sizeof (EMACS_INT);

  /* Give Lisp_Floats an extra alignment.  */
  if (type == Lisp_Float)
    {

      alignment = __alignof (struct Lisp_Float);
#else
      alignment = sizeof (struct Lisp_Float);
#endif
    }

 again:
  result = ALIGN (purebeg + pure_bytes_used, alignment);
  pure_bytes_used = ((char *)result - (char *)purebeg) + size;

			     SBYTES (obj),
			     STRING_MULTIBYTE (obj));
  else if (COMPILEDP (obj) || VECTORP (obj))
    {
      register struct Lisp_Vector *vec;
      register int i, size;

      size = XVECTOR (obj)->size;
      if (size & PSEUDOVECTOR_FLAG)
	size &= PSEUDOVECTOR_SIZE_MASK;
      vec = XVECTOR (make_pure_vector ((EMACS_INT) size));
      for (i = 0; i < size; i++)
	vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
      if (COMPILEDP (obj))
	XSETCOMPILED (obj, vec);
      else

#endif

  gc_sweep ();

  /* Clear the mark bits that we set in certain root slots.  */

#if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
     || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
  {
    register struct gcpro *tail;
  }
#endif

  unmark_byte_stack ();
  VECTOR_UNMARK (&buffer_defaults);
  VECTOR_UNMARK (&buffer_local_symbols);

89909:68c22ea6027c

/* Storage allocation and gc for GNU Emacs Lisp interpreter.
   Copyright (C) 1985,86,88,93,94,95,97,98,1999,2000,01,02,03,2004
      Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify

#endif

/* Note that this declares bzero on OSF/1.  How dumb.  */

#include <signal.h>

/* This file is part of the core Lisp implementation, and thus must
   deal with the real data structures.  If the Lisp implementation is
   replaced, this file likely will not be used.  */

#include "frame.h"
#include "blockinput.h"
#include "character.h"
#include "syssignal.h"
#include <setjmp.h>

/* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
   memory.  Can do this only if using gmalloc.c.  */

#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 ();

  allocated_mem_type = type;
#endif

  val = (void *) malloc (nbytes);

#ifndef USE_LSB_TAG
  /* If the memory just allocated cannot be addressed thru a Lisp
     object's pointer, and it needs to be,
     that's equivalent to running out of memory.  */
  if (val && type != MEM_TYPE_NON_LISP)
    {

	  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

	abase = err ? (base = NULL) : base;
      }
#else
      base = malloc (ABLOCKS_BYTES);
      abase = ALIGN (base, BLOCK_ALIGN);
      if (base == 0)
	{
	  UNBLOCK_INPUT;
	  memory_full ();
	}
#endif

      aligned = (base == abase);
      if (!aligned)
	((void**)abase)[-1] = base;

#ifdef DOUG_LEA_MALLOC
      /* Back to a reasonable maximum of mmap'ed areas.  */
      mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
#endif

#ifndef USE_LSB_TAG
      /* If the memory just allocated cannot be addressed thru a Lisp
	 object's pointer, and it needs to be, that's equivalent to
	 running out of memory.  */
      if (type != MEM_TYPE_NON_LISP)
	{

	      free (base);
	      UNBLOCK_INPUT;
	      memory_full ();
	    }
	}
#endif

      /* Initialize the blocks and put them on the free list.
	 Is `base' was not properly aligned, we can't use the last block.  */
      for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
	{

/* Intervals are allocated in chunks in form of an interval_block
   structure.  */

struct interval_block
{
  /* Place `intervals' first, to preserve alignment.  */
  struct interval intervals[INTERVAL_BLOCK_SIZE];
  struct interval_block *next;
};

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

/* Structure describing a block from which Lisp_String structures
   are allocated.  */

struct string_block
{
  /* Place `strings' first, to preserve alignment.  */
  struct Lisp_String strings[STRING_BLOCK_SIZE];
  struct string_block *next;
};

/* Head and tail of the list of sblock structures holding Lisp string
   data.  We always allocate from current_sblock.  The NEXT pointers
   in the sblock structures go from oldest_sblock to current_sblock.  */

/* We store float cells inside of float_blocks, allocating a new
   float_block with malloc whenever necessary.  Float cells reclaimed
   by GC are put on a free list to be reallocated before allocating
   any new float cells from the latest float_block.  */

#define FLOAT_BLOCK_SIZE					\
  (((BLOCK_BYTES - sizeof (struct float_block *)		\
     /* The compiler might add padding at the end.  */		\
     - (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)))		\

	  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++;
    }

  XFLOAT_DATA (val) = float_value;
  eassert (!FLOAT_MARKED_P (XFLOAT (val)));
  consing_since_gc += sizeof (struct Lisp_Float);
  floats_consed++;
  return val;
}

      if (cons_block_index == CONS_BLOCK_SIZE)
	{
	  register struct cons_block *new;
	  new = (struct cons_block *) lisp_align_malloc (sizeof *new,
							 MEM_TYPE_CONS);
	  bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
	  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++;
    }

  XSETCAR (val, car);
  XSETCDR (val, cdr);
  eassert (!CONS_MARKED_P (XCONS (val)));
  consing_since_gc += sizeof (struct Lisp_Cons);
  cons_cells_consed++;
  return val;
}

#ifdef DOUG_LEA_MALLOC
  /* Prevent mmap'ing the chunk.  Lisp data may not be mmap'ed
     because mapped region contents are not preserved in
     a dumped Emacs.  */
  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
  /* Back to a reasonable maximum of mmap'ed areas.  */
  BLOCK_INPUT;
  mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
  UNBLOCK_INPUT;
#endif

  consing_since_gc += nbytes;
  vector_cells_consed += len;

#define SYMBOL_BLOCK_SIZE \
  ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))

struct symbol_block
{
  /* Place `symbols' first, to preserve alignment.  */
  struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
  struct symbol_block *next;
};

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

	  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++;
    }

  p = XSYMBOL (val);
  p->xname = name;
  p->plist = Qnil;

#define MARKER_BLOCK_SIZE \
  ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))

struct marker_block
{
  /* 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;

	  new->next = marker_block;
	  marker_block = new;
	  marker_block_index = 0;
	  n_marker_blocks++;
	}
      XSETMISC (val, &marker_block->markers[marker_block_index]);
      marker_block_index++;
    }

  consing_since_gc += sizeof (union Lisp_Misc);
  misc_objects_consed++;
  XMARKER (val)->gcmarkbit = 0;

      /* P must point to the start of a Lisp_String structure, and it
	 must not be on the free-list.  */
      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;
}

      /* P must point to the start of a Lisp_Cons, not be
	 one of the unused cells in the current cons block,
	 and not be on the free-list.  */
      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

      /* P must point to the start of a Lisp_Symbol, not be
	 one of the unused cells in the current symbol block,
	 and not be on the free-list.  */
      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

      int offset = (char *) p - (char *) &b->floats[0];

      /* P must point to the start of a Lisp_Float and not be
	 one of the unused cells in the current float block.  */
      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;

      /* P must point to the start of a Lisp_Misc, not be
	 one of the unused cells in the current misc block,
	 and not be on the free-list.  */
      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

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

  /* Give Lisp_Floats an extra alignment.  */
  if (type == Lisp_Float)
    {

      alignment = __alignof (struct Lisp_Float);
#else
      alignment = sizeof (struct Lisp_Float);
#endif
    }
#endif

 again:
  result = ALIGN (purebeg + pure_bytes_used, alignment);
  pure_bytes_used = ((char *)result - (char *)purebeg) + size;

			     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

#endif

  gc_sweep ();

  /* Clear the mark bits that we set in certain root slots.  */

  unmark_byte_stack ();
  VECTOR_UNMARK (&buffer_defaults);
  VECTOR_UNMARK (&buffer_local_symbols);