[bpt/guile.git] / libguile / gc-mark.c

/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
 */


\f
#if HAVE_CONFIG_H
#  include <config.h>
#endif

#include <stdio.h>
#include <errno.h>
#include <string.h>
#include <assert.h>

#ifdef __ia64__
#include <ucontext.h>
extern unsigned long * __libc_ia64_register_backing_store_base;
#endif

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/stime.h"
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
#include "libguile/unif.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/tags.h"
#include "libguile/private-gc.h"
#include "libguile/validate.h"
#include "libguile/deprecation.h"
#include "libguile/gc.h"

#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif

#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#ifdef __ia64__
# define SCM_MARK_BACKING_STORE() do {                                \
    ucontext_t ctx;                                                   \
    SCM_STACKITEM * top, * bot;                                       \
    getcontext (&ctx);                                                \
    scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext,           \
      ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
       / sizeof (SCM_STACKITEM)));                                    \
    bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base;  \
    top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp;                \
    scm_mark_locations (bot, top - bot); } while (0)
#else
# define SCM_MARK_BACKING_STORE()
#endif


/*
  Entry point for this file.
 */
void
scm_mark_all (void)
{
  long j;
  
  
  scm_i_clear_mark_space ();
  
  /* Mark every thread's stack and registers */
  scm_threads_mark_stacks ();

  j = SCM_NUM_PROTECTS;
  while (j--)
    scm_gc_mark (scm_sys_protects[j]);

  /* mark the registered roots */
  {
    size_t i;
    for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots); ++i)
      {
	SCM l = SCM_HASHTABLE_BUCKETS (scm_gc_registered_roots)[i];
	for (; !SCM_NULLP (l); l = SCM_CDR (l))
	  {
	    SCM *p = (SCM *) (scm_num2long (SCM_CAAR (l), 0, NULL));
	    scm_gc_mark (*p);
	  }
      }
  }
  

  /* FIXME: we should have a means to register C functions to be run
   * in different phases of GC
   */
  scm_mark_subr_table ();
}

/* {Mark/Sweep}
 */

/*
  Mark an object precisely, then recurse.
 */
void
scm_gc_mark (SCM ptr)
{
  if (SCM_IMP (ptr))
    return;
  
  if (SCM_GC_MARK_P (ptr))
    return;

  SCM_SET_GC_MARK (ptr);
  scm_gc_mark_dependencies (ptr);
}

