[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);
}

/*
  Sweep cards from SEG until we've gather 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];
    }
}


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