alloc.c

早期freebsd实现

	    if ((int)objptr & 1) abort ();
	    ptr->size = (int) objptr & ~MARKBIT;
	    if ((int) objptr & MARKBIT)
	      ptr->size ++;
	  }
      }
      break;

    case Lisp_Vector:
    case Lisp_Window:
    case Lisp_Process:
    case Lisp_Window_Configuration:
      {
	register struct Lisp_Vector *ptr = XVECTOR (obj);
	register int size = ptr->size;
	register int i;

	if (size & ARRAY_MARK_FLAG) break;   /* Already marked */
	ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
	for (i = 0; i < size; i++)     /* and then mark its elements */
	  mark_object (&ptr->contents[i]);
      }
      break;

#if 0
    case Lisp_Temp_Vector:
      {
	register struct Lisp_Vector *ptr = XVECTOR (obj);
	register int size = ptr->size;
	register int i;

	for (i = 0; i < size; i++)     /* and then mark its elements */
	  mark_object (&ptr->contents[i]);
      }
      break;
#endif 0

    case Lisp_Symbol:
      {
	register struct Lisp_Symbol *ptr = XSYMBOL (obj);
	struct Lisp_Symbol *ptrx;

	if (XMARKBIT (ptr->plist)) break;
	XMARK (ptr->plist);
	XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
	mark_object (&ptr->name);
	mark_object ((Lisp_Object *) &ptr->value);
	mark_object (&ptr->function);
	mark_object (&ptr->plist);
	ptr = ptr->next;
	if (ptr)
	  {
	    ptrx = ptr;		/* Use pf ptrx avoids compiler bug on Sun */
	    XSETSYMBOL (obj, ptrx);
	    goto loop;
	  }
      }
      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 they are freed by gc. */
      break;

    case Lisp_Cons:
    case Lisp_Buffer_Local_Value:
    case Lisp_Some_Buffer_Local_Value:
      {
	register struct Lisp_Cons *ptr = XCONS (obj);
	if (XMARKBIT (ptr->car)) break;
	XMARK (ptr->car);
	mark_object (&ptr->car);
	objptr = &ptr->cdr;
	obj = ptr->cdr;
	goto loop;
      }

    case Lisp_Buffer:
      if (!XMARKBIT (XBUFFER (obj)->name))
	mark_buffer (obj);
      break;

    case Lisp_Int:
    case Lisp_Void:
    case Lisp_Subr:
    case Lisp_Intfwd:
    case Lisp_Boolfwd:
    case Lisp_Objfwd:
    case Lisp_Buffer_Objfwd:
    case Lisp_Internal_Stream:
    /* Don't bother with Lisp_Buffer_Objfwd,
       since all markable slots in current buffer marked anyway.  */
    /* Don't need to do Lisp_Objfwd, since the places they point
       are protected with staticpro.  */
      break;

    default:
      abort ();
    }
}

/* Mark the pointers in a buffer structure.  */

static void
mark_buffer (buf)
     Lisp_Object buf;
{
  Lisp_Object tem;
  register struct buffer *buffer = XBUFFER (buf);
  register Lisp_Object *ptr;

  /* This is the buffer's markbit */
  mark_object (&buffer->name);
  XMARK (buffer->name);

  for (ptr = &buffer->name + 1;
       (char *)ptr < (char *)buffer + sizeof (struct buffer);
       ptr++)
    mark_object (ptr);
}

/* Find all structures not marked, and free them. */