/*

Mark the dependencies of an object.

Prefetching:

Should prefetch objects before marking, i.e. if marking a cell, we
should prefetch the car, and then mark the cdr. This will improve CPU
cache misses, because the car is more likely to be in core when we
finish the cdr.

See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
garbage collector cache misses.

Prefetch is supported on GCC >= 3.1 

(Some time later.)

Tried this with GCC 3.1.1 -- the time differences are barely measurable.
Perhaps this would work better with an explicit markstack?


*/
void
scm_gc_mark_dependencies (SCM p)
#define FUNC_NAME "scm_gc_mark_dependencies"
{
  register long i;
  register SCM ptr;
  scm_t_bits cell_type;

  ptr = p;
 scm_mark_dependencies_again:
  
  cell_type = SCM_GC_CELL_TYPE (ptr);
  switch (SCM_ITAG7 (cell_type))
    {
    case scm_tcs_cons_nimcar:
      if (SCM_IMP (SCM_CDR (ptr)))
	{
	  ptr = SCM_CAR (ptr);
	  goto gc_mark_nimp;
	}


      scm_gc_mark (SCM_CAR (ptr));
      ptr = SCM_CDR (ptr);
      goto gc_mark_nimp;
    case scm_tcs_cons_imcar:
      ptr = SCM_CDR (ptr);
      goto gc_mark_loop;
    case scm_tc7_pws:

      scm_gc_mark (SCM_SETTER (ptr));
      ptr = SCM_PROCEDURE (ptr);
      goto gc_mark_loop;
    case scm_tcs_struct:
      {
	/* XXX - use less explicit code. */
	scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
	scm_t_bits * vtable_data = (scm_t_bits *) word0;
	SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
	long len = SCM_SYMBOL_LENGTH (layout);
	char * fields_desc = SCM_SYMBOL_CHARS (layout);
	scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);

	if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
	  {
	    scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
	    scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
	  }
	if (len)
	  {
	    long x;

	    for (x = 0; x < len - 2; x += 2, ++struct_data)
	      if (fields_desc[x] == 'p')
		scm_gc_mark (SCM_PACK (*struct_data));
	    if (fields_desc[x] == 'p')
	      {
		if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
		  for (x = *struct_data++; x; --x, ++struct_data)
		    scm_gc_mark (SCM_PACK (*struct_data));
		else
		  scm_gc_mark (SCM_PACK (*struct_data));
	      }
	  }
	/* mark vtable */
	ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
	goto gc_mark_loop;
      }
      break;
    case scm_tcs_closures:
      if (SCM_IMP (SCM_ENV (ptr)))
	{
	  ptr = SCM_CLOSCAR (ptr);
	  goto gc_mark_nimp;
	}
      scm_gc_mark (SCM_CLOSCAR (ptr));
      ptr = SCM_ENV (ptr);
      goto gc_mark_nimp;
    case scm_tc7_vector:
      i = SCM_VECTOR_LENGTH (ptr);
      if (i == 0)
	break;
      while (--i > 0)
	{
	  if (SCM_NIMP (SCM_VELTS (ptr)[i]))
	    scm_gc_mark (SCM_VELTS (ptr)[i]);
	}
      ptr = SCM_VELTS (ptr)[0];
      goto gc_mark_loop;
#ifdef CCLO
    case scm_tc7_cclo:
      {
	size_t i = SCM_CCLO_LENGTH (ptr);
	size_t j;
	for (j = 1; j != i; ++j)
	  {
	    SCM obj = SCM_CCLO_REF (ptr, j);
	    if (!SCM_IMP (obj))
	      scm_gc_mark (obj);
	  }
	ptr = SCM_CCLO_REF (ptr, 0);
	goto gc_mark_loop;
      }
#endif
#if SCM_HAVE_ARRAYS
    case scm_tc7_bvect:
    case scm_tc7_byvect:
    case scm_tc7_ivect:
    case scm_tc7_uvect:
    case scm_tc7_fvect:
    case scm_tc7_dvect:
    case scm_tc7_cvect:
    case scm_tc7_svect:
#if SCM_SIZEOF_LONG_LONG != 0
    case scm_tc7_llvect:
#endif
#endif
    case scm_tc7_string:
      break;

    case scm_tc7_number:
      break;

    case scm_tc7_wvect:
      SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors);
      scm_weak_vectors = ptr;
      if (SCM_IS_WHVEC_ANY (ptr))
	{
	  long x;
	  long len;
	  int weak_keys;
	  int weak_values;

	  len = SCM_VECTOR_LENGTH (ptr);
	  weak_keys = SCM_WVECT_WEAK_KEY_P (ptr);
	  weak_values = SCM_WVECT_WEAK_VALUE_P (ptr);

	  for (x = 0; x < len; ++x)
	    {
	      SCM alist;
	      alist = SCM_VELTS (ptr)[x];

	      /* mark everything on the alist except the keys or
	       * values, according to weak_values and weak_keys.  */
	      while (   SCM_CONSP (alist)
		     && !SCM_GC_MARK_P (alist)
		     && SCM_CONSP (SCM_CAR (alist)))
		{
		  SCM kvpair;
		  SCM next_alist;

		  kvpair = SCM_CAR (alist);
		  next_alist = SCM_CDR (alist);
		  /*
		   * Do not do this:
		   * 	SCM_SET_GC_MARK (alist);
		   *	SCM_SET_GC_MARK (kvpair);
		   *
		   * It may be that either the key or value is protected by
		   * an escaped reference to part of the spine of this alist.
		   * If we mark the spine here, and only mark one or neither of the
		   * key and value, they may never be properly marked.
		   * This leads to a horrible situation in which an alist containing
		   * freelist cells is exported.
		   *
		   * So only mark the spines of these arrays last of all marking.
		   * If somebody confuses us by constructing a weak vector
		   * with a circular alist then we are hosed, but at least we
		   * won't prematurely drop table entries.
		   */
		  if (!weak_keys)
		    scm_gc_mark (SCM_CAR (kvpair));
		  if (!weak_values)
		    scm_gc_mark (SCM_CDR (kvpair));
		  alist = next_alist;
		}
	      if (SCM_NIMP (alist))
		scm_gc_mark (alist);
	    }
	}
      break;

    case scm_tc7_symbol:
      ptr = SCM_PROP_SLOTS (ptr);
      goto gc_mark_loop;
    case scm_tc7_variable:
      ptr = SCM_CELL_OBJECT_1 (ptr);
      goto gc_mark_loop;
    case scm_tcs_subrs:
      break;
    case scm_tc7_port:
      i = SCM_PTOBNUM (ptr);
