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

/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006 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 <assert.h> 
#include <stdio.h>
#include <string.h>

#include "libguile/_scm.h"
#include "libguile/pairs.h"
#include "libguile/gc.h"
#include "libguile/private-gc.h"


size_t scm_max_segment_size;

scm_t_heap_segment *
scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl)
{
  scm_t_heap_segment * shs = malloc (sizeof (scm_t_heap_segment));

  if (!shs)
    {
      fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n");
      abort ();
    }
  
  shs->bounds[0] = NULL;
  shs->bounds[1] = NULL;
  shs->malloced = NULL;
  shs->span = fl->span;
  shs->freelist  = fl;
  shs->next_free_card = NULL;
  
  return shs;
}


void
scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab)
{
  scm_t_cell *p = seg->bounds[0];
  while (p <  seg->bounds[1])
    {
      scm_i_card_statistics (p, tab, seg); 
      p += SCM_GC_CARD_N_CELLS;
    }
}


/*
  Fill SEGMENT with memory both for data and mark bits.

  RETURN:  1 on success, 0 failure  
 */
int 
scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested)
{
  /*
    round upwards
   */
  int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
  int card_count =1 + (requested / sizeof (scm_t_cell)) /  card_data_cell_count; 

  /*
    one card extra due to alignment
  */
  size_t mem_needed = (1+card_count) * SCM_GC_SIZEOF_CARD
    + SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG
    ;
  scm_t_c_bvec_long * bvec_ptr = 0;
  scm_t_cell *  memory = 0;

  /*
    We use calloc to alloc the heap. On GNU libc this is 
    equivalent to mmapping /dev/zero
   */
  SCM_SYSCALL (memory = (scm_t_cell * ) calloc (1, mem_needed));

  if (memory == NULL)
    return 0;

  segment->malloced = memory;
  segment->bounds[0] = SCM_GC_CARD_UP (memory);
  segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS;

  segment->freelist->heap_size += scm_i_segment_cell_count (segment);
  
  bvec_ptr = (scm_t_c_bvec_long*) segment->bounds[1];

  /*
    Don't init the mem or the bitvector. This is handled by lazy
    sweeping.
  */
  
  segment->next_free_card = segment->bounds[0];
  segment->first_time = 1;
  return 1;
}

int
scm_i_segment_card_count (scm_t_heap_segment * seg)
{
  return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
}

/*
  Return the number of available single-cell data cells. 
 */
int
scm_i_segment_cell_count (scm_t_heap_segment * seg)
{
  return scm_i_segment_card_count (seg) * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
    + ((seg->span == 2) ? -1 : 0);
}

void
scm_i_clear_segment_mark_space (scm_t_heap_segment *seg)
{
  scm_t_cell *  markspace = seg->bounds[1];

  memset (markspace, 0x00,
	  scm_i_segment_card_count (seg) *  SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG);
}

/* Sweep cards from SEG until we've gathered THRESHOLD cells.  On return,
   SWEEP_STATS contains the number of cells that have been visited and
   collected.  A freelist is returned, potentially empty.  */
SCM
scm_i_sweep_some_cards (scm_t_heap_segment *seg,
			scm_t_sweep_statistics *sweep_stats)
{
  SCM cells = SCM_EOL;
  int threshold = 512;
  int collected = 0;
  int (*sweeper) (scm_t_cell *, SCM *, scm_t_heap_segment* )
    = (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card;

  scm_t_cell * next_free = seg->next_free_card;
  int cards_swept = 0;

  while (collected < threshold && next_free < seg->bounds[1])
    {
      collected += (*sweeper) (next_free, &cells, seg);
      next_free += SCM_GC_CARD_N_CELLS;
      cards_swept ++;
    }

  sweep_stats->swept = cards_swept * seg->span
    * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);

  if (!seg->first_time)
    {
      /* scm_cells_allocated -= collected * seg->span; */
      sweep_stats->collected = collected * seg->span;
    }
  else
    sweep_stats->collected = 0;

  seg->freelist->collected += collected * seg->span;

  if(next_free == seg->bounds[1])
    {
      seg->first_time = 0;
    }

  seg->next_free_card = next_free;
  return cells;
}