static void
gc_sweep ()
{
  total_string_size = 0;
  compact_strings ();

  /* Put all unmarked conses on free list */
  {
    register struct cons_block *cblk;
    register int lim = cons_block_index;
    register int num_free = 0, num_used = 0;

    cons_free_list = 0;
  
    for (cblk = cons_block; cblk; cblk = cblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  if (!XMARKBIT (cblk->conses[i].car))
	    {
	      XFASTINT (cblk->conses[i].car) = (int) cons_free_list;
	      num_free++;
	      cons_free_list = &cblk->conses[i];
	    }
	  else
	    {
	      num_used++;
	      XUNMARK (cblk->conses[i].car);
	    }
	lim = CONS_BLOCK_SIZE;
      }
    total_conses = num_used;
    total_free_conses = num_free;
  }

  /* Put all unmarked symbols on free list */
  {
    register struct symbol_block *sblk;
    register int lim = symbol_block_index;
    register int num_free = 0, num_used = 0;

    symbol_free_list = 0;
  
    for (sblk = symbol_block; sblk; sblk = sblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  if (!XMARKBIT (sblk->symbols[i].plist))
	    {
	      XFASTINT (sblk->symbols[i].value) = (int) symbol_free_list;
	      symbol_free_list = &sblk->symbols[i];
	      num_free++;
	    }
	  else
	    {
	      num_used++;
	      sblk->symbols[i].name
		= XSTRING (*(Lisp_Object *) &sblk->symbols[i].name);
	      XUNMARK (sblk->symbols[i].plist);
	    }
	lim = SYMBOL_BLOCK_SIZE;
      }
    total_symbols = num_used;
    total_free_symbols = num_free;
  }

#ifndef standalone
  /* Put all unmarked markers on free list.
     Dechain each one first from the buffer it points into. */
  {
    register struct marker_block *mblk;
    struct Lisp_Marker *tem1;
    register int lim = marker_block_index;
    register int num_free = 0, num_used = 0;

    marker_free_list = 0;
  
    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 */
	      XSET (tem, Lisp_Marker, tem1);
	      if (tem1->buffer)
		unchain_marker (tem);
	      XFASTINT (mblk->markers[i].chain) = (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;
    total_free_markers = num_free;
  }

  /* Free all unmarked buffers */
  {
    register struct buffer *buffer = all_buffers, *prev = 0, *next;

    while (buffer)
      if (!XMARKBIT (buffer->name))
	{
	  if (prev)
	    prev->next = buffer->next;
	  else
	    all_buffers = buffer->next;
	  next = buffer->next;
	  free (buffer);
	  buffer = next;
	}
      else
	{
	  XUNMARK (buffer->name);
	  prev = buffer, buffer = buffer->next;
	}
  }

#endif standalone

  /* Free all unmarked vectors */
  {
    register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
    total_vector_size = 0;

    while (vector)
      if (!(vector->size & ARRAY_MARK_FLAG))
	{
	  if (prev)
	    prev->next = vector->next;
	  else
	    all_vectors = vector->next;
	  next = vector->next;
	  free (vector);
	  vector = next;
	}
      else
	{
	  vector->size &= ~ARRAY_MARK_FLAG;
	  total_vector_size += vector->size;
	  prev = vector, vector = vector->next;
	}
  }

  /* Free all "large strings" not marked with ARRAY_MARK_FLAG.  */
  {
    register struct string_block *sb = large_string_blocks, *prev = 0, *next;

    while (sb)
      if (!(((struct Lisp_String *)(&sb->chars[0]))->size & ARRAY_MARK_FLAG))
	{
	  if (prev)
	    prev->next = sb->next;
	  else
	    large_string_blocks = sb->next;
	  next = sb->next;
	  free (sb);
	  sb = next;
	}
      else
	{
	  ((struct Lisp_String *)(&sb->chars[0]))->size
	    &= ~ARRAY_MARK_FLAG & ~MARKBIT;
	  total_string_size += ((struct Lisp_String *)(&sb->chars[0]))->size;
	  prev = sb, sb = sb->next;
	}
  }
}

/* Compactify strings, relocate references to them, and
   free any string blocks that become empty.  */

static void
compact_strings ()
{
  /* String block of old strings we are scanning.  */
  register struct string_block *from_sb;
  /* A preceding string block (or maybe the same one)
     where we are copying the still-live strings to.  */
  register struct string_block *to_sb;
  int pos;
  int to_pos;

  to_sb = first_string_block;
  to_pos = 0;

  /* Scan each existing string block sequentially, string by string.  */
  for (from_sb = first_string_block; from_sb; from_sb = from_sb->next)
    {
      pos = 0;
      /* POS is the index of the next string in the block.  */
      while (pos < from_sb->pos)
	{
	  register struct Lisp_String *nextstr
	    = (struct Lisp_String *) &from_sb->chars[pos];

	  register struct Lisp_String *newaddr;
	  register int size = nextstr->size;

	  /* NEXTSTR is the old address of the next string.
	     Just skip it if it isn't marked.  */
	  if ((unsigned) size > STRING_BLOCK_SIZE)
	    {
	      /* It is marked, so its size field is really a chain of refs.
		 Find the end of the chain, where the actual size lives.  */
	      while ((unsigned) size > STRING_BLOCK_SIZE)
		{
		  if (size & 1) size ^= MARKBIT | 1;
		  size = *(int *)size & ~MARKBIT;
		}

	      total_string_size += size;

	      /* If it won't fit in TO_SB, close it out,
		 and move to the next sb.  Keep doing so until
		 TO_SB reaches a large enough, empty enough string block.
		 We know that TO_SB cannot advance past FROM_SB here
		 since FROM_SB is large enough to contain this string.
		 Any string blocks skipped here
		 will be patched out and freed later.  */
	      while (to_pos + STRING_FULLSIZE (size)
		     > max (to_sb->pos, STRING_BLOCK_SIZE))
		{
		  to_sb->pos = to_pos;
		  to_sb = to_sb->next;
		  to_pos = 0;
		}
	      /* Compute new address of this string
		 and update TO_POS for the space being used.  */
	      newaddr = (struct Lisp_String *) &to_sb->chars[to_pos];
	      to_pos += STRING_FULLSIZE (size);

	      /* Copy the string itself to the new place.  */
	      if (nextstr != newaddr)
		bcopy (nextstr, newaddr, size + 1 + sizeof (int));

	      /* Go through NEXTSTR's chain of references
		 and make each slot in the chain point to
		 the new address of this string.  */
	      size = newaddr->size;
	      while ((unsigned) size > STRING_BLOCK_SIZE)
		{
		  register Lisp_Object *objptr;
		  if (size & 1) size ^= MARKBIT | 1;
		  objptr = (Lisp_Object *)size;

		  size = XFASTINT (*objptr) & ~MARKBIT;
		  if (XMARKBIT (*objptr))
		    {
		      XSET (*objptr, Lisp_String, newaddr);
		      XMARK (*objptr);
		    }
		  else
		    XSET (*objptr, Lisp_String, newaddr);
		}
	      /* Store the actual size in the size field.  */
	      newaddr->size = size;
	    }
	  pos += STRING_FULLSIZE (size);
	}
    }

  /* Close out the last string block still used and free any that follow.  */
  to_sb->pos = to_pos;
  current_string_block = to_sb;

  from_sb = to_sb->next;
  to_sb->next = 0;
  while (from_sb)
    {
      to_sb = from_sb->next;
      free (from_sb);
      from_sb = to_sb;
    }

  /* Free any empty string blocks further back in the chain.
     This loop will never free first_string_block, but it is very
     unlikely that that one will become empty, so why bother checking?  */

  from_sb = first_string_block;
  while (to_sb = from_sb->next)
    {
      if (to_sb->pos == 0)
	{
	  if (from_sb->next = to_sb->next)
	    from_sb->next->prev = from_sb;
	  free (to_sb);
	}
      else
	from_sb = to_sb;
    }
}

truncate_all_undos ()
{
  register struct buffer *nextb = all_buffers;

  consing_at_last_truncate = consing_since_gc;

  while (nextb)
    {
      nextb->undo_list 
	= truncate_undo_list (nextb->undo_list, undo_threshold,
			      undo_high_threshold);
      nextb = nextb->next;
    }
}

/* Initialization */

init_alloc_once ()
{
  /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet!  */
  pureptr = 0;
  all_vectors = 0;
  init_strings ();
  init_cons ();
  init_symbol ();
  init_marker ();
  gcprolist = 0;
  staticidx = 0;
  consing_since_gc = 0;
  gc_cons_threshold = 100000;
#ifdef VIRT_ADDR_VARIES
  malloc_sbrk_unused = 1<<22;	/* A large number */
  malloc_sbrk_used = 100000;	/* as reasonable as any number */
#endif /* VIRT_ADDR_VARIES */
}

init_alloc ()
{
  gcprolist = 0;
}

void
syms_of_alloc ()
{
  memory_exhausted_message = Fcons (build_string ("Memory exhausted"), Qnil);
  staticpro (&memory_exhausted_message);

  DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
    "*Number of bytes of consing between garbage collections.");

  DEFVAR_INT ("pure-bytes-used", &pureptr,
    "Number of bytes of sharable Lisp data allocated so far.");

#if 0
  DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used,
    "Number of bytes of unshared memory allocated in this session.");

  DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused,
    "Number of bytes of unshared memory remaining available in this session.");
#endif

  DEFVAR_LISP ("purify-flag", &Vpurify_flag,
    "Non-nil means loading Lisp code in order to dump an executable.");

  DEFVAR_INT ("undo-threshold", &undo_threshold,
    "Keep no more undo information once it exceeds this size.\n\
This threshold is applied when garbage collection happens.\n\
The size is counted as the number of bytes occupied,\n\
which includes both saved text and other data.");
  undo_threshold = 15000;
  DEFVAR_INT ("undo-high-threshold", &undo_high_threshold,
    "Don't keep more than this much size of undo information.\n\
A command which pushes past this size is itself forgotten.\n\
This threshold is applied when garbage collection happens.\n\
The size is counted as the number of bytes occupied,\n\
which includes both saved text and other data.");
  undo_high_threshold = 20000;

  defsubr (&Scons);
  defsubr (&Slist);
  defsubr (&Svector);
  defsubr (&Smake_list);
  defsubr (&Smake_vector);
  defsubr (&Smake_string);
  defsubr (&Smake_symbol);
  defsubr (&Smake_marker);
  defsubr (&Spurecopy);
  defsubr (&Sgarbage_collect);
}