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

/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */


#include <stdio.h>
#include <gmp.h>

#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/numbers.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"
#include "libguile/srfi-4.h"

#include "libguile/private-gc.h"

long int scm_i_deprecated_memory_return;


/* During collection, this accumulates structures which are to be freed.
 */
SCM scm_i_structs_to_free;


/*
  Init all the free cells in CARD, prepending to *FREE_LIST.

  Return: number of free cells found in this card.

  It would be cleaner to have a separate function sweep_value(), but
  that is too slow (functions with switch statements can't be
  inlined).


  NOTE:

  This function is quite efficient. However, for many types of cells,
  allocation and a de-allocation involves calling malloc() and
  free().

  This is costly for small objects (due to malloc/free overhead.)
  (should measure this).

  It might also be bad for threads: if several threads are allocating
  strings concurrently, then mallocs for both threads may have to
  fiddle with locks.

  It might be interesting to add a separate memory pool for small
  objects to each freelist.

  --hwn.
 */
int
scm_i_sweep_card (scm_t_cell *  p, SCM *free_list, scm_t_heap_segment*seg)
#define FUNC_NAME "sweep_card"
{
  scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
  scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
  int span = seg->span;
  int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
  int free_count  = 0;

  /*
    I tried something fancy with shifting by one bit every word from
    the bitvec in turn, but it wasn't any faster, but quite a bit
    hairier.
   */
  for (p += offset; p < end; p += span, offset += span)
    {
      SCM scmptr = PTR2SCM (p);
      if (SCM_C_BVEC_GET (bitvec, offset))
        continue;

      switch (SCM_TYP7 (scmptr))
	{
	case scm_tcs_struct:
	  /* The card can be swept more than once.  Check that it's
	   * the first time!
	   */
	  if (!SCM_STRUCT_GC_CHAIN (scmptr))
	    {
	      /* Structs need to be freed in a special order.
	       * This is handled by GC C hooks in struct.c.
	       */
	      SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
	      scm_i_structs_to_free = scmptr;
	    }
	  continue;
      
	case scm_tcs_cons_imcar:
	case scm_tcs_cons_nimcar:
	case scm_tcs_closures:
	case scm_tc7_pws:
	  break;
	case scm_tc7_wvect:
	case scm_tc7_vector:
	  scm_i_vector_free (scmptr);
	  break;

#ifdef CCLO
	case scm_tc7_cclo:
	  scm_gc_free (SCM_CCLO_BASE (scmptr), 
		       SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
		       "compiled closure");
	  break;
#endif

	case scm_tc7_number:
	  switch SCM_TYP16 (scmptr)
            {
            case scm_tc16_real:
              break;
            case scm_tc16_big:
              mpz_clear (SCM_I_BIG_MPZ (scmptr));
              /* nothing else to do here since the mpz is in a double cell */
              break;
	    case scm_tc16_complex:
	      scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
			   "complex");
	      break;
	    case scm_tc16_fraction:
	      /* nothing to do here since the num/denum of a fraction
		 are proper SCM objects themselves. */
	      break;
            }
          break;
	case scm_tc7_string:
	  scm_i_string_free (scmptr);
	  break;
	case scm_tc7_stringbuf:
	  scm_i_stringbuf_free (scmptr);
	  break;
	case scm_tc7_symbol:
	  scm_i_symbol_free (scmptr); 
	  break;
	case scm_tc7_variable:
	  break;
	case scm_tcs_subrs:
	  /* the various "subrs" (primitives) are never freed */
	  continue;
	case scm_tc7_port:
	  if SCM_OPENP (scmptr)
	    {
	      int k = SCM_PTOBNUM (scmptr);
	      size_t mm;
#if (SCM_DEBUG_CELL_ACCESSES == 1)
	      if (!(k < scm_numptob))
		{
		  fprintf (stderr, "undefined port type");
		  abort();
		}
#endif
	      /* Keep "revealed" ports alive.  */
	      if (scm_revealed_count (scmptr) > 0)
		continue;
	  
	      /* Yes, I really do mean scm_ptobs[k].free */
	      /* rather than ftobs[k].close.  .close */
	      /* is for explicit CLOSE-PORT by user */
	      mm = scm_ptobs[k].free (scmptr);

	      if (mm != 0)
		{
#if SCM_ENABLE_DEPRECATED == 1
		  scm_c_issue_deprecation_warning
		    ("Returning non-0 from a port free function is "
		     "deprecated.  Use scm_gc_free et al instead.");
		  scm_c_issue_deprecation_warning_fmt
		    ("(You just returned non-0 while freeing a %s.)",
		     SCM_PTOBNAME (k));
		  scm_i_deprecated_memory_return += mm;
#else
		  abort ();
#endif
		}

	      SCM_SETSTREAM (scmptr, 0);
	      scm_i_remove_port (scmptr);
	      SCM_CLR_PORT_OPEN_FLAG (scmptr);
	    }
	  break;
	case scm_tc7_smob:
	  switch SCM_TYP16 (scmptr)
	    {
	    case scm_tc_free_cell:
	      free_count --;
	      break;
	    default:
	      {
		int k;
		k = SCM_SMOBNUM (scmptr);
#if (SCM_DEBUG_CELL_ACCESSES == 1)
		if (!(k < scm_numsmob))
		  {
		    fprintf (stderr, "undefined smob type");
		    abort();
		  }
#endif
		if (scm_smobs[k].free)
		  {
		    size_t mm;
		    mm = scm_smobs[k].free (scmptr);
		    if (mm != 0)
		      {
#if SCM_ENABLE_DEPRECATED == 1
			scm_c_issue_deprecation_warning
			  ("Returning non-0 from a smob free function is "
			   "deprecated.  Use scm_gc_free et al instead.");
			scm_c_issue_deprecation_warning_fmt
			  ("(You just returned non-0 while freeing a %s.)",
			   SCM_SMOBNAME (k));
			scm_i_deprecated_memory_return += mm;
#else
			abort();
#endif
		      }
		  }
		break;
	      }
	    }
	  break;
	default:
	  fprintf (stderr, "unknown type");
	  abort();
	}

      SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);	  
      SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
      *free_list = scmptr;
      free_count ++;
    }

  return free_count;
}
#undef FUNC_NAME