/*
  Force a sweep of this entire segment. This doesn't modify sweep
  statistics, it just frees the memory pointed to by to-be-swept
  cells.

  Implementation is slightly ugh.

  FIXME: if you do scm_i_sweep_segment(), and then allocate from this
  segment again, the statistics are off.
 */
void
scm_i_sweep_segment (scm_t_heap_segment *seg,
		     scm_t_sweep_statistics *sweep_stats)
{
  scm_t_sweep_statistics sweep;
  scm_t_cell * p = seg->next_free_card;

  scm_i_sweep_statistics_init (sweep_stats);

  scm_i_sweep_statistics_init (&sweep);
  while (scm_i_sweep_some_cards (seg, &sweep) != SCM_EOL)
    {
      scm_i_sweep_statistics_sum (sweep_stats, sweep);
      scm_i_sweep_statistics_init (&sweep);
    }

  seg->next_free_card =p;
}

void
scm_i_sweep_all_segments (char const *reason,
			  scm_t_sweep_statistics *sweep_stats)
{
  unsigned i= 0;

  scm_i_sweep_statistics_init (sweep_stats);
  for (i = 0; i < scm_i_heap_segment_table_size; i++)
    {
      scm_t_sweep_statistics sweep;

      scm_i_sweep_segment (scm_i_heap_segment_table[i], &sweep);
      scm_i_sweep_statistics_sum (sweep_stats, sweep);
    }
}


/*
  Heap segment table.

  The table is sorted by the address of the data itself. This makes
  for easy lookups. This is not portable: according to ANSI C,
  pointers can only be compared within the same object (i.e. the same
  block of malloced memory.). For machines with weird architectures,
  this should be revised.
  
  (Apparently, for this reason 1.6 and earlier had macros for pointer
  comparison. )
  
  perhaps it is worthwhile to remove the 2nd level of indirection in
  the table, but this certainly makes for cleaner code.
*/
scm_t_heap_segment ** scm_i_heap_segment_table;
size_t scm_i_heap_segment_table_size;
scm_t_cell *lowest_cell;
scm_t_cell *highest_cell; 


void
scm_i_clear_mark_space (void)
{
  int i = 0;
  for (; i < scm_i_heap_segment_table_size; i++)
    {
      scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]);
    }
}


/*
  RETURN: index of inserted segment.
 */
int
scm_i_insert_segment (scm_t_heap_segment * seg)
{
  size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *);
  SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **)
			       realloc ((char *)scm_i_heap_segment_table, size)));

  /*
    We can't alloc 4 more bytes. This is hopeless.
   */
  if (!scm_i_heap_segment_table)
    {
      fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n");
      abort ();
    }

  if (!lowest_cell)
    {
      lowest_cell = seg->bounds[0];
      highest_cell = seg->bounds[1];
    }
  else
    {
      lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]);
      highest_cell = SCM_MAX (highest_cell, seg->bounds[1]);
    }


  {
    int i = 0;
    int j = 0;

    while (i < scm_i_heap_segment_table_size
	   && scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0])
      i++;

    /*
      We insert a new entry; if that happens to be before the
      "current" segment of a freelist, we must move the freelist index
      as well.
    */
    if (scm_i_master_freelist.heap_segment_idx >= i)
      scm_i_master_freelist.heap_segment_idx ++;
    if (scm_i_master_freelist2.heap_segment_idx >= i)
      scm_i_master_freelist2.heap_segment_idx ++;

    for (j = scm_i_heap_segment_table_size; j > i; --j)
      scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1];

    scm_i_heap_segment_table [i] = seg;
    scm_i_heap_segment_table_size ++;

    return i;
  }
}

