[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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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;
}


/*
  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 malloc 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);
}

/*
  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];
    }
}


/*
  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;

  if (scm_gc_heap_lock)
    {
      /* Critical code sections (such as the garbage collector) aren't
       * supposed to add heap segments.
       */
      fprintf (stderr, "scm_i_get_new_heap_segment: Can not extend locked heap.\n");
      abort ();
    }

  {
    /* 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_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
	14	* License along with this library; if not, write to the Free Software
	15	* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	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
	55	/*
	56	Fill SEGMENT with memory both for data and mark bits.
	57
	58	RETURN: 1 on success, 0 failure
	59	*/
	60	int
	61	scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested)
	62	{
	63	/*
	64	round upwards
	65	*/
	66	int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
	67	int card_count =1 + (requested / sizeof (scm_t_cell)) / card_data_cell_count;
	68
	69	/*
	70	one card extra due to alignment
	71	*/
	72	size_t mem_needed = (1+card_count) * SCM_GC_SIZEOF_CARD
	73	+ SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG
	74	;
	75	scm_t_c_bvec_long * bvec_ptr = 0;
	76	scm_t_cell * memory = 0;
	77
	78	/*
	79	We use malloc to alloc the heap. On GNU libc this is
	80	equivalent to mmapping /dev/zero
	81	*/
	82	SCM_SYSCALL (memory = (scm_t_cell * ) calloc (1, mem_needed));
	83
	84	if (memory == NULL)
	85	return 0;
	86
	87	segment->malloced = memory;
	88	segment->bounds[0] = SCM_GC_CARD_UP (memory);
	89	segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS;
	90
	91	segment->freelist->heap_size += scm_i_segment_cell_count (segment);
	92
93	bvec_ptr = (scm_t_c_bvec_long*) segment->bounds[1];
94
1383773b HWN	95	/*
	96	Don't init the mem or the bitvector. This is handled by lazy
	97	sweeping.
	98	*/
	99
c7743d02 HWN	100	segment->next_free_card = segment->bounds[0];
	101	segment->first_time = 1;
	102	return 1;
	103	}
	104
	105	int
	106	scm_i_segment_card_count (scm_t_heap_segment * seg)
	107	{
	108	return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
	109	}
	110
	111	/*
	112	Return the number of available single-cell data cells.
	113	*/
	114	int
	115	scm_i_segment_cell_count (scm_t_heap_segment * seg)
	116	{
	117	return scm_i_segment_card_count (seg) * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
	118	+ ((seg->span == 2) ? -1 : 0);
	119	}
	120
	121	void
	122	scm_i_clear_segment_mark_space (scm_t_heap_segment *seg)
	123	{
	124	scm_t_cell * markspace = seg->bounds[1];
	125
	126	memset (markspace, 0x00,
	127	scm_i_segment_card_count (seg) * SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG);
	128	}
	129
	130	/*
	131	RETURN:
	132
	133	Freelist.
	134	*/
	135	SCM
	136	scm_i_sweep_some_cards (scm_t_heap_segment *seg)
	137	{
	138	SCM cells = SCM_EOL;
	139	int threshold = 512;
	140	int collected = 0;
1383773b HWN	141	int (sweeper) (scm_t_cell , SCM , scm_t_heap_segment )
1383773b HWN	142	= (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card;
c7743d02 HWN	143
	144	scm_t_cell * next_free = seg->next_free_card;
	145	int cards_swept = 0;
	146
	147	while (collected < threshold && next_free < seg->bounds[1])
	148	{
1383773b	149	collected += (*sweeper) (next_free, &cells, seg);
c7743d02 HWN	150	next_free += SCM_GC_CARD_N_CELLS;
	151	cards_swept ++;
	152	}
	153
	154	scm_gc_cells_swept += cards_swept * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
	155	scm_gc_cells_collected += collected * seg->span;
c2cbcc57 HWN	156
	157	if (!seg->first_time)
	158	scm_cells_allocated -= collected * seg->span;
	159
c7743d02	160	seg->freelist->collected += collected * seg->span;
c2cbcc57	161
c7743d02 HWN	162
	163	if(next_free == seg->bounds[1])
	164	{
	165	seg->first_time = 0;
	166	}
	167
	168	seg->next_free_card = next_free;
	169	return cells;
	170	}
	171
	172
	173	/*
	174	Force a sweep of this entire segment. This doesn't modify sweep
	175	statistics, it just frees the memory pointed to by to-be-swept
	176	cells.
	177
c2cbcc57 HWN	178	Implementation is slightly ugh.
	179
	180	FIXME: if you do scm_i_sweep_segment(), and then allocate from this
	181	segment again, the statistics are off.
c7743d02 HWN	182	*/
	183	void
	184	scm_i_sweep_segment (scm_t_heap_segment * seg)
	185	{
	186	scm_t_cell * p = seg->next_free_card;
	187	int yield = scm_gc_cells_collected;
	188	int coll = seg->freelist->collected;
f2893a25	189	unsigned long alloc = scm_cells_allocated ;
c2cbcc57	190
c7743d02 HWN	191	while (scm_i_sweep_some_cards (seg) != SCM_EOL)
	192	;
	193
	194	scm_gc_cells_collected = yield;
c2cbcc57	195	scm_cells_allocated = alloc;
c7743d02 HWN	196	seg->freelist->collected = coll;
	197
	198	seg->next_free_card =p;
	199	}
	200
	201	void
	202	scm_i_sweep_all_segments (char const *reason)
	203	{
	204	int i= 0;
	205
	206	for (i = 0; i < scm_i_heap_segment_table_size; i++)
	207	{
	208	scm_i_sweep_segment (scm_i_heap_segment_table[i]);
	209	}
	210	}
	211
	212
	213	/*
	214	Heap segment table.
	215
	216	The table is sorted by the address of the data itself. This makes
	217	for easy lookups. This is not portable: according to ANSI C,
	218	pointers can only be compared within the same object (i.e. the same
	219	block of malloced memory.). For machines with weird architectures,
	220	this should be revised.
	221
	222	(Apparently, for this reason 1.6 and earlier had macros for pointer
	223	comparison. )
	224
	225	perhaps it is worthwhile to remove the 2nd level of indirection in
	226	the table, but this certainly makes for cleaner code.
	227	*/
	228	scm_t_heap_segment ** scm_i_heap_segment_table;
	229	size_t scm_i_heap_segment_table_size;
	230	scm_t_cell *lowest_cell;
	231	scm_t_cell *highest_cell;
	232
	233
	234	void
	235	scm_i_clear_mark_space (void)
	236	{
	237	int i = 0;
	238	for (; i < scm_i_heap_segment_table_size; i++)
	239	{
	240	scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]);
	241	}
	242	}
	243
	244
	245	/*
	246	RETURN: index of inserted segment.
	247	*/
	248	int
	249	scm_i_insert_segment (scm_t_heap_segment * seg)
	250	{
	251	size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *);
	252	SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **)
	253	realloc ((char *)scm_i_heap_segment_table, size)));
	254
	255	/*
	256	We can't alloc 4 more bytes. This is hopeless.
	257	*/
	258	if (!scm_i_heap_segment_table)
	259	{
260	fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n");
261	abort ();
262	}
263
264	if (!lowest_cell)
265	{
266	lowest_cell = seg->bounds[0];
267	highest_cell = seg->bounds[1];
268	}
269	else
270	{
271	lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]);
272	highest_cell = SCM_MAX (highest_cell, seg->bounds[1]);
273	}
274
ffd72400	275
c7743d02 HWN	276	{
	277	int i = 0;
	278	int j = 0;
	279
	280	while (i < scm_i_heap_segment_table_size
	281	&& scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0])
	282	i++;