#if (SCM_DEBUG_CELL_ACCESSES == 1) 
      if (!(i < scm_numptob))
	{
	  fprintf (stderr, "undefined port type");
	  abort();
	}
#endif
      if (SCM_PTAB_ENTRY(ptr))
	scm_gc_mark (SCM_FILENAME (ptr));
      if (scm_ptobs[i].mark)
	{
	  ptr = (scm_ptobs[i].mark) (ptr);
	  goto gc_mark_loop;
	}
      else
	return;
      break;
    case scm_tc7_smob:
      switch (SCM_TYP16 (ptr))
	{ /* should be faster than going through scm_smobs */
	case scm_tc_free_cell:
	  /* We have detected a free cell.  This can happen if non-object data
	   * on the C stack points into guile's heap and is scanned during
	   * conservative marking.  */
	  break;
	default:
	  i = SCM_SMOBNUM (ptr);
#if (SCM_DEBUG_CELL_ACCESSES == 1)
	  if (!(i < scm_numsmob))
	    {
	      fprintf (stderr, "undefined smob type");
	      abort();
	    }
#endif
	  if (scm_smobs[i].mark)
	    {
	      ptr = (scm_smobs[i].mark) (ptr);
	      goto gc_mark_loop;
	    }
	  else
	    return;
	}
      break;
    default:
      fprintf (stderr, "unknown type");
      abort();
    }

  /*
    If we got here, then exhausted recursion options for PTR.  we
    return (careful not to mark PTR, it might be the argument that we
    were called with.)
   */
  return ;
  
gc_mark_loop:
  if (SCM_IMP (ptr))
    return;

 gc_mark_nimp:
  {
    int valid_cell = CELL_P (ptr);

    
#if (SCM_DEBUG_CELL_ACCESSES == 1)
    if (scm_debug_cell_accesses_p)
      {
    /* We are in debug mode.  Check the ptr exhaustively. */
	
	valid_cell = valid_cell && (scm_i_find_heap_segment_containing_object (ptr) >= 0);
      }
    
#endif
    if (!valid_cell)
      {
	fprintf (stderr, "rogue pointer in heap");
	abort();
      }
  }
  
 if (SCM_GC_MARK_P (ptr))
  {
    return;
  }
  
  SCM_SET_GC_MARK (ptr);

  goto   scm_mark_dependencies_again;
  
}
#undef FUNC_NAME


/* Mark a region conservatively */
void
scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
{
  unsigned long m;

  for (m = 0; m < n; ++m)
    {
      SCM obj = * (SCM *) &x[m];
      long int segment = scm_i_find_heap_segment_containing_object (obj);
      if (segment >= 0)
	scm_gc_mark (obj);
    }
}


/* The function scm_in_heap_p determines whether an SCM value can be regarded as a
 * pointer to a cell on the heap.
 */
int
scm_in_heap_p (SCM value)
{
  long int segment = scm_i_find_heap_segment_containing_object (value);
  return (segment >= 0);
}


#if SCM_ENABLE_DEPRECATED == 1