SCM
scm_i_sweep_some_segments (scm_t_cell_type_statistics *fl,
			   scm_t_sweep_statistics *sweep_stats)
{
  int i = fl->heap_segment_idx;
  SCM collected = SCM_EOL;

  scm_i_sweep_statistics_init (sweep_stats);
  if (i == -1)
    i++;

  for (;
       i < scm_i_heap_segment_table_size; i++)
    {
      scm_t_sweep_statistics sweep;

      if (scm_i_heap_segment_table[i]->freelist != fl)
	continue;

      scm_i_sweep_statistics_init (&sweep);
      collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i],
					  &sweep);

      scm_i_sweep_statistics_sum (sweep_stats, sweep);

      if (collected != SCM_EOL)       /* Don't increment i */
	break;
    }

  fl->heap_segment_idx = i;

  return collected;
}


void
scm_i_reset_segments (void)
{
  int i = 0;
  for (; i < scm_i_heap_segment_table_size; i++)
    {
      scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
      seg->next_free_card = seg->bounds[0];
    }
}

/*
  Return a hashtab with counts of live objects, with tags as keys.
 */


SCM
scm_i_all_segments_statistics (SCM tab)
{
  int i = 0;
  for (; i < scm_i_heap_segment_table_size; i++)
    {
      scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
      scm_i_heap_segment_statistics (seg, tab);
    }

  return tab;
}


/*
  Determine whether the given value does actually represent a cell in
  some heap segment.  If this is the case, the number of the heap
  segment is returned.  Otherwise, -1 is returned.  Binary search is
  used to determine the heap segment that contains the cell.


  I think this function is too long to be inlined. --hwn
*/
long int
scm_i_find_heap_segment_containing_object (SCM obj)
{
  if (!CELL_P (obj))
    return -1;

  if ((scm_t_cell* ) obj < lowest_cell || (scm_t_cell*) obj >= highest_cell)
    return -1;

  
    {
      scm_t_cell *  ptr = SCM2PTR (obj);
      unsigned long int i = 0;
      unsigned long int j = scm_i_heap_segment_table_size - 1;

      if (ptr < scm_i_heap_segment_table[i]->bounds[0])
	return -1;
      else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
	return -1;
      else
	{
	  while (i < j)
	    {
	      if (ptr < scm_i_heap_segment_table[i]->bounds[1])
		{
		  break;
		}
	      else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr)
		{
		  i = j;
		  break;
		}
	      else
		{
		  unsigned long int k = (i + j) / 2;

		  if (k == i)
		    return -1;
		  else if (ptr <  scm_i_heap_segment_table[k]->bounds[1])
		    {
		      j = k;
		      ++i;
		      if (ptr <  scm_i_heap_segment_table[i]->bounds[0])
			return -1;
		    }
		  else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr)
		    {
		      i = k;
		      --j;
		      if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
			return -1;
		    }
		}
	    }

	  if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2)
	    return -1;
	  else if (SCM_GC_IN_CARD_HEADERP (ptr))
	    return -1;
	  else
	    return i;
	}
    }
}


/* Important entry point: try to grab some memory, and make it into a
   segment; return the index of the segment.  SWEEP_STATS should contain
   global GC sweep statistics collected since the last full GC.  */
int
scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
			    scm_t_sweep_statistics sweep_stats,
			    policy_on_error error_policy)
{
  size_t len;

  {
    /* Assure that the new segment is predicted to be large enough.
     *
     * New yield should at least equal GC fraction of new heap size, i.e.
     *
     *   y + dh > f * (h + dh)
     *
     *    y : yield
     *    f : min yield fraction
     *    h : heap size
     *   dh : size of new heap segment
     *
     * This gives dh > (f * h - y) / (1 - f)
     */
    float f = freelist->min_yield_fraction / 100.0;
    float h = SCM_HEAP_SIZE;
    float min_cells = (f * h - sweep_stats.collected) / (1.0 - f);

    /* Make heap grow with factor 1.5 */
    len =  freelist->heap_size / 2;
#ifdef DEBUGINFO
    fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
#endif

    if (len < min_cells)
      len = (unsigned long) min_cells;  
    len *= sizeof (scm_t_cell);
    /* force new sampling */
    freelist->collected = LONG_MAX;
  }

  if (len > scm_max_segment_size)
    len = scm_max_segment_size;
  if (len < SCM_MIN_HEAP_SEG_SIZE)
    len = SCM_MIN_HEAP_SEG_SIZE;

  {
    scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);

    /* Allocate with decaying ambition. */
    while (len >= SCM_MIN_HEAP_SEG_SIZE)
      {
	if (scm_i_initialize_heap_segment_data (seg, len))
	  {
	    return scm_i_insert_segment (seg);
	  }
	
	len /= 2;
      }
  }

  if (error_policy == abort_on_error)
    {
      fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n");
      abort ();
    }
  return -1;
}