/*
  Like sweep, but no complicated logic to do the sweeping.
 */
int
scm_i_init_card_freelist (scm_t_cell *  card, SCM *free_list,
			scm_t_heap_segment*seg)
{
  int span = seg->span;
  scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
  scm_t_cell *p = end - span;

  scm_t_c_bvec_long * bvec_ptr =  (scm_t_c_bvec_long* ) seg->bounds[1];
  int idx = (card  - seg->bounds[0]) / SCM_GC_CARD_N_CELLS; 

  bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
  SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
  
  /*
     ASSUMPTION: n_header_cells <= 2. 
   */
  for (; p > card;  p -= span)
    {
      const SCM scmptr = PTR2SCM (p);
      SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
      SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
      *free_list = scmptr;
    }

  return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
}


void
scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
{
  scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
  scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
  int span = seg->span;
  int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);

  if (!bitvec)
    /* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
    return;

  for (p += offset; p < end; p += span, offset += span)
    {
      scm_t_bits tag = -1;
      SCM scmptr = PTR2SCM (p);

      if (!SCM_C_BVEC_GET (bitvec, offset))
        continue;

      tag = SCM_TYP7 (scmptr);
      if (tag == scm_tc7_smob || tag == scm_tc7_number)
	{
          /* Record smobs and numbers under 16 bits of the tag, so the
             different smob objects are distinguished, and likewise the
             different numbers big, real, complex and fraction. */
	  tag = SCM_TYP16(scmptr);
	}
      else
	switch (tag) 
	{
	case scm_tcs_cons_imcar:
	  tag = scm_tc2_int;
	  break;
	case scm_tcs_cons_nimcar:
	  tag = scm_tc3_cons;
	  break;

	case scm_tcs_struct:
	  tag = scm_tc3_struct;
	  break;
	case scm_tcs_closures:
	  tag = scm_tc3_closure;
	  break;
	case scm_tcs_subrs:
	  tag = scm_tc7_asubr;
	  break;
	}

      {      
        SCM handle = scm_hashq_create_handle_x (hashtab,
                                                scm_from_int (tag), SCM_INUM0);
        SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
      }
    }
}

