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