void
scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist)
{
  scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);

  if (init_heap_size < 1)
    {
      init_heap_size =  SCM_DEFAULT_INIT_HEAP_SIZE_1;
    }
 
  if (scm_i_initialize_heap_segment_data (seg, init_heap_size))
    {
      freelist->heap_segment_idx = scm_i_insert_segment (seg);
    }

  /*
    Why the fuck  try twice? --hwn
   */
  if (!seg->malloced)
    {
      scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE);
    }

  if (freelist->min_yield_fraction)
    freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
			    / 100);
}
Commit	Line	Data
2b829bbb	1	/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006 Free Software Foundation, Inc.
c7743d02	2	*
73be1d9e MV	3	* This library is free software; you can redistribute it and/or
	4	* modify it under the terms of the GNU Lesser General Public
	5	* License as published by the Free Software Foundation; either
	6	* version 2.1 of the License, or (at your option) any later version.
c7743d02	7	*
73be1d9e	8	* This library is distributed in the hope that it will be useful,
c7743d02	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e MV	11	* Lesser General Public License for more details.
c7743d02	12	*
73be1d9e MV	13	* You should have received a copy of the GNU Lesser General Public
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	*/
c7743d02 HWN	17
	18	#include <assert.h>
	19	#include <stdio.h>
	20	#include <string.h>
	21
	22	#include "libguile/_scm.h"
	23	#include "libguile/pairs.h"
	24	#include "libguile/gc.h"
	25	#include "libguile/private-gc.h"
	26
	27
	28
c7743d02 HWN	29
	30
	31	size_t scm_max_segment_size;
	32
	33	scm_t_heap_segment *
	34	scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl)
	35	{
	36	scm_t_heap_segment * shs = malloc (sizeof (scm_t_heap_segment));
	37
	38	if (!shs)
	39	{
	40	fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n");
	41	abort ();
	42	}
	43
	44	shs->bounds[0] = NULL;
	45	shs->bounds[1] = NULL;
	46	shs->malloced = NULL;
	47	shs->span = fl->span;
	48	shs->freelist = fl;
	49	shs->next_free_card = NULL;
	50
	51	return shs;
	52	}
	53
	54
1367aa5e HWN	55	void
	56	scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab)
	57	{
	58	scm_t_cell *p = seg->bounds[0];
	59	while (p < seg->bounds[1])
	60	{
	61	scm_i_card_statistics (p, tab, seg);
	62	p += SCM_GC_CARD_N_CELLS;
	63	}
	64	}
	65
	66
	67