/* If an allocated cell is detected during garbage collection, this
 * means that some code has just obtained the object but was preempted
 * before the initialization of the object was completed.  This meanst
 * that some entries of the allocated cell may already contain SCM
 * objects.  Therefore, allocated cells are scanned conservatively.
 */

scm_t_bits scm_tc16_allocated;

static SCM
allocated_mark (SCM cell)
{
  unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell);
  unsigned int span = scm_i_heap_segment_table[cell_segment]->span;
  unsigned int i;

  for (i = 1; i != span * 2; ++i)
    {
      SCM obj = SCM_CELL_OBJECT (cell, i);
      long int obj_segment = scm_i_find_heap_segment_containing_object (obj);
      if (obj_segment >= 0)
	scm_gc_mark (obj);
    }
  return SCM_BOOL_F;
}

SCM
scm_deprecated_newcell (void)
{
  scm_c_issue_deprecation_warning 
    ("SCM_NEWCELL is deprecated.  Use `scm_cell' instead.\n");

  return scm_cell (scm_tc16_allocated, 0);
}

SCM
scm_deprecated_newcell2 (void)
{
  scm_c_issue_deprecation_warning 
    ("SCM_NEWCELL2 is deprecated.  Use `scm_double_cell' instead.\n");

  return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
}

#endif /* SCM_ENABLE_DEPRECATED == 1 */


void
scm_gc_init_mark(void)
{
#if SCM_ENABLE_DEPRECATED == 1
  scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
  scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
#endif
}
Commit	Line	Data
c35738c1	1	/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
c7743d02	2	*
73be1d9e MV	3	* This library is free software; you can redistribute it and/or
	4	* modify it under the terms of the GNU Lesser General Public
	5	* License as published by the Free Software Foundation; either
	6	* version 2.1 of the License, or (at your option) any later version.
c7743d02	7	*
73be1d9e	8	* This library is distributed in the hope that it will be useful,
c7743d02	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e MV	11	* Lesser General Public License for more details.
c7743d02	12	*
73be1d9e MV	13	* You should have received a copy of the GNU Lesser General Public
	14	* License along with this library; if not, write to the Free Software
	15	* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	16	*/
c7743d02 HWN	17
	18
	19	\f
3ba436c8 RB	20	#if HAVE_CONFIG_H
	21	# include <config.h>
	22	#endif
	23
c7743d02 HWN	24	#include <stdio.h>
	25	#include <errno.h>
	26	#include <string.h>
	27	#include <assert.h>
	28
	29	#ifdef __ia64__
	30	#include <ucontext.h>
	31	extern unsigned long * __libc_ia64_register_backing_store_base;
	32	#endif
	33
	34	#include "libguile/_scm.h"
	35	#include "libguile/eval.h"
	36	#include "libguile/stime.h"
	37	#include "libguile/stackchk.h"
	38	#include "libguile/struct.h"
	39	#include "libguile/smob.h"
	40	#include "libguile/unif.h"
	41	#include "libguile/async.h"
	42	#include "libguile/ports.h"
	43	#include "libguile/root.h"
	44	#include "libguile/strings.h"
	45	#include "libguile/vectors.h"
	46	#include "libguile/weaks.h"
	47	#include "libguile/hashtab.h"
	48	#include "libguile/tags.h"
	49	#include "libguile/private-gc.h"
	50	#include "libguile/validate.h"
	51	#include "libguile/deprecation.h"
	52	#include "libguile/gc.h"
	53
	54	#ifdef GUILE_DEBUG_MALLOC
	55	#include "libguile/debug-malloc.h"
	56	#endif
	57
	58	#ifdef HAVE_MALLOC_H
	59	#include <malloc.h>
	60	#endif
	61
	62	#ifdef HAVE_UNISTD_H
	63	#include <unistd.h>
	64	#endif
	65
