comparison src/alloc.c @ 85019:21a145f18ed2

(allocate_pseudovector): New fun. (ALLOCATE_PSEUDOVECTOR): New macro. (allocate_window, allocate_terminal, allocate_frame) (allocate_process): Use it. (mark_vectorlike): New function. (mark_object) <FRAMEP, WINDOWP, BOOL_VECTOR_P, VECTORP>: Use it. (mark_terminals): Use it. (Fmake_bool_vector, Fmake_char_table, make_sub_char_table) (Fmake_byte_code): Use XSETPVECTYPE.

85018:3389713480bb

		     / BOOL_VECTOR_BITS_PER_CHAR);

  /* We must allocate one more elements than LENGTH_IN_ELTS for the
     slot `size' of the struct Lisp_Bool_Vector.  */
  val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
  p = XBOOL_VECTOR (val);

  /* Get rid of any bits that would cause confusion.  */
  p->vector_size = 0;
  XSETBOOL_VECTOR (val, p);
  p->size = XFASTINT (length);

  real_init = (NILP (init) ? 0 : -1);
  for (i = 0; i < length_in_chars ; i++)
    p->data[i] = real_init;

  /* Clear the extraneous bits in the last byte.  */
  if (XINT (length) != length_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
    XBOOL_VECTOR (val)->data[length_in_chars - 1]
      &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;

  return val;
}

}


/* Allocate other vector-like structures.  */

struct Lisp_Hash_Table *
allocate_hash_table ()
{
  EMACS_INT len = VECSIZE (struct Lisp_Hash_Table);
  struct Lisp_Vector *v = allocate_vectorlike (len);

  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;

  return (struct Lisp_Hash_Table *) v;
}


struct window *
allocate_window ()
{
  EMACS_INT len = VECSIZE (struct window);
  struct Lisp_Vector *v = allocate_vectorlike (len);
  EMACS_INT i;

  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;
  v->size = len;

  return (struct window *) v;
}


struct terminal *
allocate_terminal ()
{
  /* Memory-footprint of the object in nb of Lisp_Object fields.  */
  EMACS_INT memlen = VECSIZE (struct terminal);
  /* Size if we only count the actual Lisp_Object fields (which need to be
     traced by the GC).  */
  EMACS_INT lisplen = PSEUDOVECSIZE (struct terminal, next_terminal);
  struct Lisp_Vector *v = allocate_vectorlike (memlen);
  EMACS_INT i;
  Lisp_Object tmp, zero = make_number (0);

  for (i = 0; i < lisplen; ++i)
    v->contents[i] = Qnil;
  for (;i < memlen; ++i)
    v->contents[i] = zero;
  v->size = lisplen;		/* Only trace the Lisp fields.  */
  XSETTERMINAL (tmp, v);	/* Add the appropriate tag.  */

  return (struct terminal *) v;
}

struct frame *
allocate_frame ()
{
  EMACS_INT len = VECSIZE (struct frame);
  struct Lisp_Vector *v = allocate_vectorlike (len);
  EMACS_INT i;

  for (i = 0; i < len; ++i)
    v->contents[i] = make_number (0);
  v->size = len;
  return (struct frame *) v;
}


struct Lisp_Process *
allocate_process ()
{
  /* Memory-footprint of the object in nb of Lisp_Object fields.  */
  EMACS_INT memlen = VECSIZE (struct Lisp_Process);
  /* Size if we only count the actual Lisp_Object fields (which need to be
     traced by the GC).  */
  EMACS_INT lisplen = PSEUDOVECSIZE (struct Lisp_Process, pid);
  struct Lisp_Vector *v = allocate_vectorlike (memlen);
  EMACS_INT i;

  for (i = 0; i < lisplen; ++i)
    v->contents[i] = Qnil;
  v->size = lisplen;

  return (struct Lisp_Process *) v;
}


struct Lisp_Vector *
allocate_other_vector (len)
     EMACS_INT len;
{
  struct Lisp_Vector *v = allocate_vectorlike (len);

  if (XINT (n) < 0 || XINT (n) > 10)
    args_out_of_range (n, Qnil);
  /* Add 2 to the size for the defalt and parent slots.  */
  vector = Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS + XINT (n)),
			 init);
  XCHAR_TABLE (vector)->top = Qt;
  XCHAR_TABLE (vector)->parent = Qnil;
  XCHAR_TABLE (vector)->purpose = purpose;
  XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
  return vector;