c7743d02 HWN	68	/*
	69	Fill SEGMENT with memory both for data and mark bits.
	70
	71	RETURN: 1 on success, 0 failure
	72	*/
	73	int
	74	scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested)
	75	{
	76	/*
	77	round upwards
	78	*/
	79	int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
	80	int card_count =1 + (requested / sizeof (scm_t_cell)) / card_data_cell_count;
	81
	82	/*
	83	one card extra due to alignment
	84	*/
	85	size_t mem_needed = (1+card_count) * SCM_GC_SIZEOF_CARD
	86	+ SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG
	87	;
	88	scm_t_c_bvec_long * bvec_ptr = 0;
	89	scm_t_cell * memory = 0;
	90
	91	/*
b17e0ac3	92	We use calloc to alloc the heap. On GNU libc this is
c7743d02 HWN	93	equivalent to mmapping /dev/zero
	94	*/
	95	SCM_SYSCALL (memory = (scm_t_cell * ) calloc (1, mem_needed));
	96
	97	if (memory == NULL)
	98	return 0;
	99
	100	segment->malloced = memory;
	101	segment->bounds[0] = SCM_GC_CARD_UP (memory);
	102	segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS;
	103
	104	segment->freelist->heap_size += scm_i_segment_cell_count (segment);
	105
	106	bvec_ptr = (scm_t_c_bvec_long*) segment->bounds[1];
	107
1383773b HWN	108	/*
	109	Don't init the mem or the bitvector. This is handled by lazy
	110	sweeping.
	111	*/
	112
c7743d02 HWN	113	segment->next_free_card = segment->bounds[0];
	114	segment->first_time = 1;
	115	return 1;
	116	}
	117
	118	int
	119	scm_i_segment_card_count (scm_t_heap_segment * seg)
	120	{
	121	return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
	122	}
	123
	124	/*
	125	Return the number of available single-cell data cells.
	126	*/
	127	int
	128	scm_i_segment_cell_count (scm_t_heap_segment * seg)
	129	{
	130	return scm_i_segment_card_count (seg) * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
	131	+ ((seg->span == 2) ? -1 : 0);
	132	}
	133
	134	void
	135	scm_i_clear_segment_mark_space (scm_t_heap_segment *seg)
	136	{
	137	scm_t_cell * markspace = seg->bounds[1];
	138
	139	memset (markspace, 0x00,
	140	scm_i_segment_card_count (seg) * SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG);
	141	}
	142
