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

/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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
  
  RETURN:

  Freelist. 
*/
SCM
scm_i_sweep_some_cards (scm_t_heap_segment *seg)
{
  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 ++;
    }

  scm_gc_cells_swept +=  cards_swept * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
  scm_gc_cells_collected += collected * seg->span;

  if (!seg->first_time)
    scm_cells_allocated -= collected * seg->span;
  
  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_cell * p = seg->next_free_card;
  int yield = scm_gc_cells_collected;
  int coll = seg->freelist->collected;
  unsigned long alloc = scm_cells_allocated ;
  
  while (scm_i_sweep_some_cards (seg) != SCM_EOL)
    ;

  scm_gc_cells_collected = yield;
  scm_cells_allocated = alloc;
  seg->freelist->collected = coll; 
  
  seg->next_free_card =p;
}

void
scm_i_sweep_all_segments (char const  *reason)
{
  int i= 0; 

  for (i = 0; i < scm_i_heap_segment_table_size; i++)
    {
      scm_i_sweep_segment (scm_i_heap_segment_table[i]);
    }
}


/*
  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)
{
  int i = fl->heap_segment_idx;
  SCM collected = SCM_EOL;
  
  if (i == -1)
    i++;
  
  for (;
       i < scm_i_heap_segment_table_size; i++)
    {
      if (scm_i_heap_segment_table[i]->freelist != fl)
	continue;
      
      collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i]);


      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.
 */
int 
scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
			    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 - scm_gc_cells_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
c7743d02 HWN	1	/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc.
c7743d02 HWN	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
	143	/*
adba74f3	144	Sweep cards from SEG until we've gathered THRESHOLD cells
dff96e95	145
c7743d02 HWN	146	RETURN:
	147
	148	Freelist.
	149	*/
	150	SCM
	151	scm_i_sweep_some_cards (scm_t_heap_segment *seg)
	152	{
	153	SCM cells = SCM_EOL;
	154	int threshold = 512;
	155	int collected = 0;
1383773b HWN	156	int (sweeper) (scm_t_cell , SCM , scm_t_heap_segment )
1383773b HWN	157	= (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card;
c7743d02 HWN	158
	159	scm_t_cell * next_free = seg->next_free_card;
	160	int cards_swept = 0;
	161
	162	while (collected < threshold && next_free < seg->bounds[1])
	163	{
1383773b	164	collected += (*sweeper) (next_free, &cells, seg);
c7743d02 HWN	165	next_free += SCM_GC_CARD_N_CELLS;
	166	cards_swept ++;
	167	}
	168
	169	scm_gc_cells_swept += cards_swept * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
	170	scm_gc_cells_collected += collected * seg->span;
c2cbcc57 HWN	171
	172	if (!seg->first_time)
	173	scm_cells_allocated -= collected * seg->span;
	174
c7743d02	175	seg->freelist->collected += collected * seg->span;
c2cbcc57	176
c7743d02 HWN	177
	178	if(next_free == seg->bounds[1])
	179	{
	180	seg->first_time = 0;
	181	}
	182
	183	seg->next_free_card = next_free;
	184	return cells;
	185	}
	186
	187
	188	/*
	189	Force a sweep of this entire segment. This doesn't modify sweep
	190	statistics, it just frees the memory pointed to by to-be-swept
	191	cells.
	192
c2cbcc57 HWN	193	Implementation is slightly ugh.
	194
	195	FIXME: if you do scm_i_sweep_segment(), and then allocate from this
	196	segment again, the statistics are off.
c7743d02 HWN	197	*/
	198	void
	199	scm_i_sweep_segment (scm_t_heap_segment * seg)
	200	{
	201	scm_t_cell * p = seg->next_free_card;
	202	int yield = scm_gc_cells_collected;
	203	int coll = seg->freelist->collected;
f2893a25	204	unsigned long alloc = scm_cells_allocated ;
c2cbcc57	205
c7743d02 HWN	206	while (scm_i_sweep_some_cards (seg) != SCM_EOL)
	207	;
	208
	209	scm_gc_cells_collected = yield;
c2cbcc57	210	scm_cells_allocated = alloc;
c7743d02 HWN	211	seg->freelist->collected = coll;
	212
	213	seg->next_free_card =p;
	214	}
	215
	216	void
	217	scm_i_sweep_all_segments (char const *reason)
	218	{
	219	int i= 0;
	220
	221	for (i = 0; i < scm_i_heap_segment_table_size; i++)
	222	{
	223	scm_i_sweep_segment (scm_i_heap_segment_table[i]);
	224	}
	225	}
	226
	227
	228	/*
	229	Heap segment table.
	230
	231	The table is sorted by the address of the data itself. This makes
	232	for easy lookups. This is not portable: according to ANSI C,
	233	pointers can only be compared within the same object (i.e. the same
	234	block of malloced memory.). For machines with weird architectures,
	235	this should be revised.
	236
	237	(Apparently, for this reason 1.6 and earlier had macros for pointer
	238	comparison. )
	239
	240	perhaps it is worthwhile to remove the 2nd level of indirection in
	241	the table, but this certainly makes for cleaner code.
	242	*/
	243	scm_t_heap_segment ** scm_i_heap_segment_table;
	244	size_t scm_i_heap_segment_table_size;
	245	scm_t_cell *lowest_cell;
	246	scm_t_cell *highest_cell;
	247
	248
	249	void
	250	scm_i_clear_mark_space (void)
	251	{
	252	int i = 0;
	253	for (; i < scm_i_heap_segment_table_size; i++)
	254	{
	255	scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]);
	256	}
	257	}
	258
	259
	260	/*
	261	RETURN: index of inserted segment.
	262	*/
	263	int
	264	scm_i_insert_segment (scm_t_heap_segment * seg)
	265	{
	266	size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *);
	267	SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **)
	268	realloc ((char *)scm_i_heap_segment_table, size)));
	269
	270	/*
	271	We can't alloc 4 more bytes. This is hopeless.
	272	*/
	273	if (!scm_i_heap_segment_table)
	274	{
275	fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n");
276	abort ();
277	}
278
279	if (!lowest_cell)
280	{
281	lowest_cell = seg->bounds[0];
282	highest_cell = seg->bounds[1];
283	}
284	else
285	{
286	lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]);
287	highest_cell = SCM_MAX (highest_cell, seg->bounds[1]);
288	}
289
ffd72400	290
c7743d02 HWN	291	{
	292	int i = 0;
	293	int j = 0;
	294
	295	while (i < scm_i_heap_segment_table_size
	296	&& scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0])
	297	i++;