make_sub_char_table (init)
     Lisp_Object init;
{
  Lisp_Object vector
    = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), init);
  XCHAR_TABLE (vector)->top = Qnil;
  XCHAR_TABLE (vector)->defalt = Qnil;
  XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
  return vector;
}

    {
      if (!NILP (Vpurify_flag))
	args[index] = Fpurecopy (args[index]);
      p->contents[index] = args[index];
    }
  XSETCOMPILED (val, p);
  return val;
}

   links of a list, in mark_object.  In debugging,
   the call to abort will hit a breakpoint.
   Normally this is zero and the check never goes off.  */
int mark_object_loop_halt;

void
mark_object (arg)
     Lisp_Object arg;
{
  register Lisp_Object obj = arg;

	  goto loop;
	}
      else if (GC_FRAMEP (obj))
	{
	  register struct frame *ptr = XFRAME (obj);

	  if (VECTOR_MARKED_P (ptr)) break;   /* Already marked */
	  VECTOR_MARK (ptr);		      /* Else mark it */

	  CHECK_LIVE (live_vector_p);
	  mark_object (ptr->name);
	  mark_object (ptr->icon_name);
	  mark_object (ptr->title);
	  mark_object (ptr->focus_frame);
	  mark_object (ptr->selected_window);
	  mark_object (ptr->minibuffer_window);
	  mark_object (ptr->param_alist);
	  mark_object (ptr->scroll_bars);
	  mark_object (ptr->condemned_scroll_bars);
	  mark_object (ptr->menu_bar_items);
	  mark_object (ptr->face_alist);
	  mark_object (ptr->menu_bar_vector);
	  mark_object (ptr->buffer_predicate);
	  mark_object (ptr->buffer_list);
	  mark_object (ptr->buried_buffer_list);
	  mark_object (ptr->menu_bar_window);
	  mark_object (ptr->tool_bar_window);
	  mark_face_cache (ptr->face_cache);
#ifdef HAVE_WINDOW_SYSTEM
	  mark_image_cache (ptr);
	  mark_object (ptr->tool_bar_items);
	  mark_object (ptr->desired_tool_bar_string);
	  mark_object (ptr->current_tool_bar_string);
#endif /* HAVE_WINDOW_SYSTEM */
	}
      else if (GC_BOOL_VECTOR_P (obj))
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);

	  if (VECTOR_MARKED_P (ptr))
	    break;   /* Already marked */
	  CHECK_LIVE (live_vector_p);
	  VECTOR_MARK (ptr);	/* Else mark it */
	}
      else if (GC_WINDOWP (obj))
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);
	  struct window *w = XWINDOW (obj);
	  register int i;

	  /* Stop if already marked.  */
	  if (VECTOR_MARKED_P (ptr))
	    break;

	  /* Mark it.  */
	  CHECK_LIVE (live_vector_p);
	  VECTOR_MARK (ptr);

	  /* There is no Lisp data above The member CURRENT_MATRIX in
	     struct WINDOW.  Stop marking when that slot is reached.  */
	  for (i = 0;
	       (char *) &ptr->contents[i] < (char *) &w->current_matrix;
	       i++)
	    mark_object (ptr->contents[i]);

	  /* Mark glyphs for leaf windows.  Marking window matrices is
	     sufficient because frame matrices use the same glyph
	     memory.  */
	  if (NILP (w->hchild)
	      && NILP (w->vchild)
	      && w->current_matrix)
	    {
	      mark_glyph_matrix (w->current_matrix);
	      mark_glyph_matrix (w->desired_matrix);
	    }
	}
      else if (GC_HASH_TABLE_P (obj))
	{

	  mark_object (h->user_cmp_function);

	  /* If hash table is not weak, mark all keys and values.
	     For weak tables, mark only the vector.  */
	  if (GC_NILP (h->weak))
	    mark_object (h->key_and_value);
	  else
	    VECTOR_MARK (XVECTOR (h->key_and_value));
	}
      else
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);
	  register EMACS_INT size = ptr->size;
	  register int i;

	  if (VECTOR_MARKED_P (ptr)) break; /* Already marked */
	  CHECK_LIVE (live_vector_p);
	  VECTOR_MARK (ptr);	/* Else mark it */
	  if (size & PSEUDOVECTOR_FLAG)
	    size &= PSEUDOVECTOR_SIZE_MASK;

	  /* Note that this size is not the memory-footprint size, but only
	     the number of Lisp_Object fields that we should trace.
	     The distinction is used e.g. by Lisp_Process which places extra
	     non-Lisp_Object fields at the end of the structure.  */
	  for (i = 0; i < size; i++) /* and then mark its elements */
	    mark_object (ptr->contents[i]);
	}
      break;

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