ffd72400 HWN	283
	284	/*
	285	We insert a new entry; if that happens to be before the
	286	"current" segment of a freelist, we must move the freelist index
	287	as well.
	288	*/
	289	if (scm_i_master_freelist.heap_segment_idx >= i)
	290	scm_i_master_freelist.heap_segment_idx ++;
	291	if (scm_i_master_freelist2.heap_segment_idx >= i)
	292	scm_i_master_freelist2.heap_segment_idx ++;
	293
c7743d02 HWN	294	for (j = scm_i_heap_segment_table_size; j > i; --j)
	295	scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1];
	296
	297	scm_i_heap_segment_table [i] = seg;
	298	scm_i_heap_segment_table_size ++;
	299
	300	return i;
	301	}
	302	}
	303
	304	SCM
	305	scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl)
	306	{
	307	int i = fl->heap_segment_idx;
	308	SCM collected =SCM_EOL;
	309
	310	if (i == -1)
	311	i++;
	312
	313	for (;
	314	i < scm_i_heap_segment_table_size; i++)
	315	{
	316	if (scm_i_heap_segment_table[i]->freelist != fl)
	317	continue;
	318
	319	collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i]);
	320
	321
	322	if (collected != SCM_EOL) /* Don't increment i */
	323	break;
	324	}
	325
	326	fl->heap_segment_idx = i;
	327
	328	return collected;
	329	}
	330
	331
	332
	333
	334	void
	335	scm_i_reset_segments (void)
	336	{
	337	int i = 0;
	338	for (; i < scm_i_heap_segment_table_size; i++)
	339	{
	340	scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
	341	seg->next_free_card = seg->bounds[0];
	342	}
	343	}
	344
	345
	346	/*
	347	Determine whether the given value does actually represent a cell in
	348	some heap segment. If this is the case, the number of the heap
	349	segment is returned. Otherwise, -1 is returned. Binary search is
	350	used to determine the heap segment that contains the cell.
	351
	352
	353	I think this function is too long to be inlined. --hwn
	354	*/
	355	long int
	356	scm_i_find_heap_segment_containing_object (SCM obj)
	357	{
358	if (!CELL_P (obj))
359	return -1;
360
361	if ((scm_t_cell* ) obj < lowest_cell \|\| (scm_t_cell*) obj >= highest_cell)
362	return -1;
363
364
365	{
366	scm_t_cell * ptr = SCM2PTR (obj);
367	unsigned long int i = 0;
368	unsigned long int j = scm_i_heap_segment_table_size - 1;
369
370	if (ptr < scm_i_heap_segment_table[i]->bounds[0])
371	return -1;
372	else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
373	return -1;
374	else
375	{
376	while (i < j)
377	{
378	if (ptr < scm_i_heap_segment_table[i]->bounds[1])
379	{
380	break;
381	}
382	else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr)
383	{
384	i = j;
385	break;
386	}
387	else
388	{
389	unsigned long int k = (i + j) / 2;
390
391	if (k == i)
392	return -1;
393	else if (ptr < scm_i_heap_segment_table[k]->bounds[1])
394	{
395	j = k;
396	++i;
397	if (ptr < scm_i_heap_segment_table[i]->bounds[0])
398	return -1;
399	}
400	else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr)
401	{
402	i = k;
403	--j;
404	if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
405	return -1;
406	}
407	}
408	}
409
1383773b	410	if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2)
c7743d02 HWN	411	return -1;
	412	else if (SCM_GC_IN_CARD_HEADERP (ptr))
	413	return -1;
	414	else
	415	return i;
	416	}
	417	}
	418	}
	419
	420
	421	/*
	422	Important entry point: try to grab some memory, and make it into a
	423	segment.
	424
	425	RETURN: the index of the segment.
	426	*/
	427	int
	428	scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, policy_on_error error_policy)
	429	{
	430	size_t len;
	431
	432	if (scm_gc_heap_lock)
	433	{
	434	/* Critical code sections (such as the garbage collector) aren't
	435	* supposed to add heap segments.
	436	*/
	437	fprintf (stderr, "scm_i_get_new_heap_segment: Can not extend locked heap.\n");
	438	abort ();
	439	}
	440
c7743d02 HWN	441	{
	442	/* Assure that the new segment is predicted to be large enough.
	443	*
	444	* New yield should at least equal GC fraction of new heap size, i.e.
	445	*
	446	* y + dh > f * (h + dh)
	447	*
	448	* y : yield
	449	* f : min yield fraction
	450	* h : heap size
	451	* dh : size of new heap segment
	452	*
	453	* This gives dh > (f * h - y) / (1 - f)
	454	*/
38d1262a HWN	455	float f = freelist->min_yield_fraction / 100.0;
	456	float h = SCM_HEAP_SIZE;
	457	float min_cells
	458	= (f * h - scm_gc_cells_collected) / (1.0 - f);
c7743d02 HWN	459
	460	/* Make heap grow with factor 1.5 */
	461	len = freelist->heap_size / 2;
	462	#ifdef DEBUGINFO
	463	fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
	464	#endif
	465
c7743d02	466	if (len < min_cells)
38d1262a	467	len = (unsigned long) min_cells;
c7743d02 HWN	468	len *= sizeof (scm_t_cell);
	469	/* force new sampling */
	470	freelist->collected = LONG_MAX;
	471	}
	472
4a5309c9	473	if (len < SCM_MIN_HEAP_SEG_SIZE)
67329a9e	474	len = SCM_MIN_HEAP_SEG_SIZE;
c7743d02 HWN	475
c7743d02 HWN	476	{
c7743d02	477	scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
c7743d02 HWN	478
c7743d02 HWN	479	/* Allocate with decaying ambition. */
67329a9e	480	while (len >= SCM_MIN_HEAP_SEG_SIZE)
c7743d02 HWN	481	{
	482	if (scm_i_initialize_heap_segment_data (seg, len))
	483	{
	484	return scm_i_insert_segment (seg);
	485	}
	486
	487	len /= 2;
	488	}
	489	}
	490
	491	if (error_policy == abort_on_error)
	492	{
	493	fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n");
	494	abort ();
	495	}
	496	return -1;
	497	}
	498
c7743d02	499	void
dac04e9f	500	scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist)
c7743d02 HWN	501	{
c7743d02 HWN	502	scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
dac04e9f HWN	503
	504	if (init_heap_size < 1)
	505	{
	506	init_heap_size = SCM_DEFAULT_INIT_HEAP_SIZE_1;
	507	}
c7743d02 HWN	508
	509	if (scm_i_initialize_heap_segment_data (seg, init_heap_size))
	510	{
	511	freelist->heap_segment_idx = scm_i_insert_segment (seg);
	512	}
	513
	514	/*
	515	Why the fuck try twice? --hwn
	516	*/
	517	if (!seg->malloced)
	518	{
	519	scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE);
	520	}
	521
	522	if (freelist->min_yield_fraction)
	523	freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
	524	/ 100);
	525	}