/* TAG is the tag word of a cell, return a string which is its name, or NULL
   if unknown.  Currently this is only used by gc-live-object-stats and the
   distinctions between types are oriented towards what that code records
   while scanning what's alive.  */
char const *
scm_i_tag_name (scm_t_bits tag)
{
  switch (tag & 0x7F) /* 7 bits */
    {
    case scm_tcs_struct:
      return "struct";
    case scm_tcs_cons_imcar:
      return "cons (immediate car)";
    case scm_tcs_cons_nimcar:
      return "cons (non-immediate car)";
    case scm_tcs_closures:
      return "closures";
    case scm_tc7_pws:
      return "pws";
    case scm_tc7_wvect:
      return "weak vector";
    case scm_tc7_vector:
      return "vector";
#ifdef CCLO
    case scm_tc7_cclo:
      return "compiled closure";
#endif
    case scm_tc7_number:
      switch (tag)
	{
	case scm_tc16_real:
	  return "real";
	case scm_tc16_big:
	  return "bignum";
	case scm_tc16_complex:
	  return "complex number";
	case scm_tc16_fraction:
	  return "fraction";
	}
      /* shouldn't reach here unless there's a new class of numbers */
      return "number";
    case scm_tc7_string:
      return "string";
    case scm_tc7_stringbuf:
      return "string buffer";
    case scm_tc7_symbol:
      return "symbol";
    case scm_tc7_variable:
      return "variable";
    case scm_tcs_subrs:
      return "subrs";
    case scm_tc7_port:
      return "port";
    case scm_tc7_smob:
      /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
         entry should be ok for our return here */
      return scm_smobs[SCM_TC2SMOBNUM(tag)].name;
    }

  return NULL;
}


#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)

typedef struct scm_dbg_t_list_cell {
  scm_t_bits car;  
  struct scm_dbg_t_list_cell * cdr;
} scm_dbg_t_list_cell;


typedef struct scm_dbg_t_double_cell {
  scm_t_bits word_0;
  scm_t_bits word_1;
  scm_t_bits word_2;
  scm_t_bits word_3;
} scm_dbg_t_double_cell;


int scm_dbg_gc_marked_p (SCM obj);
scm_t_cell * scm_dbg_gc_get_card (SCM obj);
scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);


int
scm_dbg_gc_marked_p (SCM obj)
{
  if (!SCM_IMP (obj))
    return SCM_GC_MARK_P(obj);
  else
    return 0;
}

scm_t_cell *
scm_dbg_gc_get_card (SCM obj)
{
  if (!SCM_IMP (obj))
    return SCM_GC_CELL_CARD(obj);
  else
    return NULL;
}

scm_t_c_bvec_long *
scm_dbg_gc_get_bvec (SCM obj)
{
  if (!SCM_IMP (obj))
    return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
  else
    return NULL;
}

#endif
Commit	Line	Data
8f3aa0bd	1	/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
c8a1bdc4	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.
c8a1bdc4	7	*
73be1d9e	8	* This library is distributed in the hope that it will be useful,
c8a1bdc4	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.
c8a1bdc4	12	*
73be1d9e MV	13	* You should have received a copy of the GNU Lesser General Public
73be1d9e MV	14	* License along with this library; if not, write to the Free Software
92205699	15	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
73be1d9e	16	*/
c8a1bdc4 HWN	17
c8a1bdc4 HWN	18
be3ff021	19	#include <stdio.h>
660e30c5	20	#include <gmp.h>
be3ff021	21
c8a1bdc4 HWN	22	#include "libguile/_scm.h"
c8a1bdc4 HWN	23	#include "libguile/eval.h"
29c4382a	24	#include "libguile/numbers.h"
c8a1bdc4 HWN	25	#include "libguile/stime.h"
	26	#include "libguile/stackchk.h"
	27	#include "libguile/struct.h"
	28	#include "libguile/smob.h"
	29	#include "libguile/unif.h"
	30	#include "libguile/async.h"
	31	#include "libguile/ports.h"
	32	#include "libguile/root.h"
	33	#include "libguile/strings.h"
	34	#include "libguile/vectors.h"
	35	#include "libguile/weaks.h"
	36	#include "libguile/hashtab.h"
	37	#include "libguile/tags.h"
	38	#include "libguile/private-gc.h"
	39	#include "libguile/validate.h"
	40	#include "libguile/deprecation.h"
	41	#include "libguile/gc.h"