ffd72400 HWN	298
	299	/*
	300	We insert a new entry; if that happens to be before the
	301	"current" segment of a freelist, we must move the freelist index
	302	as well.
	303	*/
	304	if (scm_i_master_freelist.heap_segment_idx >= i)
	305	scm_i_master_freelist.heap_segment_idx ++;
	306	if (scm_i_master_freelist2.heap_segment_idx >= i)
	307	scm_i_master_freelist2.heap_segment_idx ++;
	308
c7743d02 HWN	309	for (j = scm_i_heap_segment_table_size; j > i; --j)
	310	scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1];
	311
	312	scm_i_heap_segment_table [i] = seg;
	313	scm_i_heap_segment_table_size ++;
	314
	315	return i;
	316	}
	317	}
	318
	319	SCM
	320	scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl)
	321	{
	322	int i = fl->heap_segment_idx;
b17e0ac3	323	SCM collected = SCM_EOL;
c7743d02 HWN	324
	325	if (i == -1)
	326	i++;
	327
	328	for (;
	329	i < scm_i_heap_segment_table_size; i++)
	330	{
	331	if (scm_i_heap_segment_table[i]->freelist != fl)
	332	continue;
	333
	334	collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i]);
	335
	336
	337	if (collected != SCM_EOL) /* Don't increment i */
	338	break;
	339	}
	340
	341	fl->heap_segment_idx = i;
	342
	343	return collected;
	344	}
	345
	346
c7743d02 HWN	347	void
	348	scm_i_reset_segments (void)
	349	{
	350	int i = 0;
	351	for (; i < scm_i_heap_segment_table_size; i++)
	352	{
	353	scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
	354	seg->next_free_card = seg->bounds[0];
	355	}
	356	}
	357
1367aa5e HWN	358	/*
	359	Return a hashtab with counts of live objects, with tags as keys.
	360	*/
	361
	362
	363	SCM
	364	scm_i_all_segments_statistics (SCM tab)
	365	{
	366	int i = 0;
	367	for (; i < scm_i_heap_segment_table_size; i++)
	368	{
	369	scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
	370	scm_i_heap_segment_statistics (seg, tab);
	371	}
	372
	373	return tab;
	374	}
	375
	376
	377