4c7016dc	143	/* Sweep cards from SEG until we've gathered THRESHOLD cells. On return,
d9f71a07 LC	144	SWEEP_STATS contains the number of cells that have been visited and
d9f71a07 LC	145	collected. A freelist is returned, potentially empty. */
c7743d02	146	SCM
4c7016dc HWN	147	scm_i_sweep_some_cards (scm_t_heap_segment *seg,
4c7016dc HWN	148	scm_t_sweep_statistics *sweep_stats)
c7743d02 HWN	149	{
	150	SCM cells = SCM_EOL;
	151	int threshold = 512;
	152	int collected = 0;
1383773b HWN	153	int (sweeper) (scm_t_cell , SCM , scm_t_heap_segment )
1383773b HWN	154	= (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card;
c7743d02 HWN	155
	156	scm_t_cell * next_free = seg->next_free_card;
	157	int cards_swept = 0;
4c7016dc	158
c7743d02 HWN	159	while (collected < threshold && next_free < seg->bounds[1])
c7743d02 HWN	160	{
1383773b	161	collected += (*sweeper) (next_free, &cells, seg);
c7743d02 HWN	162	next_free += SCM_GC_CARD_N_CELLS;
	163	cards_swept ++;
	164	}
	165
4c7016dc HWN	166	sweep_stats->swept = cards_swept * seg->span
4c7016dc HWN	167	* (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
c2cbcc57 HWN	168
c2cbcc57 HWN	169	if (!seg->first_time)
4c7016dc HWN	170	{
	171	/* scm_cells_allocated -= collected * seg->span; */
	172	sweep_stats->collected = collected * seg->span;
	173	}
	174	else
	175	sweep_stats->collected = 0;
	176
	177	seg->freelist->collected += collected * seg->span;
c7743d02 HWN	178
	179	if(next_free == seg->bounds[1])
	180	{
	181	seg->first_time = 0;
	182	}
	183
	184	seg->next_free_card = next_free;
	185	return cells;
	186	}
	187
	188
	189	/*
	190	Force a sweep of this entire segment. This doesn't modify sweep
	191	statistics, it just frees the memory pointed to by to-be-swept
	192	cells.
	193
c2cbcc57 HWN	194	Implementation is slightly ugh.
	195
	196	FIXME: if you do scm_i_sweep_segment(), and then allocate from this
	197	segment again, the statistics are off.
c7743d02 HWN	198	*/
c7743d02 HWN	199	void
4c7016dc HWN	200	scm_i_sweep_segment (scm_t_heap_segment *seg,
4c7016dc HWN	201	scm_t_sweep_statistics *sweep_stats)
c7743d02	202	{
4c7016dc	203	scm_t_sweep_statistics sweep;
c7743d02	204	scm_t_cell * p = seg->next_free_card;
c7743d02	205
4c7016dc HWN	206	scm_i_sweep_statistics_init (sweep_stats);
4c7016dc HWN	207
d9f71a07	208	scm_i_sweep_statistics_init (&sweep);
4c7016dc	209	while (scm_i_sweep_some_cards (seg, &sweep) != SCM_EOL)
d9f71a07 LC	210	{
	211	scm_i_sweep_statistics_sum (sweep_stats, sweep);
	212	scm_i_sweep_statistics_init (&sweep);
	213	}
4c7016dc	214
c7743d02 HWN	215	seg->next_free_card =p;
	216	}
	217
	218	void
4c7016dc HWN	219	scm_i_sweep_all_segments (char const *reason,
4c7016dc HWN	220	scm_t_sweep_statistics *sweep_stats)
c7743d02	221	{
4c7016dc	222	unsigned i= 0;
c7743d02	223
4c7016dc	224	scm_i_sweep_statistics_init (sweep_stats);
c7743d02 HWN	225	for (i = 0; i < scm_i_heap_segment_table_size; i++)
c7743d02 HWN	226	{
4c7016dc HWN	227	scm_t_sweep_statistics sweep;
	228
	229	scm_i_sweep_segment (scm_i_heap_segment_table[i], &sweep);
	230	scm_i_sweep_statistics_sum (sweep_stats, sweep);
c7743d02 HWN	231	}
	232	}
	233
	234
	235	/*
	236	Heap segment table.
	237
	238	The table is sorted by the address of the data itself. This makes
	239	for easy lookups. This is not portable: according to ANSI C,
	240	pointers can only be compared within the same object (i.e. the same
	241	block of malloced memory.). For machines with weird architectures,
	242	this should be revised.
	243
	244	(Apparently, for this reason 1.6 and earlier had macros for pointer
	245	comparison. )
	246
	247	perhaps it is worthwhile to remove the 2nd level of indirection in
	248	the table, but this certainly makes for cleaner code.
	249	*/
	250	scm_t_heap_segment ** scm_i_heap_segment_table;
	251	size_t scm_i_heap_segment_table_size;
	252	scm_t_cell *lowest_cell;
	253	scm_t_cell *highest_cell;
	254
	255
	256	void
	257	scm_i_clear_mark_space (void)
	258	{
	259	int i = 0;
	260	for (; i < scm_i_heap_segment_table_size; i++)
	261	{
	262	scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]);
	263	}
	264	}
	265
	266
	267	/*
	268	RETURN: index of inserted segment.
	269	*/
	270	int
	271	scm_i_insert_segment (scm_t_heap_segment * seg)
	272	{
	273	size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *);
	274	SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **)
	275	realloc ((char *)scm_i_heap_segment_table, size)));
	276
	277	/*
	278	We can't alloc 4 more bytes. This is hopeless.
	279	*/
	280	if (!scm_i_heap_segment_table)
	281	{
	282	fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n");
	283	abort ();
	284	}
	285
	286	if (!lowest_cell)
	287	{
	288	lowest_cell = seg->bounds[0];
	289	highest_cell = seg->bounds[1];
	290	}
	291	else
	292	{
	293	lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]);
	294	highest_cell = SCM_MAX (highest_cell, seg->bounds[1]);
295	}
296
ffd72400	297
c7743d02 HWN	298	{
	299	int i = 0;
	300	int j = 0;
	301
	302	while (i < scm_i_heap_segment_table_size
	303	&& scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0])
	304	i++;
ffd72400 HWN	305
	306	/*
	307	We insert a new entry; if that happens to be before the
	308	"current" segment of a freelist, we must move the freelist index
	309	as well.
	310	*/
	311	if (scm_i_master_freelist.heap_segment_idx >= i)
	312	scm_i_master_freelist.heap_segment_idx ++;
	313	if (scm_i_master_freelist2.heap_segment_idx >= i)
	314	scm_i_master_freelist2.heap_segment_idx ++;
	315