d315ee57	42	#include "libguile/srfi-4.h"
c8a1bdc4 HWN	43
	44	#include "libguile/private-gc.h"
	45
	46	long int scm_i_deprecated_memory_return;
	47
	48
ffd72400 HWN	49	/* During collection, this accumulates structures which are to be freed.
	50	*/
	51	SCM scm_i_structs_to_free;
	52
	53
c8a1bdc4 HWN	54	/*
	55	Init all the free cells in CARD, prepending to *FREE_LIST.
	56
	57	Return: number of free cells found in this card.
	58
	59	It would be cleaner to have a separate function sweep_value(), but
	60	that is too slow (functions with switch statements can't be
	61	inlined).
06e80f59 HWN	62
	63
	64
c8a1bdc4	65
06e80f59 HWN	66	NOTE:
	67
	68	This function is quite efficient. However, for many types of cells,
	69	allocation and a de-allocation involves calling malloc() and
	70	free().
c8a1bdc4	71
06e80f59 HWN	72	This is costly for small objects (due to malloc/free overhead.)
	73	(should measure this).
	74
	75	It might also be bad for threads: if several threads are allocating
	76	strings concurrently, then mallocs for both threads may have to
	77	fiddle with locks.
	78
	79	It might be interesting to add a separate memory pool for small
	80	objects to each freelist.
	81
	82	--hwn.
	83	*/
