comparison src/alloc.c @ 25024:3bb745067f0e

(gc_sweep): Call sweep_weak_hash_tables. (survives_gc_p): New. (mark_object): Mark objects referenced from glyphs, hash tables, toolbar date, toolbar window, face caches, menu bar window. Mark windows specially. (Fgarbage_collect): Use message3_nolog. (mark_face_cache): New. (NSTATICS): Increased to 1024. (mark_glyph_matrix): New.

25023:6e3de2f65704

/* Non-zero means ignore malloc warnings.  Set during initialization.  */
int ignore_warnings;

Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;

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

extern int message_enable_multibyte;

/* Versions of malloc and realloc that print warnings as memory gets full.  */


/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

#define NSTATICS 768

Lisp_Object *staticvec[NSTATICS] = {0};

int staticidx = 0;

  struct catchtag *catch;
  struct handler *handler;
  register struct backtrace *backlist;
  register Lisp_Object tem;
  char *omessage = echo_area_glyphs;
  int omessage_length = echo_area_glyphs_length;
  int oldmultibyte = message_enable_multibyte;
  char stack_top_variable;
  register int i;

  /* In case user calls debug_print during GC,
     don't let that cause a recursive GC.  */
  consing_since_gc = 0;

  /* Save a copy of the contents of the stack, for debugging.  */
#if MAX_SAVE_STACK > 0
  if (NILP (Vpurify_flag))
    {

  if (gc_cons_threshold < 10000)
    gc_cons_threshold = 10000;

  if (garbage_collection_messages)
    {
      if (omessage || minibuf_level > 0)
	message2_nolog (omessage, omessage_length, oldmultibyte);
      else
	message1_nolog ("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),

	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.

#define LAST_MARKED_SIZE 500
Lisp_Object *last_marked[LAST_MARKED_SIZE];
int last_marked_index;

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

	  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);
	}
      else if (GC_BOOL_VECTOR_P (obj))
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);

	  if (ptr->size & ARRAY_MARK_FLAG)
	    break;   /* Already marked */
	  ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
	}
      else
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);
	  register EMACS_INT size = ptr->size;

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

	XMARK (ptr->plist);
	mark_object ((Lisp_Object *) &ptr->value);
	mark_object (&ptr->function);
	mark_object (&ptr->plist);
	XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
	mark_object (&ptr->name);
	/* Note that we do not mark the obarray of the symbol.
	   It is safe not to do so because nothing accesses that
	   slot except to check whether it is nil.  */
	ptr = ptr->next;
	if (ptr)

      mark_object (&kb->Vsystem_key_alist);
      mark_object (&kb->system_key_syms);
      mark_object (&kb->Vdefault_minibuffer_frame);
    }
}

/* Sweep: 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 */
  {

    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;
	  lisp_free (vector);
	  n_vectors--;
	  vector = next;
	}
      else
	{
	  vector->size &= ~ARRAY_MARK_FLAG;
	  if (vector->size & PSEUDOVECTOR_FLAG)

25024:3bb745067f0e

/* Non-zero means ignore malloc warnings.  Set during initialization.  */
int ignore_warnings;

Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;

static void mark_buffer (), mark_kboards ();
static void clear_marks (), gc_sweep ();
static void compact_strings ();
static void mark_glyph_matrix P_ ((struct glyph_matrix *));
static void mark_face_cache P_ ((struct face_cache *));

#ifdef HAVE_WINDOW_SYSTEM
static void mark_image P_ ((struct image *));
static void mark_image_cache P_ ((struct frame *));
#endif /* HAVE_WINDOW_SYSTEM */


extern int message_enable_multibyte;

/* Versions of malloc and realloc that print warnings as memory gets full.  */


/* Recording what needs to be marked for gc.  */

struct gcpro *gcprolist;

#define NSTATICS 1024

Lisp_Object *staticvec[NSTATICS] = {0};

int staticidx = 0;

  struct catchtag *catch;
  struct handler *handler;
  register struct backtrace *backlist;
  register Lisp_Object tem;
  char *omessage = echo_area_glyphs;
  Lisp_Object omessage_string = echo_area_message;
  int omessage_length = echo_area_glyphs_length;
  int oldmultibyte = message_enable_multibyte;
  char stack_top_variable;
  register int i;
  struct gcpro gcpro1;

  /* In case user calls debug_print during GC,
     don't let that cause a recursive GC.  */
  consing_since_gc = 0;

  GCPRO1 (omessage_string);

  /* Save a copy of the contents of the stack, for debugging.  */
#if MAX_SAVE_STACK > 0
  if (NILP (Vpurify_flag))
    {

  if (gc_cons_threshold < 10000)
    gc_cons_threshold = 10000;

  if (garbage_collection_messages)
    {
      if (STRINGP (omessage_string))
	message3_nolog (omessage_string, omessage_length, oldmultibyte);
      if (omessage || minibuf_level > 0)
	message2_nolog (omessage, omessage_length, oldmultibyte);
      else
	message1_nolog ("Garbage collecting...done");
    }

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

	nextb = nextb->next;
      }
  }
}
#endif

