[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 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:
      if (SCM_TYP16 (ptr) == scm_tc16_fraction)
	{
	  scm_gc_mark (SCM_CELL_OBJECT_1 (ptr));
	  ptr = SCM_CELL_OBJECT_2 (ptr);
	  goto gc_mark_loop;
	}
      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;
702551e6	169	SCM cell_type;
c7743d02 HWN	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	283	case scm_tc7_number:
f92e85f7 MV	284	if (SCM_TYP16 (ptr) == scm_tc16_fraction)
	285	{
	286	scm_gc_mark (SCM_CELL_OBJECT_1 (ptr));
	287	ptr = SCM_CELL_OBJECT_2 (ptr);
	288	goto gc_mark_loop;
	289	}
534c55a9 DH	290	break;
534c55a9 DH	291
c7743d02 HWN	292	case scm_tc7_wvect:
	293	SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors);
	294	scm_weak_vectors = ptr;
	295	if (SCM_IS_WHVEC_ANY (ptr))
	296	{
	297	long x;
	298	long len;
	299	int weak_keys;
	300	int weak_values;
	301
	302	len = SCM_VECTOR_LENGTH (ptr);
c35738c1 MD	303	weak_keys = SCM_WVECT_WEAK_KEY_P (ptr);
c35738c1 MD	304	weak_values = SCM_WVECT_WEAK_VALUE_P (ptr);
c7743d02 HWN	305
	306	for (x = 0; x < len; ++x)
	307	{
	308	SCM alist;
	309	alist = SCM_VELTS (ptr)[x];
	310
	311	/* mark everything on the alist except the keys or
	312	* values, according to weak_values and weak_keys. */
	313	while ( SCM_CONSP (alist)
	314	&& !SCM_GC_MARK_P (alist)
	315	&& SCM_CONSP (SCM_CAR (alist)))
	316	{
	317	SCM kvpair;
	318	SCM next_alist;
	319
	320	kvpair = SCM_CAR (alist);
	321	next_alist = SCM_CDR (alist);
	322	/*
	323	* Do not do this:
	324	* SCM_SET_GC_MARK (alist);
	325	* SCM_SET_GC_MARK (kvpair);
	326	*
	327	* It may be that either the key or value is protected by
	328	* an escaped reference to part of the spine of this alist.
	329	* If we mark the spine here, and only mark one or neither of the
	330	* key and value, they may never be properly marked.
	331	* This leads to a horrible situation in which an alist containing
	332	* freelist cells is exported.
	333	*
	334	* So only mark the spines of these arrays last of all marking.
	335	* If somebody confuses us by constructing a weak vector
	336	* with a circular alist then we are hosed, but at least we
	337	* won't prematurely drop table entries.
	338	*/
	339	if (!weak_keys)
	340	scm_gc_mark (SCM_CAR (kvpair));
	341	if (!weak_values)
	342	scm_gc_mark (SCM_CDR (kvpair));
	343	alist = next_alist;
	344	}
	345	if (SCM_NIMP (alist))
	346	scm_gc_mark (alist);
	347	}
	348	}
	349	break;
	350
	351	case scm_tc7_symbol:
	352	ptr = SCM_PROP_SLOTS (ptr);
	353	goto gc_mark_loop;
	354	case scm_tc7_variable:
	355	ptr = SCM_CELL_OBJECT_1 (ptr);
	356	goto gc_mark_loop;
	357	case scm_tcs_subrs:
	358	break;
	359	case scm_tc7_port:
	360	i = SCM_PTOBNUM (ptr);
	361	#if (SCM_DEBUG_CELL_ACCESSES == 1)
	362	if (!(i < scm_numptob))
be3ff021 HWN	363	{
	364	fprintf (stderr, "undefined port type");
	365	abort();
	366	}
c7743d02 HWN	367	#endif
	368	if (SCM_PTAB_ENTRY(ptr))
	369	scm_gc_mark (SCM_FILENAME (ptr));
	370	if (scm_ptobs[i].mark)
	371	{
	372	ptr = (scm_ptobs[i].mark) (ptr);
	373	goto gc_mark_loop;
	374	}
	375	else
	376	return;
	377	break;
	378	case scm_tc7_smob:
	379	switch (SCM_TYP16 (ptr))
	380	{ /* should be faster than going through scm_smobs */
	381	case scm_tc_free_cell:
	382	/* We have detected a free cell. This can happen if non-object data
	383	* on the C stack points into guile's heap and is scanned during
	384	* conservative marking. */
	385	break;
c7743d02 HWN	386	default:
	387	i = SCM_SMOBNUM (ptr);
	388	#if (SCM_DEBUG_CELL_ACCESSES == 1)
	389	if (!(i < scm_numsmob))
be3ff021 HWN	390	{
	391	fprintf (stderr, "undefined smob type");
	392	abort();
	393	}
c7743d02 HWN	394	#endif
	395	if (scm_smobs[i].mark)
	396	{
	397	ptr = (scm_smobs[i].mark) (ptr);
	398	goto gc_mark_loop;
	399	}
	400	else
	401	return;
	402	}
	403	break;
	404	default:
be3ff021 HWN	405	fprintf (stderr, "unknown type");
be3ff021 HWN	406	abort();
c7743d02 HWN	407	}
	408
	409	/*
	410	If we got here, then exhausted recursion options for PTR. we
	411	return (careful not to mark PTR, it might be the argument that we
	412	were called with.)
	413	*/
	414	return ;
	415
	416	gc_mark_loop:
	417	if (SCM_IMP (ptr))
	418	return;
	419
	420	gc_mark_nimp:
	421	{
	422	int valid_cell = CELL_P (ptr);
	423
	424
	425	#if (SCM_DEBUG_CELL_ACCESSES == 1)
	426	if (scm_debug_cell_accesses_p)
	427	{
	428	/* We are in debug mode. Check the ptr exhaustively. */
	429
	430	valid_cell = valid_cell && (scm_i_find_heap_segment_containing_object (ptr) >= 0);
	431	}
	432
	433	#endif
	434	if (!valid_cell)
be3ff021 HWN	435	{
	436	fprintf (stderr, "rogue pointer in heap");
	437	abort();
	438	}
c7743d02 HWN	439	}
	440
	441	if (SCM_GC_MARK_P (ptr))
eab1b259	442	{
c7743d02	443	return;
eab1b259 HWN	444	}
eab1b259 HWN	445
c7743d02	446	SCM_SET_GC_MARK (ptr);
eab1b259	447
c7743d02 HWN	448	goto scm_mark_dependencies_again;
	449
	450	}
	451	#undef FUNC_NAME
	452
	453
	454
eab1b259	455
c7743d02 HWN	456	/* Mark a region conservatively */
	457	void
	458	scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
	459	{
	460	unsigned long m;
	461
	462	for (m = 0; m < n; ++m)
	463	{
	464	SCM obj = * (SCM *) &x[m];
	465	long int segment = scm_i_find_heap_segment_containing_object (obj);
	466	if (segment >= 0)
	467	scm_gc_mark (obj);
	468	}
	469	}
	470
	471
	472	/* The function scm_in_heap_p determines whether an SCM value can be regarded as a
	473	* pointer to a cell on the heap.
	474	*/
	475	int
	476	scm_in_heap_p (SCM value)
	477	{
	478	long int segment = scm_i_find_heap_segment_containing_object (value);
	479	return (segment >= 0);
	480	}
	481
	482
	483	#if SCM_ENABLE_DEPRECATED == 1
	484
	485	/* If an allocated cell is detected during garbage collection, this
	486	* means that some code has just obtained the object but was preempted
	487	* before the initialization of the object was completed. This meanst
	488	* that some entries of the allocated cell may already contain SCM
	489	* objects. Therefore, allocated cells are scanned conservatively.
	490	*/
	491
	492	scm_t_bits scm_tc16_allocated;
	493
	494	static SCM
	495	allocated_mark (SCM cell)
	496	{
	497	unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell);
	498	unsigned int span = scm_i_heap_segment_table[cell_segment]->span;
	499	unsigned int i;
	500
	501	for (i = 1; i != span * 2; ++i)
	502	{
	503	SCM obj = SCM_CELL_OBJECT (cell, i);
	504	long int obj_segment = scm_i_find_heap_segment_containing_object (obj);
	505	if (obj_segment >= 0)
	506	scm_gc_mark (obj);
	507	}
	508	return SCM_BOOL_F;
	509	}
	510
	511	SCM
	512	scm_deprecated_newcell (void)
	513	{
	514	scm_c_issue_deprecation_warning
	515	("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n");
	516
	517	return scm_cell (scm_tc16_allocated, 0);
	518	}
	519
520	SCM
521	scm_deprecated_newcell2 (void)
522	{
523	scm_c_issue_deprecation_warning
524	("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n");
525
526	return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
527	}
528
529	#endif /* SCM_ENABLE_DEPRECATED == 1 */
530
531
532	void
533	scm_gc_init_mark(void)
534	{
535	#if SCM_ENABLE_DEPRECATED == 1
536	scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
537	scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
538	#endif
539	}
540