c8a1bdc4	84	int
1383773b	85	scm_i_sweep_card (scm_t_cell * p, SCM free_list, scm_t_heap_segmentseg)
c8a1bdc4 HWN	86	#define FUNC_NAME "sweep_card"
	87	{
	88	scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
	89	scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
1383773b	90	int span = seg->span;
c8a1bdc4 HWN	91	int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
	92	int free_count = 0;
	93
	94	/*
	95	I tried something fancy with shifting by one bit every word from
dff96e95	96	the bitvec in turn, but it wasn't any faster, but quite a bit
c8a1bdc4 HWN	97	hairier.
	98	*/
	99	for (p += offset; p < end; p += span, offset += span)
	100	{
f96460ce	101	SCM scmptr = PTR2SCM (p);
c8a1bdc4 HWN	102	if (SCM_C_BVEC_GET (bitvec, offset))
	103	continue;
	104
	105	switch (SCM_TYP7 (scmptr))
	106	{
	107	case scm_tcs_struct:
b4a1358c MD	108	/* The card can be swept more than once. Check that it's
	109	* the first time!
	110	*/
f96460ce	111	if (!SCM_STRUCT_GC_CHAIN (scmptr))
b4a1358c MD	112	{
	113	/* Structs need to be freed in a special order.
	114	* This is handled by GC C hooks in struct.c.
	115	*/
f96460ce	116	SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
b4a1358c MD	117	scm_i_structs_to_free = scmptr;
b4a1358c MD	118	}
c8a1bdc4 HWN	119	continue;
	120
	121	case scm_tcs_cons_imcar:
	122	case scm_tcs_cons_nimcar:
	123	case scm_tcs_closures:
	124	case scm_tc7_pws:
	125	break;
	126	case scm_tc7_wvect:
	127	case scm_tc7_vector:
b8b154fd MV	128	scm_i_vector_free (scmptr);
	129	break;
	130
c8a1bdc4 HWN	131	#ifdef CCLO
	132	case scm_tc7_cclo:
	133	scm_gc_free (SCM_CCLO_BASE (scmptr),
	134	SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
	135	"compiled closure");
	136	break;
	137	#endif
b7a7750a	138
534c55a9 DH	139	case scm_tc7_number:
	140	switch SCM_TYP16 (scmptr)
	141	{
	142	case scm_tc16_real:
	143	break;
	144	case scm_tc16_big:
	145	mpz_clear (SCM_I_BIG_MPZ (scmptr));
	146	/* nothing else to do here since the mpz is in a double cell */
	147	break;
	148	case scm_tc16_complex:
	149	scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
	150	"complex");
	151	break;
f92e85f7 MV	152	case scm_tc16_fraction:
	153	/* nothing to do here since the num/denum of a fraction
	154	are proper SCM objects themselves. */
	155	break;
534c55a9 DH	156	}
534c55a9 DH	157	break;
c8a1bdc4	158	case scm_tc7_string:
eb01cb64 MV	159	scm_i_string_free (scmptr);
	160	break;
	161	case scm_tc7_stringbuf:
	162	scm_i_stringbuf_free (scmptr);
c8a1bdc4 HWN	163	break;
c8a1bdc4 HWN	164	case scm_tc7_symbol:
eb01cb64	165	scm_i_symbol_free (scmptr);
c8a1bdc4 HWN	166	break;
	167	case scm_tc7_variable:
	168	break;
	169	case scm_tcs_subrs:
	170	/* the various "subrs" (primitives) are never freed */
	171	continue;
	172	case scm_tc7_port:
	173	if SCM_OPENP (scmptr)
	174	{
	175	int k = SCM_PTOBNUM (scmptr);
	176	size_t mm;
	177	#if (SCM_DEBUG_CELL_ACCESSES == 1)
	178	if (!(k < scm_numptob))
be3ff021 HWN	179	{
	180	fprintf (stderr, "undefined port type");
	181	abort();
	182	}
c8a1bdc4 HWN	183	#endif
	184	/* Keep "revealed" ports alive. */
	185	if (scm_revealed_count (scmptr) > 0)
	186	continue;
	187
	188	/* Yes, I really do mean scm_ptobs[k].free */
	189	/* rather than ftobs[k].close. .close */
	190	/* is for explicit CLOSE-PORT by user */
	191	mm = scm_ptobs[k].free (scmptr);
	192
	193	if (mm != 0)
	194	{
	195	#if SCM_ENABLE_DEPRECATED == 1
	196	scm_c_issue_deprecation_warning
	197	("Returning non-0 from a port free function is "
	198	"deprecated. Use scm_gc_free et al instead.");
	199	scm_c_issue_deprecation_warning_fmt
	200	("(You just returned non-0 while freeing a %s.)",
	201	SCM_PTOBNAME (k));
	202	scm_i_deprecated_memory_return += mm;
	203	#else
	204	abort ();
	205	#endif
	206	}
	207
	208	SCM_SETSTREAM (scmptr, 0);
5dbc6c06	209	scm_i_remove_port (scmptr);
c8a1bdc4 HWN	210	SCM_CLR_PORT_OPEN_FLAG (scmptr);
	211	}
	212	break;
	213	case scm_tc7_smob:
	214	switch SCM_TYP16 (scmptr)
	215	{
	216	case scm_tc_free_cell:
2ca2ffe6	217	free_count --;
c8a1bdc4 HWN	218	break;
	219	default:
	220	{
	221	int k;
	222	k = SCM_SMOBNUM (scmptr);
	223	#if (SCM_DEBUG_CELL_ACCESSES == 1)
	224	if (!(k < scm_numsmob))
be3ff021 HWN	225	{
	226	fprintf (stderr, "undefined smob type");
	227	abort();
	228	}
c8a1bdc4 HWN	229	#endif
	230	if (scm_smobs[k].free)
	231	{
	232	size_t mm;
	233	mm = scm_smobs[k].free (scmptr);
	234	if (mm != 0)
	235	{
	236	#if SCM_ENABLE_DEPRECATED == 1
	237	scm_c_issue_deprecation_warning
	238	("Returning non-0 from a smob free function is "
	239	"deprecated. Use scm_gc_free et al instead.");
	240	scm_c_issue_deprecation_warning_fmt
	241	("(You just returned non-0 while freeing a %s.)",
	242	SCM_SMOBNAME (k));
	243	scm_i_deprecated_memory_return += mm;
	244	#else
	245	abort();
	246	#endif
	247	}
	248	}
	249	break;
	250	}
	251	}
	252	break;
	253	default:
be3ff021 HWN	254	fprintf (stderr, "unknown type");
be3ff021 HWN	255	abort();
c8a1bdc4 HWN	256	}
c8a1bdc4 HWN	257
726f82e7	258	SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
f96460ce DH	259	SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
f96460ce DH	260	*free_list = scmptr;
c8a1bdc4 HWN	261	free_count ++;
c8a1bdc4 HWN	262	}
eab1b259	263
c8a1bdc4 HWN	264	return free_count;
	265	}
	266	#undef FUNC_NAME
	267
	268
	269	/*
	270	Like sweep, but no complicated logic to do the sweeping.
	271	*/
	272	int
