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

/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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 ();
  
#ifndef USE_THREADS

  /* Mark objects on the C stack. */
  SCM_FLUSH_REGISTER_WINDOWS;
  /* This assumes that all registers are saved into the jmp_buf */
  setjmp (scm_save_regs_gc_mark);
  scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
		      (   (size_t) (sizeof (SCM_STACKITEM) - 1 +
				       sizeof scm_save_regs_gc_mark)
			  / sizeof (SCM_STACKITEM)));

  {
    unsigned long stack_len = scm_stack_size (scm_stack_base);
#ifdef SCM_STACK_GROWS_UP
    scm_mark_locations (scm_stack_base, stack_len);
#else
    scm_mark_locations (scm_stack_base - stack_len, stack_len);
#endif
  }
  SCM_MARK_BACKING_STORE();

#else /* USE_THREADS */

  /* Mark every thread's stack and registers */
  scm_threads_mark_stacks ();

#endif /* USE_THREADS */

  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_VECTOR_LENGTH (scm_gc_registered_roots); ++i)
      {
	SCM l = SCM_VELTS (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 ();


#ifndef USE_THREADS
  scm_gc_mark (scm_root->handle);
#endif
}

/* {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_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr);
	  weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (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))
	SCM_MISC_ERROR ("undefined port type", SCM_EOL);
#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))
	    SCM_MISC_ERROR ("undefined smob type", SCM_EOL);
#endif
	  if (scm_smobs[i].mark)
	    {
	      ptr = (scm_smobs[i].mark) (ptr);
	      goto gc_mark_loop;
	    }
	  else
	    return;
	}
      break;
    default:
      SCM_MISC_ERROR ("unknown type", SCM_EOL);
    }

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