alloc.c

早期freebsd实现

static Lisp_Object make_uninit_string ();

DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
  "Return a newly created string of length LENGTH, with each element being INIT.\n\
Both LENGTH and INIT must be numbers.")
  (length, init)
     Lisp_Object length, init;
{
  register Lisp_Object val;
  register unsigned char *p, *end, c;

  if (XTYPE (length) != Lisp_Int || XINT (length) < 0)
    length = wrong_type_argument (Qnatnump, length);
  CHECK_NUMBER (init, 1);
  val = make_uninit_string (XINT (length));
  c = XINT (init);
  p = XSTRING (val)->data;
  end = p + XSTRING (val)->size;
  while (p != end)
    *p++ = c;
  *p = 0;
  return val;
}

Lisp_Object
make_string (contents, length)
     char *contents;
     int length;
{
  register Lisp_Object val;
  val = make_uninit_string (length, 0);
  bcopy (contents, XSTRING (val)->data, length);
  return val;
}

Lisp_Object
build_string (str)
     char *str;
{
  return make_string (str, strlen (str));
}

static Lisp_Object
make_uninit_string (length)
     int length;
{
  register Lisp_Object val;
  register int fullsize = STRING_FULLSIZE (length);

  if (length < 0) abort ();

  if (fullsize <= STRING_BLOCK_SIZE - current_string_block->pos)
    /* This string can fit in the current string block */
    {
      XSET (val, Lisp_String,
	    (struct Lisp_String *) (current_string_block->chars + current_string_block->pos));
      current_string_block->pos += fullsize;
    }
  else if (fullsize > STRING_BLOCK_OUTSIZE)
    /* This string gets its own string block */
    {
      register struct string_block *new
	= (struct string_block *) malloc (sizeof (struct string_block_head) + fullsize);
      if (!new) memory_full ();
      VALIDATE_LISP_STORAGE (new, 0);
      consing_since_gc += sizeof (struct string_block_head) + fullsize;
      new->pos = fullsize;
      new->next = large_string_blocks;
      large_string_blocks = new;
      XSET (val, Lisp_String,
	    (struct Lisp_String *) ((struct string_block_head *)new + 1));
    }
  else
    /* Make a new current string block and start it off with this string */
    {
      register struct string_block *new
	= (struct string_block *) malloc (sizeof (struct string_block));
      if (!new) memory_full ();
      VALIDATE_LISP_STORAGE (new, sizeof *new);
      consing_since_gc += sizeof (struct string_block);
      current_string_block->next = new;
      new->prev = current_string_block;
      new->next = 0;
      current_string_block = new;
      new->pos = fullsize;
      XSET (val, Lisp_String,
	    (struct Lisp_String *) current_string_block->chars);
    }
    
  XSTRING (val)->size = length;
  XSTRING (val)->data[length] = 0;

  return val;
}

/* Must get an error if pure storage is full,
 since if it cannot hold a large string
 it may be able to hold conses that point to that string;
 then the string is not protected from gc. */

Lisp_Object
make_pure_string (data, length)
     char *data;
     int length;
{
  register Lisp_Object new;
  register int size = sizeof (int) + length + 1;

  if (pureptr + size > PURESIZE)
    error ("Pure Lisp storage exhausted");
  XSET (new, Lisp_String, PUREBEG + pureptr);
  XSTRING (new)->size = length;
  bcopy (data, XSTRING (new)->data, length);
  XSTRING (new)->data[length] = 0;
  pureptr += (size + sizeof (int) - 1)
	     / sizeof (int) * sizeof (int);
  return new;
}

Lisp_Object
pure_cons (car, cdr)
     Lisp_Object car, cdr;
{
  register Lisp_Object new;

  if (pureptr + sizeof (struct Lisp_Cons) > PURESIZE)
    error ("Pure Lisp storage exhausted");
  XSET (new, Lisp_Cons, PUREBEG + pureptr);
  pureptr += sizeof (struct Lisp_Cons);
  XCONS (new)->car = Fpurecopy (car);
  XCONS (new)->cdr = Fpurecopy (cdr);
  return new;
}

Lisp_Object
make_pure_vector (len)
     int len;
{
  register Lisp_Object new;
  register int size = sizeof (struct Lisp_Vector) + (len - 1) * sizeof (Lisp_Object);

  if (pureptr + size > PURESIZE)
    error ("Pure Lisp storage exhausted");

  XSET (new, Lisp_Vector, PUREBEG + pureptr);
  pureptr += size;
  XVECTOR (new)->size = len;
  return new;
}

DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
  "Make a copy of OBJECT in pure storage.\n\
Recursively copies contents of vectors and cons cells.\n\
Does not copy symbols.")
  (obj)
     register Lisp_Object obj;
{
  register Lisp_Object new, tem;
  register int i;

  if (NULL (Vpurify_flag))
    return obj;

  if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
      && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
    return obj;

#ifdef SWITCH_ENUM_BUG
  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);

    case Lisp_String:
      return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size);

    case Lisp_Vector:
      new = make_pure_vector (XVECTOR (obj)->size);
      for (i = 0; i < XVECTOR (obj)->size; i++)
	{
	  tem = XVECTOR (obj)->contents[i];
	  XVECTOR (new)->contents[i] = Fpurecopy (tem);
	}
      return new;

    default:
      return obj;
    }
}

/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

#define NSTATICS 200

int staticidx = 0;

#ifdef __GNUC__
Lisp_Object *staticvec[NSTATICS] = {0};
#else
char staticvec1[NSTATICS * sizeof (Lisp_Object *)] = {0};
#define staticvec ((Lisp_Object **) staticvec1)
#endif

/* Put an entry in staticvec, pointing at the variable whose address is given */

void
staticpro (varaddress)
     Lisp_Object *varaddress;
{
  staticvec[staticidx++] = varaddress;
  if (staticidx >= NSTATICS)
    abort ();
}

struct catchtag
  {
    Lisp_Object tag;
    Lisp_Object val;
    struct catchtag *next;
/*    jmp_buf jmp;  /* We don't need this for GC purposes */
  };

extern struct catchtag *catchlist;

struct backtrace
  {
    struct backtrace *next;
    Lisp_Object *function;
    Lisp_Object *args;	/* Points to vector of args. */
    int nargs;		/* length of vector */
	       /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
    char evalargs;
  };

extern struct backtrace *backtrace_list;

/* Two flags that are set during GC in the `size' component
   of a string or vector.  On some machines, these flags
   are defined by the m- file to be different bits.  */

/* On vector, means it has been marked.
   On string size field or a reference to a string,
   means not the last reference in the chain.  */

#ifndef ARRAY_MARK_FLAG
#define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
#endif /* no ARRAY_MARK_FLAG */

/* Any slot that is a Lisp_Object can point to a string
   and thus can be put on a string's reference-chain
   and thus may need to have its ARRAY_MARK_FLAG set.
   This includes the slots whose markbits are used to mark
   the containing objects.  */

#if ARRAY_MARK_FLAG == MARKBIT
you lose
#endif

int total_conses, total_markers, total_symbols, total_string_size, total_vector_size;
int total_free_conses, total_free_markers, total_free_symbols;

static void mark_object (), mark_buffer ();
static void clear_marks (), gc_sweep ();
static void compact_strings ();

DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
  "Reclaim storage for Lisp objects no longer needed.\n\
Returns info on amount of space in use:\n\
 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
  (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS)\n\