1383773b HWN	273	scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,
1383773b HWN	274	scm_t_heap_segment*seg)
c8a1bdc4	275	{
1383773b	276	int span = seg->span;
c8a1bdc4 HWN	277	scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
	278	scm_t_cell *p = end - span;
	279
1383773b HWN	280	scm_t_c_bvec_long * bvec_ptr = (scm_t_c_bvec_long* ) seg->bounds[1];
	281	int idx = (card - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
	282
	283	bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
c5b0618d	284	SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
1383773b	285
c8a1bdc4 HWN	286	/*
	287	ASSUMPTION: n_header_cells <= 2.
	288	*/
	289	for (; p > card; p -= span)
	290	{
f96460ce	291	const SCM scmptr = PTR2SCM (p);
726f82e7	292	SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
f96460ce DH	293	SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
f96460ce DH	294	*free_list = scmptr;
c8a1bdc4 HWN	295	}
	296
	297	return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
	298	}
	299
	300
1367aa5e HWN	301	void
	302	scm_i_card_statistics (scm_t_cell p, SCM hashtab, scm_t_heap_segment seg)
	303	{
	304	scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
	305	scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
	306	int span = seg->span;
	307	int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
	308
9fb5c8f9 NJ	309	if (!bitvec)
	310	/* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
	311	return;
	312
1367aa5e HWN	313	for (p += offset; p < end; p += span, offset += span)
1367aa5e HWN	314	{
8fecbb19	315	scm_t_bits tag = -1;
1367aa5e	316	SCM scmptr = PTR2SCM (p);
b01532af	317
1367aa5e HWN	318	if (!SCM_C_BVEC_GET (bitvec, offset))
	319	continue;
	320
b01532af	321	tag = SCM_TYP7 (scmptr);
8f3aa0bd	322	if (tag == scm_tc7_smob \|\| tag == scm_tc7_number)
1367aa5e	323	{
8f3aa0bd KR	324	/* Record smobs and numbers under 16 bits of the tag, so the
	325	different smob objects are distinguished, and likewise the
	326	different numbers big, real, complex and fraction. */
1367aa5e HWN	327	tag = SCM_TYP16(scmptr);
	328	}
	329	else
	330	switch (tag)
	331	{
	332	case scm_tcs_cons_imcar:
	333	tag = scm_tc2_int;
	334	break;
	335	case scm_tcs_cons_nimcar:
	336	tag = scm_tc3_cons;
	337	break;
856fca7e HWN	338
	339	case scm_tcs_struct:
	340	tag = scm_tc3_struct;
	341	break;
	342	case scm_tcs_closures:
	343	tag = scm_tc3_closure;
	344	break;
	345	case scm_tcs_subrs:
	346	tag = scm_tc7_asubr;
	347	break;
1367aa5e	348	}
1367aa5e	349
b01532af	350	{
8f3aa0bd KR	351	SCM handle = scm_hashq_create_handle_x (hashtab,
	352	scm_from_int (tag), SCM_INUM0);
	353	SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
b01532af	354	}
1367aa5e HWN	355	}
	356	}
	357
8f3aa0bd KR	358	/* TAG is the tag word of a cell, return a string which is its name, or NULL
	359	if unknown. Currently this is only used by gc-live-object-stats and the
	360	distinctions between types are oriented towards what that code records
	361	while scanning what's alive. */