c7743d02 HWN	316	for (j = scm_i_heap_segment_table_size; j > i; --j)
	317	scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1];
	318
	319	scm_i_heap_segment_table [i] = seg;
	320	scm_i_heap_segment_table_size ++;
	321
	322	return i;
	323	}
	324	}
	325
	326	SCM
4c7016dc HWN	327	scm_i_sweep_some_segments (scm_t_cell_type_statistics *fl,
4c7016dc HWN	328	scm_t_sweep_statistics *sweep_stats)
c7743d02 HWN	329	{
c7743d02 HWN	330	int i = fl->heap_segment_idx;
b17e0ac3	331	SCM collected = SCM_EOL;
4c7016dc HWN	332
4c7016dc HWN	333	scm_i_sweep_statistics_init (sweep_stats);
c7743d02 HWN	334	if (i == -1)
c7743d02 HWN	335	i++;
4c7016dc	336
c7743d02 HWN	337	for (;
	338	i < scm_i_heap_segment_table_size; i++)
	339	{
4c7016dc HWN	340	scm_t_sweep_statistics sweep;
4c7016dc HWN	341
c7743d02 HWN	342	if (scm_i_heap_segment_table[i]->freelist != fl)
c7743d02 HWN	343	continue;
c7743d02	344
d9f71a07	345	scm_i_sweep_statistics_init (&sweep);
4c7016dc HWN	346	collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i],
	347	&sweep);
	348
	349	scm_i_sweep_statistics_sum (sweep_stats, sweep);
c7743d02 HWN	350
	351	if (collected != SCM_EOL) /* Don't increment i */
	352	break;
	353	}
	354
	355	fl->heap_segment_idx = i;
4c7016dc	356
c7743d02 HWN	357	return collected;
	358	}
	359
	360
c7743d02 HWN	361	void
	362	scm_i_reset_segments (void)
	363	{
	364	int i = 0;
	365	for (; i < scm_i_heap_segment_table_size; i++)
	366	{
	367	scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
	368	seg->next_free_card = seg->bounds[0];
	369	}
	370	}
	371
1367aa5e HWN	372	/*
	373	Return a hashtab with counts of live objects, with tags as keys.
	374	*/
	375
	376
	377	SCM
	378	scm_i_all_segments_statistics (SCM tab)
	379	{
	380	int i = 0;
	381	for (; i < scm_i_heap_segment_table_size; i++)
	382	{
	383	scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
	384	scm_i_heap_segment_statistics (seg, tab);
	385	}
	386
	387	return tab;
	388	}
	389
	390
	391
c7743d02 HWN	392
	393	/*
	394	Determine whether the given value does actually represent a cell in
	395	some heap segment. If this is the case, the number of the heap
	396	segment is returned. Otherwise, -1 is returned. Binary search is
	397	used to determine the heap segment that contains the cell.
	398
	399
	400	I think this function is too long to be inlined. --hwn
	401	*/
	402	long int
	403	scm_i_find_heap_segment_containing_object (SCM obj)
	404	{
	405	if (!CELL_P (obj))
	406	return -1;
	407
	408	if ((scm_t_cell* ) obj < lowest_cell \|\| (scm_t_cell*) obj >= highest_cell)
	409	return -1;
	410
	411
	412	{
	413	scm_t_cell * ptr = SCM2PTR (obj);
	414	unsigned long int i = 0;
	415	unsigned long int j = scm_i_heap_segment_table_size - 1;
	416
	417	if (ptr < scm_i_heap_segment_table[i]->bounds[0])
	418	return -1;
	419	else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
	420	return -1;
	421	else
	422	{
	423	while (i < j)
	424	{
	425	if (ptr < scm_i_heap_segment_table[i]->bounds[1])
	426	{
	427	break;
	428	}
	429	else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr)
	430	{
	431	i = j;
	432	break;
	433	}
	434	else
	435	{
	436	unsigned long int k = (i + j) / 2;
	437
	438	if (k == i)
	439	return -1;
	440	else if (ptr < scm_i_heap_segment_table[k]->bounds[1])
	441	{
	442	j = k;
	443	++i;
	444	if (ptr < scm_i_heap_segment_table[i]->bounds[0])
	445	return -1;
	446	}
	447	else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr)
	448	{
	449	i = k;
	450	--j;
	451	if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
	452	return -1;
	453	}
	454	}
	455	}
456
1383773b	457	if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2)
c7743d02 HWN	458	return -1;
	459	else if (SCM_GC_IN_CARD_HEADERP (ptr))
	460	return -1;
	461	else
	462	return i;
	463	}
	464	}
	465	}
	466
	467