Garbage collection happens automatically if you cons more than\n\
gc-cons-threshold  bytes of Lisp data since previous garbage collection.")
  ()
{
  register struct gcpro *tail;
  register struct specbinding *bind;
  struct catchtag *catch;
  struct handler *handler;
  register struct backtrace *backlist;
  register Lisp_Object tem;
  char *omessage = echo_area_contents;

  register int i;

  if (!noninteractive)
    message1 ("Garbage collecting...");

  /* Don't keep command history around forever */
  tem = Fnthcdr (make_number (30), Vcommand_history);
  if (CONSP (tem))
    XCONS (tem)->cdr = Qnil;
  /* Likewise for undo information.  */
  truncate_all_undos ();

  gc_in_progress = 1;

/*  clear_marks ();  */

  /* In each "large string", set the MARKBIT of the size field.
     That enables mark_object to recognize them.  */
  {
    register struct string_block *b;
    for (b = large_string_blocks; b; b = b->next)
      ((struct Lisp_String *)(&b->chars[0]))->size |= MARKBIT;
  }

  /* Mark all the special slots that serve as the roots of accessibility.

     Usually the special slots to mark are contained in particular structures.
     Then we know no slot is marked twice because the structures don't overlap.
     In some cases, the structures point to the slots to be marked.
     For these, we use MARKBIT to avoid double marking of the slot.  */

  for (i = 0; i < staticidx; i++)
    mark_object (staticvec[i]);
  for (tail = gcprolist; tail; tail = tail->next)
    for (i = 0; i < tail->nvars; i++)
      if (!XMARKBIT (tail->var[i]))
	{
	  mark_object (&tail->var[i]);
	  XMARK (tail->var[i]);
	}
  for (bind = specpdl; bind != specpdl_ptr; bind++)
    {
      mark_object (&bind->symbol);
      mark_object (&bind->old_value);
    }
  for (catch = catchlist; catch; catch = catch->next)
    {
      mark_object (&catch->tag);
      mark_object (&catch->val);
    }  
  for (handler = handlerlist; handler; handler = handler->next)
    {
      mark_object (&handler->handler);
      mark_object (&handler->var);
    }  
  for (backlist = backtrace_list; backlist; backlist = backlist->next)
    {
      if (!XMARKBIT (*backlist->function))
	{
	  mark_object (backlist->function);
	  XMARK (*backlist->function);
	}
      if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
	i = 0;
      else
	i = backlist->nargs - 1;
      for (; i >= 0; i--)
	if (!XMARKBIT (backlist->args[i]))
	  {
	    mark_object (&backlist->args[i]);
	    XMARK (backlist->args[i]);
	  }
    }  

  gc_sweep ();

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

  for (tail = gcprolist; tail; tail = tail->next)
    for (i = 0; i < tail->nvars; i++)
      XUNMARK (tail->var[i]);
  for (backlist = backtrace_list; backlist; backlist = backlist->next)
    {
      XUNMARK (*backlist->function);
      if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
	i = 0;
      else
	i = backlist->nargs - 1;
      for (; i >= 0; i--)
	XUNMARK (backlist->args[i]);
    }  
  XUNMARK (buffer_defaults.name);
  XUNMARK (buffer_local_symbols.name);

/*  clear_marks (); */
  gc_in_progress = 0;

  consing_since_gc = 0;
  consing_at_last_truncate = 0;
  if (gc_cons_threshold < 10000)
    gc_cons_threshold = 10000;

  if (omessage)
    message1 (omessage);
  else if (!noninteractive)
    message1 ("Garbage collecting...done");

  return Fcons (Fcons (make_number (total_conses),
		       make_number (total_free_conses)),
		Fcons (Fcons (make_number (total_symbols),
			      make_number (total_free_symbols)),
		       Fcons (Fcons (make_number (total_markers),
				     make_number (total_free_markers)),
			      Fcons (make_number (total_string_size),
				     Fcons (make_number (total_vector_size),
					    Qnil)))));
}

#if 0
static void
clear_marks ()
{
  /* Clear marks on all conses */
  {
    register struct cons_block *cblk;
    register int lim = cons_block_index;
  
    for (cblk = cons_block; cblk; cblk = cblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  XUNMARK (cblk->conses[i].car);
	lim = CONS_BLOCK_SIZE;
      }
  }
  /* Clear marks on all symbols */
  {
    register struct symbol_block *sblk;
    register int lim = symbol_block_index;
  
    for (sblk = symbol_block; sblk; sblk = sblk->next)
      {
	register int i;
	for (i = 0; i < lim; i++)
	  {
	    XUNMARK (sblk->symbols[i].plist);
	  }
	lim = SYMBOL_BLOCK_SIZE;
      }
  }
  /* Clear marks on all markers */
  {
    register struct marker_block *sblk;
    register int lim = marker_block_index;
  
    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 */
  {
    register struct buffer *nextb = all_buffers;

    while (nextb)
      {
	XUNMARK (nextb->name);
	nextb = nextb->next;
      }
  }
}
#endif

/* Mark reference to a Lisp_Object.  If the object referred to
   has not been seen yet, recursively mark all the references contained in it.

   If the object referenced is a short string, the referrencing slot
   is threaded into a chain of such slots, pointed to from
   the `size' field of the string.  The actual string size
   lives in the last slot in the chain.  We recognize the end
   because it is < (unsigned) STRING_BLOCK_SIZE.  */

static void
mark_object (objptr)
     Lisp_Object *objptr;
{
  register Lisp_Object obj;

  obj = *objptr;
  XUNMARK (obj);

 loop:

  if ((PNTR_COMPARISON_TYPE) XPNTR (obj) < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)
      && (PNTR_COMPARISON_TYPE) XPNTR (obj) >= (PNTR_COMPARISON_TYPE) pure)
    return;

#ifdef SWITCH_ENUM_BUG
  switch ((int) XGCTYPE (obj))
#else
  switch (XGCTYPE (obj))
#endif
    {
    case Lisp_String:
      {
	register struct Lisp_String *ptr = XSTRING (obj);

	if (ptr->size & MARKBIT)
	  /* A large string.  Just set ARRAY_MARK_FLAG.  */
	  ptr->size |= ARRAY_MARK_FLAG;
	else
	  {
	    /* A small string.  Put this reference
	       into the chain of references to it.
	       The address OBJPTR is even, so if the address
	       includes MARKBIT, put it in the low bit
	       when we store OBJPTR into the size field.  */

	    if (XMARKBIT (*objptr))
	      {
		XFASTINT (*objptr) = ptr->size;
		XMARK (*objptr);
	      }
	    else
	      XFASTINT (*objptr) = ptr->size;