c7743d02 HWN	66	#ifdef __ia64__
	67	# define SCM_MARK_BACKING_STORE() do { \
	68	ucontext_t ctx; \
	69	SCM_STACKITEM * top, * bot; \
	70	getcontext (&ctx); \
	71	scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
	72	((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
	73	/ sizeof (SCM_STACKITEM))); \
	74	bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
	75	top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
	76	scm_mark_locations (bot, top - bot); } while (0)
	77	#else
	78	# define SCM_MARK_BACKING_STORE()
	79	#endif
	80
eab1b259	81
c7743d02 HWN	82	/*
	83	Entry point for this file.
	84	*/
	85	void
	86	scm_mark_all (void)
	87	{
	88	long j;
eab1b259	89
c7743d02 HWN	90
c7743d02 HWN	91	scm_i_clear_mark_space ();
eab1b259	92
c7743d02 HWN	93	/* Mark every thread's stack and registers */
	94	scm_threads_mark_stacks ();
	95
c7743d02 HWN	96	j = SCM_NUM_PROTECTS;
	97	while (j--)
	98	scm_gc_mark (scm_sys_protects[j]);
	99
	100	/* mark the registered roots */
	101	{
	102	size_t i;
c35738c1	103	for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots); ++i)
c7743d02	104	{
c35738c1	105	SCM l = SCM_HASHTABLE_BUCKETS (scm_gc_registered_roots)[i];
c7743d02 HWN	106	for (; !SCM_NULLP (l); l = SCM_CDR (l))
	107	{
	108	SCM p = (SCM ) (scm_num2long (SCM_CAAR (l), 0, NULL));
	109	scm_gc_mark (*p);
	110	}
	111	}
	112	}
eab1b259	113
c7743d02 HWN	114
	115	/* FIXME: we should have a means to register C functions to be run
	116	* in different phases of GC
	117	*/
	118	scm_mark_subr_table ();
c7743d02 HWN	119	}
	120
	121	/* {Mark/Sweep}
	122	*/
	123
c7743d02 HWN	124	/*
	125	Mark an object precisely, then recurse.
	126	*/
	127	void
	128	scm_gc_mark (SCM ptr)
	129	{
	130	if (SCM_IMP (ptr))
45a1c3e8	131	return;
c7743d02 HWN	132
c7743d02 HWN	133	if (SCM_GC_MARK_P (ptr))
45a1c3e8	134	return;
c7743d02 HWN	135
	136	SCM_SET_GC_MARK (ptr);
	137	scm_gc_mark_dependencies (ptr);
	138	}
	139
	140	/*
	141
	142	Mark the dependencies of an object.
	143
33138b05	144	Prefetching:
c7743d02 HWN	145
	146	Should prefetch objects before marking, i.e. if marking a cell, we
	147	should prefetch the car, and then mark the cdr. This will improve CPU
	148	cache misses, because the car is more likely to be in core when we
	149	finish the cdr.
	150
	151	See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
	152	garbage collector cache misses.
	153
	154	Prefetch is supported on GCC >= 3.1
	155
33138b05 HWN	156	(Some time later.)
	157
	158	Tried this with GCC 3.1.1 -- the time differences are barely measurable.
	159	Perhaps this would work better with an explicit markstack?
	160
	161
	162	*/