/* Mark Lisp objects in glyph matrix MATRIX.  */

static void
mark_glyph_matrix (matrix)
     struct glyph_matrix *matrix;
{
  struct glyph_row *row = matrix->rows;
  struct glyph_row *end = row + matrix->nrows;

  while (row < end)
    {
      if (row->enabled_p)
	{
	  int area;
	  for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
	    {
	      struct glyph *glyph = row->glyphs[area];
	      struct glyph *end_glyph = glyph + row->used[area];
	      
	      while (glyph < end_glyph)
		{
		  if (/* OBJECT Is zero for face extending glyphs, padding
			 spaces and such.  */
		      glyph->object
		      /* Marking the buffer itself should not be necessary.  */
		      && !BUFFERP (glyph->object))
		    mark_object (&glyph->object);
		  ++glyph;
		}
	    }
	}
      
      ++row;
    }
}

/* Mark Lisp faces in the face cache C.  */

static void
mark_face_cache (c)
     struct face_cache *c;
{
  if (c)
    {
      int i, j;
      for (i = 0; i < c->used; ++i)
	{
	  struct face *face = FACE_FROM_ID (c->f, i);

	  if (face)
	    {
	      for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
		mark_object (&face->lface[j]);
	      mark_object (&face->registry);
	    }
	}
    }
}


#ifdef HAVE_WINDOW_SYSTEM

/* Mark Lisp objects in image IMG.  */

static void
mark_image (img)
     struct image *img;
{
  mark_object (&img->spec);
  
  if (!NILP (img->data.lisp_val))
    mark_object (&img->data.lisp_val);
}


/* Mark Lisp objects in image cache of frame F.  It's done this way so
   that we don't have to include xterm.h here.  */

static void
mark_image_cache (f)
     struct frame *f;
{
  forall_images_in_image_cache (f, mark_image);
}

#endif /* HAVE_X_WINDOWS */



/* Mark reference to a Lisp_Object.
  If the object referred to has not been seen yet, recursively mark
  all the references contained in it.

#define LAST_MARKED_SIZE 500
Lisp_Object *last_marked[LAST_MARKED_SIZE];
int last_marked_index;

void
mark_object (argptr)
     Lisp_Object *argptr;
{
  Lisp_Object *objptr = argptr;
  register Lisp_Object obj;

	  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->menu_bar_window);
	  mark_object (&ptr->toolbar_window);
	  mark_face_cache (ptr->face_cache);
#ifdef HAVE_WINDOW_SYSTEM
	  mark_image_cache (ptr);
	  mark_object (&ptr->desired_toolbar_items);
	  mark_object (&ptr->current_toolbar_items);
	  mark_object (&ptr->desired_toolbar_string);
	  mark_object (&ptr->current_toolbar_string);
#endif /* HAVE_WINDOW_SYSTEM */
	}
      else if (GC_BOOL_VECTOR_P (obj))
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);

	  if (ptr->size & ARRAY_MARK_FLAG)
	    break;   /* Already marked */
	  ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
	}
      else if (GC_WINDOWP (obj))
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);
	  struct window *w = XWINDOW (obj);
	  register EMACS_INT size = ptr->size;
	  /* The reason we use ptr1 is to avoid an apparent hardware bug
	     that happens occasionally on the FSF's HP 300s.
	     The bug is that a2 gets clobbered by recursive calls to mark_object.
	     The clobberage seems to happen during function entry,
	     perhaps in the moveml instruction.
	     Yes, this is a crock, but we have to do it.  */
	  struct Lisp_Vector *volatile ptr1 = ptr;
	  register int i;

	  /* Stop if already marked.  */
	  if (size & ARRAY_MARK_FLAG)
	    break;

	  /* Mark it.  */
	  ptr->size |= ARRAY_MARK_FLAG;

	  /* There is no Lisp data above The member CURRENT_MATRIX in
	     struct WINDOW.  Stop marking when that slot is reached.  */
	  for (i = 0;
	       (char *) &ptr1->contents[i] < (char *) &w->current_matrix;
	       i++)
	    mark_object (&ptr1->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))
	{
	  struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
	  EMACS_INT size = h->size;
	  
	  /* Stop if already marked.  */
	  if (size & ARRAY_MARK_FLAG)
	    break;

	  /* Mark it.  */
	  h->size |= ARRAY_MARK_FLAG;

	  /* Mark contents.  */
	  mark_object (&h->test);
	  mark_object (&h->weak);
	  mark_object (&h->rehash_size);
	  mark_object (&h->rehash_threshold);
	  mark_object (&h->hash);
	  mark_object (&h->next);
	  mark_object (&h->index);
	  mark_object (&h->user_hash_function);
	  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
	    XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG;
	    
	}
      else
	{
	  register struct Lisp_Vector *ptr = XVECTOR (obj);
	  register EMACS_INT size = ptr->size;

	  if (size & ARRAY_MARK_FLAG) break; /* Already marked */
	  ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */
	  if (size & PSEUDOVECTOR_FLAG)
	    size &= PSEUDOVECTOR_SIZE_MASK;

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

	XMARK (ptr->plist);
	mark_object ((Lisp_Object *) &ptr->value);
	mark_object (&ptr->function);
	mark_object (&ptr->plist);
	XSETTYPE (*(Lisp_Object *) &ptr->name, Lisp_String);
	mark_object ((Lisp_Object *) &ptr->name);
	/* Note that we do not mark the obarray of the symbol.
	   It is safe not to do so because nothing accesses that
	   slot except to check whether it is nil.  */
	ptr = ptr->next;
	if (ptr)

      mark_object (&kb->Vsystem_key_alist);
      mark_object (&kb->system_key_syms);
      mark_object (&kb->Vdefault_minibuffer_frame);
    }
}


