comparison src/alloc.c @ 9437:c7d7fb56b42d

(MARKER_BLOCK_SIZE, marker_block, marker_free_list): Now refers to the superset type, not just markers. (allocate_misc): New function, extracted from Fmake_marker. (Fpurecopy): Check the substructure. (clear_marks, mark_object, gc_sweep): Likewise.

9436:907353876b8b

  p->next = 0;
  consing_since_gc += sizeof (struct Lisp_Symbol);
  return val;
}

/* Allocation of markers.
   Works like allocation of conses. */

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

struct marker_block
  {
    struct marker_block *next;
    struct Lisp_Marker markers[MARKER_BLOCK_SIZE];
  };

struct marker_block *marker_block;
int marker_block_index;

struct Lisp_Marker *marker_free_list;

void
init_marker ()
{
  marker_block = (struct marker_block *) malloc (sizeof (struct marker_block));

  bzero (marker_block->markers, sizeof marker_block->markers);
  marker_block_index = 0;
  marker_free_list = 0;
}

DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
  "Return a newly allocated marker which does not point at any place.")
  ()
{
  register Lisp_Object val;
  register struct Lisp_Marker *p;

  if (marker_free_list)
    {
      XSETMARKER (val, marker_free_list);
      marker_free_list
	= (struct Lisp_Marker *) XFASTINT (marker_free_list->chain);
    }
  else
    {
      if (marker_block_index == MARKER_BLOCK_SIZE)
	{
	  struct marker_block *new = (struct marker_block *) xmalloc (sizeof (struct marker_block));
	  VALIDATE_LISP_STORAGE (new, sizeof *new);
	  new->next = marker_block;
	  marker_block = new;
	  marker_block_index = 0;
	}
      XSETMARKER (val, &marker_block->markers[marker_block_index++]);
    }
  p = XMARKER (val);
  p->buffer = 0;
  p->bufpos = 0;
  p->chain = Qnil;
  consing_since_gc += sizeof (struct Lisp_Marker);
  return val;
}

/* Allocation of strings */

  switch ((int) XTYPE (obj))
#else
  switch (XTYPE (obj))
#endif
    {
    case Lisp_Marker:
      error ("Attempt to copy a marker to pure storage");

    case Lisp_Cons:
      return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr);

#ifdef LISP_FLOAT_TYPE

  
    for (sblk = marker_block; sblk; sblk = sblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  XUNMARK (sblk->markers[i].chain);
	lim = MARKER_BLOCK_SIZE;
      }
  }
  /* Clear mark bits on all buffers */
  {

	    goto loop2;
	  }
      }
      break;

    case Lisp_Marker:
      XMARK (XMARKER (obj)->chain);
      /* DO NOT mark thru the marker's chain.
	 The buffer's markers chain does not preserve markers from gc;
	 instead, markers are removed from the chain when freed by gc.  */
      break;

    case Lisp_Cons:
    case Lisp_Buffer_Local_Value:
    case Lisp_Some_Buffer_Local_Value:

  
    for (mblk = marker_block; mblk; mblk = mblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  if (!XMARKBIT (mblk->markers[i].chain))
	    {
	      Lisp_Object tem;
	      tem1 = &mblk->markers[i];  /* tem1 avoids Sun compiler bug */
	      XSETMARKER (tem, tem1);
	      unchain_marker (tem);
	      XSETFASTINT (mblk->markers[i].chain, (EMACS_INT) marker_free_list);
	      marker_free_list = &mblk->markers[i];
	      num_free++;
	    }
	  else
	    {
	      num_used++;
	      XUNMARK (mblk->markers[i].chain);
	    }
	lim = MARKER_BLOCK_SIZE;
      }

    total_markers = num_used;

9437:c7d7fb56b42d

  p->next = 0;
  consing_since_gc += sizeof (struct Lisp_Symbol);
  return val;
}

/* Allocation of markers and other objects that share that structure.
   Works like allocation of conses. */

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

union Lisp_Misc *marker_free_list;

void
init_marker ()
{
  marker_block = (struct marker_block *) malloc (sizeof (struct marker_block));

  bzero (marker_block->markers, sizeof marker_block->markers);
  marker_block_index = 0;
  marker_free_list = 0;
}

/* Return a newly allocated Lisp_Misc object, with no substructure.  */
Lisp_Object
allocate_misc ()
{
  Lisp_Object val;

  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
	    = (struct marker_block *) xmalloc (sizeof (struct marker_block));
	  VALIDATE_LISP_STORAGE (new, sizeof *new);
	  new->next = marker_block;
	  marker_block = new;
	  marker_block_index = 0;
	}
      XSETMISC (val, &marker_block->markers[marker_block_index++]);
    }
  consing_since_gc += sizeof (union Lisp_Misc);
  return val;
}

DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
  "Return a newly allocated marker which does not point at any place.")
  ()
{
  register Lisp_Object val;
  register struct Lisp_Marker *p;

  val = allocate_misc ();
  XMISC (val)->type = Lisp_Misc_Marker;
  p = XMARKER (val);
  p->buffer = 0;
  p->bufpos = 0;
  p->chain = Qnil;
  return val;
}

/* Allocation of strings */

  switch ((int) XTYPE (obj))
#else
  switch (XTYPE (obj))
#endif
    {
    case Lisp_Misc:
      switch (XMISC (obj)->type)
	{
	case Lisp_Misc_Marker:
	  error ("Attempt to copy a marker to pure storage");

	default:
	  abort ();
	}

    case Lisp_Cons:
      return pure_cons (XCONS (obj)->car, XCONS (obj)->cdr);

#ifdef LISP_FLOAT_TYPE

  
    for (sblk = marker_block; sblk; sblk = sblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  if (sblk->markers[i].type == Lisp_Misc_Marker)
	    XUNMARK (sblk->markers[i].u_marker.chain);
	lim = MARKER_BLOCK_SIZE;
      }
  }
  /* Clear mark bits on all buffers */
  {

	    goto loop2;
	  }
      }
      break;

    case Lisp_Misc:
      switch (XMISC (obj)->type)
	{
	case Lisp_Misc_Marker:
	  XMARK (XMARKER (obj)->chain);
	  /* DO NOT mark thru the marker's chain.
	     The buffer's markers chain does not preserve markers from gc;
	     instead, markers are removed from the chain when freed by gc.  */
	  break;

	default:
	  abort ();
	}
      break;

    case Lisp_Cons:
    case Lisp_Buffer_Local_Value:
    case Lisp_Some_Buffer_Local_Value:

  
    for (mblk = marker_block; mblk; mblk = mblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  if (mblk->markers[i].type == Lisp_Misc_Marker)
	    {
	      if (!XMARKBIT (mblk->markers[i].u_marker.chain))
		{
		  Lisp_Object tem;
		  tem1 = &mblk->markers[i].u_marker;  /* tem1 avoids Sun compiler bug */
		  XSETMARKER (tem, tem1);
		  unchain_marker (tem);
		  /* We could leave the type alone, since nobody checks it,
		     but this might catch bugs faster.  */
		  mblk->markers[i].type = Lisp_Misc_Free;
		  mblk->markers[i].u_free.chain = marker_free_list;
		  marker_free_list = &mblk->markers[i];
		  num_free++;
		}
	      else
		{
		  num_used++;
		  XUNMARK (mblk->markers[i].u_marker.chain);
		}
	    }
	lim = MARKER_BLOCK_SIZE;
      }

    total_markers = num_used;