d9f71a07 LC	468	/* Important entry point: try to grab some memory, and make it into a
	469	segment; return the index of the segment. SWEEP_STATS should contain
	470	global GC sweep statistics collected since the last full GC. */
	471	int
b17e0ac3	472	scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
d9f71a07	473	scm_t_sweep_statistics sweep_stats,
b17e0ac3	474	policy_on_error error_policy)
c7743d02 HWN	475	{
	476	size_t len;
	477
c7743d02 HWN	478	{
	479	/* Assure that the new segment is predicted to be large enough.
	480	*
	481	* New yield should at least equal GC fraction of new heap size, i.e.
	482	*
	483	* y + dh > f * (h + dh)
	484	*
	485	* y : yield
	486	* f : min yield fraction
	487	* h : heap size
	488	* dh : size of new heap segment
	489	*
	490	* This gives dh > (f * h - y) / (1 - f)
	491	*/
38d1262a HWN	492	float f = freelist->min_yield_fraction / 100.0;
38d1262a HWN	493	float h = SCM_HEAP_SIZE;
d9f71a07	494	float min_cells = (f * h - sweep_stats.collected) / (1.0 - f);
c7743d02 HWN	495
	496	/* Make heap grow with factor 1.5 */
	497	len = freelist->heap_size / 2;
	498	#ifdef DEBUGINFO
	499	fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
	500	#endif
	501
c7743d02	502	if (len < min_cells)
38d1262a	503	len = (unsigned long) min_cells;
c7743d02 HWN	504	len *= sizeof (scm_t_cell);
	505	/* force new sampling */
	506	freelist->collected = LONG_MAX;
	507	}
	508
c17b358f MV	509	if (len > scm_max_segment_size)
c17b358f MV	510	len = scm_max_segment_size;
4a5309c9	511	if (len < SCM_MIN_HEAP_SEG_SIZE)
67329a9e	512	len = SCM_MIN_HEAP_SEG_SIZE;
c7743d02 HWN	513
c7743d02 HWN	514	{
c7743d02	515	scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
c7743d02 HWN	516
c7743d02 HWN	517	/* Allocate with decaying ambition. */
67329a9e	518	while (len >= SCM_MIN_HEAP_SEG_SIZE)
c7743d02 HWN	519	{
	520	if (scm_i_initialize_heap_segment_data (seg, len))
	521	{
	522	return scm_i_insert_segment (seg);
	523	}
	524
	525	len /= 2;
	526	}
	527	}
	528
	529	if (error_policy == abort_on_error)
	530	{
	531	fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n");
	532	abort ();
	533	}
	534	return -1;
	535	}
	536
c7743d02	537	void
dac04e9f	538	scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist)
c7743d02 HWN	539	{
c7743d02 HWN	540	scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
dac04e9f HWN	541
	542	if (init_heap_size < 1)
	543	{
	544	init_heap_size = SCM_DEFAULT_INIT_HEAP_SIZE_1;
	545	}
c7743d02 HWN	546
	547	if (scm_i_initialize_heap_segment_data (seg, init_heap_size))
	548	{
	549	freelist->heap_segment_idx = scm_i_insert_segment (seg);
	550	}
	551
	552	/*
	553	Why the fuck try twice? --hwn
	554	*/
	555	if (!seg->malloced)
	556	{
	557	scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE);
	558	}
	559
	560	if (freelist->min_yield_fraction)
	561	freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
	562	/ 100);
	563	}