c7743d02 HWN	378
	379	/*
	380	Determine whether the given value does actually represent a cell in
	381	some heap segment. If this is the case, the number of the heap
	382	segment is returned. Otherwise, -1 is returned. Binary search is
	383	used to determine the heap segment that contains the cell.
	384
	385
	386	I think this function is too long to be inlined. --hwn
	387	*/
	388	long int
	389	scm_i_find_heap_segment_containing_object (SCM obj)
	390	{
	391	if (!CELL_P (obj))
	392	return -1;
	393
	394	if ((scm_t_cell* ) obj < lowest_cell \|\| (scm_t_cell*) obj >= highest_cell)
	395	return -1;
	396
	397
	398	{
	399	scm_t_cell * ptr = SCM2PTR (obj);
	400	unsigned long int i = 0;
	401	unsigned long int j = scm_i_heap_segment_table_size - 1;
	402
	403	if (ptr < scm_i_heap_segment_table[i]->bounds[0])
	404	return -1;
	405	else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
	406	return -1;
	407	else
	408	{
	409	while (i < j)
	410	{
	411	if (ptr < scm_i_heap_segment_table[i]->bounds[1])
	412	{
	413	break;
	414	}
	415	else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr)
	416	{
	417	i = j;
	418	break;
	419	}
	420	else
	421	{
	422	unsigned long int k = (i + j) / 2;
	423
	424	if (k == i)
	425	return -1;
	426	else if (ptr < scm_i_heap_segment_table[k]->bounds[1])
	427	{
	428	j = k;
	429	++i;
	430	if (ptr < scm_i_heap_segment_table[i]->bounds[0])
	431	return -1;
	432	}
	433	else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr)
	434	{
	435	i = k;
	436	--j;
	437	if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
	438	return -1;
	439	}
	440	}
	441	}
442
1383773b	443	if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2)
c7743d02 HWN	444	return -1;
	445	else if (SCM_GC_IN_CARD_HEADERP (ptr))
	446	return -1;
	447	else
	448	return i;
	449	}
	450	}
	451	}
	452
	453
	454	/*
	455	Important entry point: try to grab some memory, and make it into a
	456	segment.
	457
	458	RETURN: the index of the segment.
	459	*/
	460	int
b17e0ac3 MV	461	scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
b17e0ac3 MV	462	policy_on_error error_policy)
c7743d02 HWN	463	{
	464	size_t len;
	465
c7743d02 HWN	466	{
	467	/* Assure that the new segment is predicted to be large enough.
	468	*
	469	* New yield should at least equal GC fraction of new heap size, i.e.
	470	*
	471	* y + dh > f * (h + dh)
	472	*
	473	* y : yield
	474	* f : min yield fraction
	475	* h : heap size
	476	* dh : size of new heap segment
	477	*
	478	* This gives dh > (f * h - y) / (1 - f)
	479	*/
38d1262a HWN	480	float f = freelist->min_yield_fraction / 100.0;
	481	float h = SCM_HEAP_SIZE;
	482	float min_cells
	483	= (f * h - scm_gc_cells_collected) / (1.0 - f);
c7743d02 HWN	484
	485	/* Make heap grow with factor 1.5 */
	486	len = freelist->heap_size / 2;
	487	#ifdef DEBUGINFO
	488	fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
	489	#endif
	490
c7743d02	491	if (len < min_cells)
38d1262a	492	len = (unsigned long) min_cells;
c7743d02 HWN	493	len *= sizeof (scm_t_cell);
	494	/* force new sampling */
	495	freelist->collected = LONG_MAX;
	496	}
	497
c17b358f MV	498	if (len > scm_max_segment_size)
c17b358f MV	499	len = scm_max_segment_size;
4a5309c9	500	if (len < SCM_MIN_HEAP_SEG_SIZE)
67329a9e	501	len = SCM_MIN_HEAP_SEG_SIZE;
c7743d02 HWN	502
c7743d02 HWN	503	{
c7743d02	504	scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
c7743d02 HWN	505
c7743d02 HWN	506	/* Allocate with decaying ambition. */
67329a9e	507	while (len >= SCM_MIN_HEAP_SEG_SIZE)
c7743d02 HWN	508	{
	509	if (scm_i_initialize_heap_segment_data (seg, len))
	510	{
	511	return scm_i_insert_segment (seg);
	512	}
	513
	514	len /= 2;
	515	}
	516	}
	517
	518	if (error_policy == abort_on_error)
	519	{
	520	fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n");
	521	abort ();
	522	}
	523	return -1;
	524	}
	525
c7743d02	526	void
dac04e9f	527	scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist)
c7743d02 HWN	528	{
c7743d02 HWN	529	scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
dac04e9f HWN	530
	531	if (init_heap_size < 1)
	532	{
	533	init_heap_size = SCM_DEFAULT_INIT_HEAP_SIZE_1;
	534	}
c7743d02 HWN	535
	536	if (scm_i_initialize_heap_segment_data (seg, init_heap_size))
	537	{
	538	freelist->heap_segment_idx = scm_i_insert_segment (seg);
	539	}
	540
	541	/*
	542	Why the fuck try twice? --hwn
	543	*/
	544	if (!seg->malloced)
	545	{
	546	scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE);
	547	}
	548
	549	if (freelist->min_yield_fraction)
	550	freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
	551	/ 100);
	552	}