1367aa5e HWN	362	char const *
	363	scm_i_tag_name (scm_t_bits tag)
	364	{
8f3aa0bd	365	switch (tag & 0x7F) /* 7 bits */
1367aa5e HWN	366	{
	367	case scm_tcs_struct:
	368	return "struct";
	369	case scm_tcs_cons_imcar:
	370	return "cons (immediate car)";
	371	case scm_tcs_cons_nimcar:
	372	return "cons (non-immediate car)";
	373	case scm_tcs_closures:
	374	return "closures";
	375	case scm_tc7_pws:
	376	return "pws";
	377	case scm_tc7_wvect:
	378	return "weak vector";
	379	case scm_tc7_vector:
	380	return "vector";
	381	#ifdef CCLO
	382	case scm_tc7_cclo:
	383	return "compiled closure";
	384	#endif
	385	case scm_tc7_number:
	386	switch (tag)
	387	{
	388	case scm_tc16_real:
	389	return "real";
1367aa5e HWN	390	case scm_tc16_big:
1367aa5e HWN	391	return "bignum";
1367aa5e HWN	392	case scm_tc16_complex:
1367aa5e HWN	393	return "complex number";
1367aa5e HWN	394	case scm_tc16_fraction:
1367aa5e HWN	395	return "fraction";
1367aa5e	396	}
8f3aa0bd KR	397	/* shouldn't reach here unless there's a new class of numbers */
8f3aa0bd KR	398	return "number";
1367aa5e HWN	399	case scm_tc7_string:
1367aa5e HWN	400	return "string";
1367aa5e HWN	401	case scm_tc7_stringbuf:
1367aa5e HWN	402	return "string buffer";
1367aa5e HWN	403	case scm_tc7_symbol:
1367aa5e HWN	404	return "symbol";
1367aa5e HWN	405	case scm_tc7_variable:
1367aa5e HWN	406	return "variable";
1367aa5e HWN	407	case scm_tcs_subrs:
1367aa5e HWN	408	return "subrs";
1367aa5e HWN	409	case scm_tc7_port:
1367aa5e HWN	410	return "port";
1367aa5e	411	case scm_tc7_smob:
8f3aa0bd KR	412	/* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
	413	entry should be ok for our return here */
	414	return scm_smobs[SCM_TC2SMOBNUM(tag)].name;
1367aa5e HWN	415	}
1367aa5e HWN	416
73a4c24e	417	return NULL;
1367aa5e HWN	418	}
	419
	420
d0624e39	421	#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
c8a1bdc4	422
94fb5a6e	423	typedef struct scm_dbg_t_list_cell {
c8a1bdc4	424	scm_t_bits car;
94fb5a6e DH	425	struct scm_dbg_t_list_cell * cdr;
94fb5a6e DH	426	} scm_dbg_t_list_cell;
c8a1bdc4	427
eab1b259	428
94fb5a6e	429	typedef struct scm_dbg_t_double_cell {
eab1b259 HWN	430	scm_t_bits word_0;
	431	scm_t_bits word_1;
	432	scm_t_bits word_2;
	433	scm_t_bits word_3;
94fb5a6e	434	} scm_dbg_t_double_cell;
eab1b259 HWN	435
eab1b259 HWN	436
94fb5a6e DH	437	int scm_dbg_gc_marked_p (SCM obj);
94fb5a6e DH	438	scm_t_cell * scm_dbg_gc_get_card (SCM obj);
f71e4d8c	439	scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);
94fb5a6e DH	440
	441
	442	int
	443	scm_dbg_gc_marked_p (SCM obj)
	444	{
	445	if (!SCM_IMP (obj))
	446	return SCM_GC_MARK_P(obj);
	447	else
	448	return 0;
	449	}
c8a1bdc4 HWN	450
c8a1bdc4 HWN	451	scm_t_cell *
94fb5a6e	452	scm_dbg_gc_get_card (SCM obj)
c8a1bdc4	453	{
94fb5a6e DH	454	if (!SCM_IMP (obj))
	455	return SCM_GC_CELL_CARD(obj);
	456	else
	457	return NULL;
c8a1bdc4 HWN	458	}
c8a1bdc4 HWN	459
f71e4d8c	460	scm_t_c_bvec_long *
94fb5a6e	461	scm_dbg_gc_get_bvec (SCM obj)
c8a1bdc4	462	{
94fb5a6e DH	463	if (!SCM_IMP (obj))
	464	return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
	465	else
	466	return NULL;
c8a1bdc4	467	}
94fb5a6e	468
c8a1bdc4	469	#endif