c7743d02 HWN	163	void
	164	scm_gc_mark_dependencies (SCM p)
	165	#define FUNC_NAME "scm_gc_mark_dependencies"
	166	{
	167	register long i;
	168	register SCM ptr;
	169	scm_t_bits cell_type;
	170
	171	ptr = p;
	172	scm_mark_dependencies_again:
	173
	174	cell_type = SCM_GC_CELL_TYPE (ptr);
	175	switch (SCM_ITAG7 (cell_type))
	176	{
	177	case scm_tcs_cons_nimcar:
	178	if (SCM_IMP (SCM_CDR (ptr)))
	179	{
	180	ptr = SCM_CAR (ptr);
	181	goto gc_mark_nimp;
	182	}
33138b05 HWN	183
33138b05 HWN	184
c7743d02 HWN	185	scm_gc_mark (SCM_CAR (ptr));
	186	ptr = SCM_CDR (ptr);
	187	goto gc_mark_nimp;
	188	case scm_tcs_cons_imcar:
	189	ptr = SCM_CDR (ptr);
	190	goto gc_mark_loop;
	191	case scm_tc7_pws:
33138b05	192
c7743d02 HWN	193	scm_gc_mark (SCM_SETTER (ptr));
	194	ptr = SCM_PROCEDURE (ptr);
	195	goto gc_mark_loop;
	196	case scm_tcs_struct:
	197	{
	198	/* XXX - use less explicit code. */
	199	scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
	200	scm_t_bits * vtable_data = (scm_t_bits *) word0;
	201	SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
	202	long len = SCM_SYMBOL_LENGTH (layout);
	203	char * fields_desc = SCM_SYMBOL_CHARS (layout);
	204	scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
	205
	206	if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
	207	{
	208	scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
	209	scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
	210	}
	211	if (len)
	212	{
	213	long x;
	214
	215	for (x = 0; x < len - 2; x += 2, ++struct_data)
	216	if (fields_desc[x] == 'p')
	217	scm_gc_mark (SCM_PACK (*struct_data));
	218	if (fields_desc[x] == 'p')
	219	{
	220	if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
	221	for (x = *struct_data++; x; --x, ++struct_data)
	222	scm_gc_mark (SCM_PACK (*struct_data));
	223	else
	224	scm_gc_mark (SCM_PACK (*struct_data));
	225	}
	226	}
	227	/* mark vtable */
	228	ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
	229	goto gc_mark_loop;
	230	}
	231	break;
	232	case scm_tcs_closures:
	233	if (SCM_IMP (SCM_ENV (ptr)))
	234	{
	235	ptr = SCM_CLOSCAR (ptr);
	236	goto gc_mark_nimp;
	237	}
	238	scm_gc_mark (SCM_CLOSCAR (ptr));
	239	ptr = SCM_ENV (ptr);
	240	goto gc_mark_nimp;
	241	case scm_tc7_vector:
	242	i = SCM_VECTOR_LENGTH (ptr);
	243	if (i == 0)
	244	break;
	245	while (--i > 0)
33138b05 HWN	246	{
	247	if (SCM_NIMP (SCM_VELTS (ptr)[i]))
	248	scm_gc_mark (SCM_VELTS (ptr)[i]);
	249	}
c7743d02 HWN	250	ptr = SCM_VELTS (ptr)[0];
	251	goto gc_mark_loop;
	252	#ifdef CCLO
	253	case scm_tc7_cclo:
	254	{
	255	size_t i = SCM_CCLO_LENGTH (ptr);
	256	size_t j;
	257	for (j = 1; j != i; ++j)
	258	{
	259	SCM obj = SCM_CCLO_REF (ptr, j);
	260	if (!SCM_IMP (obj))
	261	scm_gc_mark (obj);
	262	}
	263	ptr = SCM_CCLO_REF (ptr, 0);
	264	goto gc_mark_loop;
	265	}
	266	#endif
25e789d5	267	#if SCM_HAVE_ARRAYS
c7743d02 HWN	268	case scm_tc7_bvect:
	269	case scm_tc7_byvect:
	270	case scm_tc7_ivect:
	271	case scm_tc7_uvect:
	272	case scm_tc7_fvect:
	273	case scm_tc7_dvect:
	274	case scm_tc7_cvect:
	275	case scm_tc7_svect:
3ba436c8	276	#if SCM_SIZEOF_LONG_LONG != 0
c7743d02 HWN	277	case scm_tc7_llvect:
	278	#endif
	279	#endif
	280	case scm_tc7_string:
	281	break;
	282
534c55a9 DH	283	case scm_tc7_number:
	284	break;
	285
c7743d02 HWN	286	case scm_tc7_wvect:
	287	SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors);
	288	scm_weak_vectors = ptr;
	289	if (SCM_IS_WHVEC_ANY (ptr))
	290	{
	291	long x;
	292	long len;
	293	int weak_keys;
	294	int weak_values;
	295
	296	len = SCM_VECTOR_LENGTH (ptr);
c35738c1 MD	297	weak_keys = SCM_WVECT_WEAK_KEY_P (ptr);
c35738c1 MD	298	weak_values = SCM_WVECT_WEAK_VALUE_P (ptr);
c7743d02 HWN	299
	300	for (x = 0; x < len; ++x)
	301	{
	302	SCM alist;
	303	alist = SCM_VELTS (ptr)[x];
	304
	305	/* mark everything on the alist except the keys or
	306	* values, according to weak_values and weak_keys. */
	307	while ( SCM_CONSP (alist)
	308	&& !SCM_GC_MARK_P (alist)
	309	&& SCM_CONSP (SCM_CAR (alist)))
	310	{
	311	SCM kvpair;
	312	SCM next_alist;
	313
	314	kvpair = SCM_CAR (alist);
	315	next_alist = SCM_CDR (alist);
	316	/*
	317	* Do not do this:
	318	* SCM_SET_GC_MARK (alist);
	319	* SCM_SET_GC_MARK (kvpair);
	320	*
	321	* It may be that either the key or value is protected by
	322	* an escaped reference to part of the spine of this alist.
	323	* If we mark the spine here, and only mark one or neither of the
	324	* key and value, they may never be properly marked.
	325	* This leads to a horrible situation in which an alist containing
	326	* freelist cells is exported.
	327	*
	328	* So only mark the spines of these arrays last of all marking.
	329	* If somebody confuses us by constructing a weak vector
	330	* with a circular alist then we are hosed, but at least we
	331	* won't prematurely drop table entries.
	332	*/
	333	if (!weak_keys)
	334	scm_gc_mark (SCM_CAR (kvpair));
	335	if (!weak_values)
	336	scm_gc_mark (SCM_CDR (kvpair));
	337	alist = next_alist;
	338	}
	339	if (SCM_NIMP (alist))
	340	scm_gc_mark (alist);
	341	}
	342	}
	343	break;
	344
	345	case scm_tc7_symbol:
	346	ptr = SCM_PROP_SLOTS (ptr);
	347	goto gc_mark_loop;
	348	case scm_tc7_variable:
	349	ptr = SCM_CELL_OBJECT_1 (ptr);
	350	goto gc_mark_loop;
	351	case scm_tcs_subrs:
	352	break;
	353	case scm_tc7_port:
	354	i = SCM_PTOBNUM (ptr);
	355	#if (SCM_DEBUG_CELL_ACCESSES == 1)
	356	if (!(i < scm_numptob))
be3ff021 HWN	357	{
	358	fprintf (stderr, "undefined port type");
	359	abort();
	360	}
c7743d02 HWN	361	#endif
	362	if (SCM_PTAB_ENTRY(ptr))
	363	scm_gc_mark (SCM_FILENAME (ptr));
	364	if (scm_ptobs[i].mark)
	365	{
	366	ptr = (scm_ptobs[i].mark) (ptr);
	367	goto gc_mark_loop;
	368	}
	369	else
	370	return;
	371	break;
	372	case scm_tc7_smob:
	373	switch (SCM_TYP16 (ptr))
	374	{ /* should be faster than going through scm_smobs */
	375	case scm_tc_free_cell:
	376	/* We have detected a free cell. This can happen if non-object data
	377	* on the C stack points into guile's heap and is scanned during
	378	* conservative marking. */
	379	break;
c7743d02 HWN	380	default:
	381	i = SCM_SMOBNUM (ptr);
	382	#if (SCM_DEBUG_CELL_ACCESSES == 1)
	383	if (!(i < scm_numsmob))
be3ff021 HWN	384	{
	385	fprintf (stderr, "undefined smob type");
	386	abort();
	387	}
c7743d02 HWN	388	#endif
	389	if (scm_smobs[i].mark)
	390	{
	391	ptr = (scm_smobs[i].mark) (ptr);
	392	goto gc_mark_loop;
	393	}
	394	else
	395	return;
	396	}
	397	break;
	398	default:
be3ff021 HWN	399	fprintf (stderr, "unknown type");
be3ff021 HWN	400	abort();
c7743d02 HWN	401	}
	402
	403	/*
	404	If we got here, then exhausted recursion options for PTR. we
	405	return (careful not to mark PTR, it might be the argument that we
	406	were called with.)
	407	*/
	408	return ;
	409
	410	gc_mark_loop:
	411	if (SCM_IMP (ptr))
	412	return;
	413
	414	gc_mark_nimp:
	415	{
	416	int valid_cell = CELL_P (ptr);
	417
	418
	419	#if (SCM_DEBUG_CELL_ACCESSES == 1)
	420	if (scm_debug_cell_accesses_p)
	421	{
	422	/* We are in debug mode. Check the ptr exhaustively. */
	423
	424	valid_cell = valid_cell && (scm_i_find_heap_segment_containing_object (ptr) >= 0);
	425	}
	426
	427	#endif
	428	if (!valid_cell)
be3ff021 HWN	429	{
	430	fprintf (stderr, "rogue pointer in heap");
	431	abort();
	432	}
c7743d02 HWN	433	}
	434
	435	if (SCM_GC_MARK_P (ptr))