static void
mark_terminals (void)
{
  struct terminal *t;
  Lisp_Object tmp;
  for (t = terminal_list; t; t = t->next_terminal)
    {
      eassert (t->name != NULL);
      XSETVECTOR (tmp, t);
      mark_object (tmp);
    }
}

85019:21a145f18ed2

		     / BOOL_VECTOR_BITS_PER_CHAR);

  /* We must allocate one more elements than LENGTH_IN_ELTS for the
     slot `size' of the struct Lisp_Bool_Vector.  */
  val = Fmake_vector (make_number (length_in_elts + 1), Qnil);

  /* Get rid of any bits that would cause confusion.  */
  XVECTOR (val)->size = 0;	/* No Lisp_Object to trace in there.  */
  XSETPVECTYPE (XVECTOR (val), PVEC_BOOL_VECTOR);

  p = XBOOL_VECTOR (val);
  p->size = XFASTINT (length);

  real_init = (NILP (init) ? 0 : -1);
  for (i = 0; i < length_in_chars ; i++)
    p->data[i] = real_init;

  /* Clear the extraneous bits in the last byte.  */
  if (XINT (length) != length_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
    p->data[length_in_chars - 1]
      &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;

  return val;
}

}


/* Allocate other vector-like structures.  */

static struct Lisp_Vector *
allocate_pseudovector (memlen, lisplen, tag)
     int memlen, lisplen;
     EMACS_INT tag;
{
  struct Lisp_Vector *v = allocate_vectorlike (memlen);
  EMACS_INT i;

  /* Only the first lisplen slots will be traced normally by the GC.  */
  v->size = lisplen;
  for (i = 0; i < lisplen; ++i)
    v->contents[i] = Qnil;

  XSETPVECTYPE (v, tag);	/* Add the appropriate tag.  */
  return v;
}
#define ALLOCATE_PSEUDOVECTOR(typ,field,tag)				\
  ((typ*)								\
   allocate_pseudovector						\
       (VECSIZE (typ), PSEUDOVECSIZE (typ, field), tag))

struct Lisp_Hash_Table *
allocate_hash_table ()
{
  EMACS_INT len = VECSIZE (struct Lisp_Hash_Table);
  struct Lisp_Vector *v = allocate_vectorlike (len);

  for (i = 0; i < len; ++i)
    v->contents[i] = Qnil;

  return (struct Lisp_Hash_Table *) v;
}
  
  
struct window *
allocate_window ()
{
  return ALLOCATE_PSEUDOVECTOR(struct window, current_matrix, PVEC_WINDOW);
}


struct terminal *
allocate_terminal ()
{
  struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal,
					      next_terminal, PVEC_TERMINAL);
  /* Zero out the non-GC'd fields.  FIXME: This should be made unnecessary.  */
  bzero (&(t->next_terminal),
	 ((char*)(t+1)) - ((char*)&(t->next_terminal)));

  return t;
}

struct frame *
allocate_frame ()
{
  struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame,
					   face_cache, PVEC_FRAME);
  /* Zero out the non-GC'd fields.  FIXME: This should be made unnecessary.  */
  bzero (&(f->face_cache),
	 ((char*)(f+1)) - ((char*)&(f->face_cache)));
  return f;
}