/* Value is non-zero if OBJ will survive the current GC because it's
   either marked or does not need to be marked to survive.  */

int
survives_gc_p (obj)
     Lisp_Object obj;
{
  int survives_p;
  
  switch (XGCTYPE (obj))
    {
    case Lisp_Int:
      survives_p = 1;
      break;

    case Lisp_Symbol:
      survives_p = XMARKBIT (XSYMBOL (obj)->plist);
      break;

    case Lisp_Misc:
      switch (XMISCTYPE (obj))
	{
	case Lisp_Misc_Marker:
	  survives_p = XMARKBIT (obj);
	  break;
	  
	case Lisp_Misc_Buffer_Local_Value:
	case Lisp_Misc_Some_Buffer_Local_Value:
	  survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
	  break;
	  
	case Lisp_Misc_Intfwd:
	case Lisp_Misc_Boolfwd:
	case Lisp_Misc_Objfwd:
	case Lisp_Misc_Buffer_Objfwd:
	case Lisp_Misc_Kboard_Objfwd:
	  survives_p = 1;
	  break;
	  
	case Lisp_Misc_Overlay:
	  survives_p = XMARKBIT (XOVERLAY (obj)->plist);
	  break;

	default:
	  abort ();
	}
      break;

    case Lisp_String:
      {
	struct Lisp_String *s = XSTRING (obj);

	if (s->size & MARKBIT)
	  survives_p = s->size & ARRAY_MARK_FLAG;
	else
	  survives_p = (s->size & ~DONT_COPY_FLAG) > STRING_BLOCK_SIZE;
      }
      break;

    case Lisp_Vectorlike:
      if (GC_BUFFERP (obj))
	survives_p = XMARKBIT (XBUFFER (obj)->name);
      else if (GC_SUBRP (obj))
	survives_p = 1;
      else
	survives_p = XVECTOR (obj)->size & ARRAY_MARK_FLAG;
      break;

    case Lisp_Cons:
      survives_p = XMARKBIT (XCAR (obj));
      break;

#ifdef LISP_FLOAT_TYPE
    case Lisp_Float:
      survives_p = XMARKBIT (XFLOAT (obj)->type);
      break;
#endif /* LISP_FLOAT_TYPE */

    default:
      abort ();
    }

  return survives_p;
}



/* Sweep: find all structures not marked, and free them. */

static void
gc_sweep ()
{
  /* Remove or mark entries in weak hash tables.
     This must be done before any object is unmarked.  */
  sweep_weak_hash_tables ();

  total_string_size = 0;
  compact_strings ();

  /* Put all unmarked conses on free list */
  {

    total_vector_size = 0;

    while (vector)
      if (!(vector->size & ARRAY_MARK_FLAG))
	{
#if 0
	  if ((vector->size & (PSEUDOVECTOR_FLAG | PVEC_HASH_TABLE))
	      == (PSEUDOVECTOR_FLAG | PVEC_HASH_TABLE))
	    fprintf (stderr, "Freeing hash table %p\n", vector);
#endif
	  if (prev)
	    prev->next = vector->next;
	  else
	    all_vectors = vector->next;
	  next = vector->next;
	  lisp_free (vector);
	  n_vectors--;
	  vector = next;

	}
      else
	{
	  vector->size &= ~ARRAY_MARK_FLAG;
	  if (vector->size & PSEUDOVECTOR_FLAG)