eab1b259	436	{
c7743d02	437	return;
eab1b259 HWN	438	}
eab1b259 HWN	439
c7743d02	440	SCM_SET_GC_MARK (ptr);
eab1b259	441
c7743d02 HWN	442	goto scm_mark_dependencies_again;
	443
	444	}
	445	#undef FUNC_NAME
	446
	447
	448
eab1b259	449
c7743d02 HWN	450	/* Mark a region conservatively */
	451	void
	452	scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
	453	{
	454	unsigned long m;
	455
	456	for (m = 0; m < n; ++m)
	457	{
	458	SCM obj = * (SCM *) &x[m];
	459	long int segment = scm_i_find_heap_segment_containing_object (obj);
	460	if (segment >= 0)
	461	scm_gc_mark (obj);
	462	}
	463	}
	464
	465
	466	/* The function scm_in_heap_p determines whether an SCM value can be regarded as a
	467	* pointer to a cell on the heap.
	468	*/
	469	int
	470	scm_in_heap_p (SCM value)
	471	{
	472	long int segment = scm_i_find_heap_segment_containing_object (value);
	473	return (segment >= 0);
	474	}
	475
	476
	477	#if SCM_ENABLE_DEPRECATED == 1
	478
	479	/* If an allocated cell is detected during garbage collection, this
	480	* means that some code has just obtained the object but was preempted
	481	* before the initialization of the object was completed. This meanst
	482	* that some entries of the allocated cell may already contain SCM
	483	* objects. Therefore, allocated cells are scanned conservatively.
	484	*/
	485
	486	scm_t_bits scm_tc16_allocated;
	487
	488	static SCM
	489	allocated_mark (SCM cell)
	490	{
	491	unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell);
	492	unsigned int span = scm_i_heap_segment_table[cell_segment]->span;
	493	unsigned int i;
	494
	495	for (i = 1; i != span * 2; ++i)
	496	{
	497	SCM obj = SCM_CELL_OBJECT (cell, i);
	498	long int obj_segment = scm_i_find_heap_segment_containing_object (obj);
	499	if (obj_segment >= 0)
	500	scm_gc_mark (obj);
	501	}
	502	return SCM_BOOL_F;
	503	}
	504
	505	SCM
	506	scm_deprecated_newcell (void)
	507	{
	508	scm_c_issue_deprecation_warning
	509	("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n");
	510
	511	return scm_cell (scm_tc16_allocated, 0);
	512	}
	513
514	SCM
515	scm_deprecated_newcell2 (void)
516	{
517	scm_c_issue_deprecation_warning
518	("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n");
519
520	return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
521	}
522
523	#endif /* SCM_ENABLE_DEPRECATED == 1 */
524
525
526	void
527	scm_gc_init_mark(void)
528	{
529	#if SCM_ENABLE_DEPRECATED == 1
530	scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
531	scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
532	#endif
533	}
534