struct Lisp_Process *
allocate_process ()
{
  return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
}


/* Only used for PVEC_WINDOW_CONFIGURATION. */
struct Lisp_Vector *
allocate_other_vector (len)
     EMACS_INT len;
{
  struct Lisp_Vector *v = allocate_vectorlike (len);

  if (XINT (n) < 0 || XINT (n) > 10)
    args_out_of_range (n, Qnil);
  /* Add 2 to the size for the defalt and parent slots.  */
  vector = Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS + XINT (n)),
			 init);
  XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
  XCHAR_TABLE (vector)->top = Qt;
  XCHAR_TABLE (vector)->parent = Qnil;
  XCHAR_TABLE (vector)->purpose = purpose;
  XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
  return vector;

make_sub_char_table (init)
     Lisp_Object init;
{
  Lisp_Object vector
    = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), init);
  XSETPVECTYPE (XVECTOR (vector), PVEC_CHAR_TABLE);
  XCHAR_TABLE (vector)->top = Qnil;
  XCHAR_TABLE (vector)->defalt = Qnil;
  XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
  return vector;
}

    {
      if (!NILP (Vpurify_flag))
	args[index] = Fpurecopy (args[index]);
      p->contents[index] = args[index];
    }
  XSETPVECTYPE (p, PVEC_COMPILED);
  XSETCOMPILED (val, p);
  return val;
}

   links of a list, in mark_object.  In debugging,
   the call to abort will hit a breakpoint.
   Normally this is zero and the check never goes off.  */
int mark_object_loop_halt;

/* Return non-zero if the object was not yet marked.  */
static int
mark_vectorlike (ptr)
     struct Lisp_Vector *ptr;
{
  register EMACS_INT size = ptr->size;
  register int i;

  if (VECTOR_MARKED_P (ptr))
    return 0;			/* Already marked */
  VECTOR_MARK (ptr);		/* Else mark it */
  if (size & PSEUDOVECTOR_FLAG)
    size &= PSEUDOVECTOR_SIZE_MASK;
  
  /* Note that this size is not the memory-footprint size, but only
     the number of Lisp_Object fields that we should trace.
     The distinction is used e.g. by Lisp_Process which places extra
     non-Lisp_Object fields at the end of the structure.  */
  for (i = 0; i < size; i++) /* and then mark its elements */
    mark_object (ptr->contents[i]);
  return 1;
}

void
mark_object (arg)
     Lisp_Object arg;
{
  register Lisp_Object obj = arg;

	  goto loop;
	}
      else if (GC_FRAMEP (obj))
	{
	  register struct frame *ptr = XFRAME (obj);
	  if (mark_vectorlike (XVECTOR (obj)))
	    {
	  mark_face_cache (ptr->face_cache);
#ifdef HAVE_WINDOW_SYSTEM
	  mark_image_cache (ptr);
#endif /* HAVE_WINDOW_SYSTEM */
	}
	}
      else if (GC_WINDOWP (obj))
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);
	  struct window *w = XWINDOW (obj);
	  if (mark_vectorlike (ptr))
	    {
	  /* Mark glyphs for leaf windows.  Marking window matrices is
	     sufficient because frame matrices use the same glyph
	     memory.  */
	      if (NILP (w->hchild)
		  && NILP (w->vchild)
		  && w->current_matrix)
		{
		  mark_glyph_matrix (w->current_matrix);
	      mark_glyph_matrix (w->desired_matrix);
	    }
	}
      else if (GC_HASH_TABLE_P (obj))
	{

	  mark_object (h->user_cmp_function);

	  /* If hash table is not weak, mark all keys and values.
	     For weak tables, mark only the vector.  */
	  if (GC_NILP (h->weak))
		mark_object (h->key_and_value);
	      else
		VECTOR_MARK (XVECTOR (h->key_and_value));
	    }
	}
      else
	mark_vectorlike (XVECTOR (obj));
      break;

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

static void
mark_terminals (void)
{
  struct terminal *t;
  for (t = terminal_list; t; t = t->next_terminal)
    {
      eassert (t->name != NULL);
      mark_vectorlike ((struct Lisp_Vector *)tmp);
    }
}