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

/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 Free Software Foundation, Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * This program 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 General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA 02111-1307 USA
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  */


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