/*
   Written by Pieter J. Schoenmakers <tiggr@gerbil.org>

   Copyright (C) 1996-1999 Pieter J. Schoenmakers.

   This file is part of TOM.  TOM is distributed under the terms of the
   TOM License, a copy of which can be found in the TOM distribution; see
   the file LICENSE.

   $Id: alloc.c,v 1.99 1999/10/05 19:35:44 tiggr Exp $  */

/* Instantiate all inline functions in this object file.  */
#define TRT_INLINE

#include "trt.h"
#include <tom/tom-r.h>
#include <stdlib.h>
#include <memory.h>
#include <sys/time.h>
#if DEBUG_GC
#include <stdio.h>
#endif
#if HAVE_MACH_MACH_H
#include <mach/mach.h>
#include <mach/mach_error.h>
#endif
#if HAVE_MMAP
#include <sys/mman.h>
#endif
#if HAVE_UNISTD_H
#include <unistd.h>
#endif

/* XXX YYY These should be from configure...  */
#define ALIGN_TYPE double

#if DEBUG_GC
#define GC_DEBUG(X)  X
#else
#define GC_DEBUG(X)  do ; while (0)
#endif

/* This can not be a normal class variable since then it, and its
   contents, would no longer be a container...  */
tom_object c_tom_Container_all_containers;

/* The total number of objects, both allocated and free.  This does not
   count the size taken by chunks on the free chunk list.  */
unsigned long tgc_num_total;

/* The amount of time (seconds) spent in GC since the last completion.  */
static tom_double tgc_this_time;

/* The same information, split in the three phases.  */
static tom_double tgc_this_protect, tgc_this_mark, tgc_this_sweep;

/* The number of objects marked.  */
unsigned long tgc_num_mark;

/* Which pass of the garbage collector is running.  */
static enum
{
  /* Not doing anything.  */
  TGC_PASS_NOT,

  /* We're protecting (graying) otherwise poosibly non-marked objects.  */
  TGC_PASS_PROTECT,

  /* Marking gray objects.  */
  TGC_PASS_MARK_GRAY,

  /* Sweeping: deallocating whites  */
  TGC_PASS_SWEEP_WHITE,
} tgc_pass;

#if STACK_REF_STRUCT

/* The stack protection stack.  */
struct trt_protect_stack *_trt_sp;

#endif

/* Struct used to inspect allocation slots.  Minimum slot size is the size
   of this struct.  */
typedef struct tgc_vacant
{
  /* The isa.  */
  struct trt_class *isa;

  /* The flags.  */
  tom_int asi;

  /* The next vacant spot in this chunk.  */
  struct tgc_vacant *next;

#if DEBUG_GC > 0
  /* The saved isa of a deallocated object.  */
  struct trt_class *saved_isa;
#endif
} tgc_vacant;

/* Objects are allocated from chunks.  Each chunk holds CAP objects (of
   ITEM_SIZE bytes, where ITEM_SIZE is defined in the chunk_list, see
   below).  The minimum item size is sizeof (TGC_VACANT).  A non-object
   (ISA == NULL) is held in every vacant slot.  */
typedef struct chunk
{
  /* Doubly linked list of all chunks in this chunk list.  */
  struct chunk *next, **previous;

  /* Doubly linked list of all chunks in this chunk list which have
     vacancies.  */
  struct chunk *next_vacant, **previous_vacant;

  /* The first vacant object in this chunk.  */
  tgc_vacant *vacant_object;

  /* The number of allocated items in this chunk, and its capacity.  */
  unsigned int num, cap;

  /* The size of the items in this chunk.  */
  int item_size;

  /* The objects in this chunk.  */
  ALIGN_TYPE data[0];
} chunk;

/* The head of a list of chunks holding objects of the same size.  */
typedef struct slot_entry
{
  /* The first chunk in this list and the first chunk with vacancies.  */
  chunk *first, *first_vacant;
} slot_entry;

#if !STACK_REF_STRUCT
/* If we do not use stack reference structures, chunks (from which objects
   are allocated) are allocated from large chunk ranges.  The number of
   these ranges will be very low, enabling fast object address checking of
   random values found on the stack or in registers.  */
typedef struct chunk_range
{
  /* The number of chunks in this range.

     XXX Chunks are always 1 page in size (and the maximum size of an
     object is 1 chunk).  */
  int num;

  /* Actual address of this range.  */
  chunk *first;

#if RANGES_ARE_ALIGNED
  /* The bitwise inverse of the above.  */
  POINTER_INT_TYPE mask;
#endif
} chunk_range;

/* The existing chunk ranges, and their number.  */
static chunk_range *chunk_ranges;
static int num_chunk_ranges;

/* The first, previously unused, chunk in the most recently allocated
   chunk range.  */
static int range_first_empty;

/* The lowset address of all chunks, and the highest address.  */
static char *lowest_range_addr, *highest_range_addr = FIRST_RANGE_ADDRESS;

/* The size of newly allocated chunk ranges.  */
static int range_size = RANGE_SIZE;
#endif

/* The array of slot_entry structures, and the number of elements.  */
static slot_entry *chunks;
static unsigned int num_slots;

/* The free list of chunks, maintained through their NEXT_VACANT field,
   and the number of chunks on this list.  */
static chunk *chunks_free;
static int chunks_free_num;

/* Return the index for an object of size N.  */
#define INDEX_FOR_SIZE(N)  \
  (((N) + sizeof (ALIGN_TYPE) - 1) / sizeof (ALIGN_TYPE))

/* The smallest legal index value.  */
#define SMALLEST_INDEX  INDEX_FOR_SIZE (sizeof (tgc_vacant))

/* Return the size of the items at slot index N.  */
#define SIZE_FOR_INDEX(N)  ((N) * sizeof (ALIGN_TYPE))

/* Return the rounded size for an object of size N.  */
#define ROUNDED_SIZE(N)  \
  (((N) + sizeof (ALIGN_TYPE) - 1) / sizeof (ALIGN_TYPE) * sizeof (ALIGN_TYPE))

/* Estimates for the number of operations which can be performed in a
   certain amount of time: The number of objects which can be marked per
   second, and the number of objects per second which can be handled in
   the sweep phase.  The initial values do not matter, as these numbers
   are adjusted continuously.  */
static unsigned long tgc_marks_per_sec = 30000;
static unsigned long tgc_sweeps_per_sec = 50000;

/* Statistics on object colours during garbage collection.  */
static unsigned long tgc_num[TGC_NUM];

#if !HAVE_VM_PAGE_SIZE

/* The number of bytes in a page.  */
static long vm_page_size;

#endif

/* The address bits not within a page.  */
static long vm_page_mask;

/* The array used as a stack for gray objects.  All gray objects should be
   here.  */
static struct trt_instance **gray_objects;
static int gray_num, gray_cap;

#if !NO_MALLOC_STATS
#define malloc_cur_num_items c_tom_Runtime_malloc_cur_items
#define malloc_cum_num_items c_tom_Runtime_malloc_cum_items
#define malloc_max_num_items c_tom_Runtime_malloc_max_items
#define malloc_cur_num_bytes c_tom_Runtime_malloc_cur_bytes
#define malloc_cum_num_bytes c_tom_Runtime_malloc_cum_bytes
#define malloc_max_num_bytes c_tom_Runtime_malloc_max_bytes

#define MALLOC_ADD(BYTES)  \
  do							\
    {							\
      malloc_cur_num_items += 1;			\
      if (malloc_cur_num_items > malloc_max_num_items)	\
	malloc_max_num_items = malloc_cur_num_items;	\
      malloc_cur_num_bytes += (BYTES);			\
      if (malloc_cur_num_bytes > malloc_max_num_bytes)	\
	malloc_max_num_bytes = malloc_cur_num_bytes;	\
      malloc_cum_num_items += 1;			\
      malloc_cum_num_bytes += (BYTES);			\
    } while (0)

#define MALLOC_DEL(BYTES)  \
  do							\
    {							\
      malloc_cur_num_items -= 1;			\
      malloc_cur_num_bytes -= (BYTES);			\
    } while (0)

#endif

void *
xmalloc (unsigned int n)
{
  void *p;

  if (n)
    {
      LOCK_ALLOC ();
#if !NO_MALLOC_STATS
      {
	char *c = malloc (n + sizeof (double));

	if (!c)
	  p = c;
	else
	  {
	    MALLOC_ADD (n);
	    *(unsigned int *) c = n;
	    p = c + sizeof (double);
	  }
      }
#else
      p = malloc (n);
#endif
      UNLOCK_ALLOC ();

      if (!p)
	{
	  /* XXX Instead of this fatal, we could run garbage collection...
             If memory remains unavailable, we could raise a
             (preallocated) out-of-memory condition...  */
	  fatal ("vm exhausted (n=%u)", n);
	}
    }
  else
    p = NULL;

  return (p);
}

void *
xrealloc (void *p, unsigned int n)
{
  if (n)
    {
      LOCK_ALLOC ();

      /* Call straight malloc for a NULL P to please braindead
	 implementations (for which malloc (0) != 0).  */
#if !NO_MALLOC_STATS
      if (!p)
	{
	  char *c = malloc (n + sizeof (double));

	  if (!c)
	    p = c;
	  else
	    {
	      MALLOC_ADD (n);
	      *(unsigned int *) c = n;
	      p = c + sizeof (double);
	    }
	}
      else
	{
	  char *c = p;
	  int old_n;

	  c -= sizeof (double);
	  old_n = *(unsigned int *) c;

	  c = realloc (c, n + sizeof (double));
	  if (!c)
	    p = c;
	  else
	    {
	      MALLOC_DEL (old_n);
	      MALLOC_ADD (n);
	      *(unsigned int *) c = n;
	      p = c + sizeof (double);
	    }
	}
#else /* !NO_MALLOC_STATS */
      p = p ? realloc (p, n) : malloc (n);
#endif

      UNLOCK_ALLOC ();
      if (!p)
	fatal ("vm exhausted (n=%u)", n);
    }
  else if (p)
    {
      xfree (p);
      p = NULL;
    }

  return p;
}

void
xfree (void *p)
{
  if (p)
    {
      LOCK_ALLOC ();

#if !NO_MALLOC_STATS
      {
	char *c = p;

	c -= sizeof (double);
	MALLOC_DEL (*(int *) c);
	p = c;
      }
#endif
      free (p);

      UNLOCK_ALLOC ();
    }
}

void *
xcalloc (unsigned int n, unsigned int m)
{
  unsigned int l = n * m;
  void *p = xmalloc (l);

  if (p)
    BZERO ((void *) p, l);

  return (p);
}

void *
stalloc (struct stalloc **pst, int zero_size, int elt_size,
	 int num, int granularity)
{
  struct stalloc *st = *pst;

  if (!st)
    {
      int new_cap = granularity ? num - 1 + granularity : (num & ~3) + 4;

      st = *pst = xmalloc (zero_size + new_cap * elt_size);
      BZERO (st, zero_size + new_cap * elt_size);
      st->cap = new_cap;
    }
  else if (st->num < num)
    {
      if (st->cap < num)
	{
	  int new_size, old_size;
	  int new_cap = (granularity ? num - 1 + granularity
			 : st->cap ? num << 1 : num + 4);

	  if (new_cap < num)
	    ABORT ();
	  old_size = zero_size + st->num * elt_size;
	  new_size = zero_size + new_cap * elt_size;

	  if (st->cap)
	    st = xrealloc (st, new_size);
	  else
	    {
	      st = xmalloc (new_size);
	      memcpy (st, *pst, old_size);
	    }

	  BZERO ((char *) st + old_size, new_size - old_size);
	  st->cap = new_cap;
	  *pst = st;
	}

    }

  st->num = num;

  return st;
}

tom_byte
i_tom_Container_o_isContainer (tom_object self, selector cmd)
{
  return !!TGC_CONTAINER_P (self->asi);
}

tom_byte
i_tom_Container_o_wantsStackNotify (tom_object self, selector cmd)
{
  return !!TGC_STACK_NOTIFY_P (self->asi);
}

void
i_tom_Container_v_setIsContainer_o (tom_object self, selector cmd, tom_byte yes)
{
  if (yes)
    {
      if (!TGC_CONTAINER_P (self->asi))
	{
	  self->asi |= TGC_ASI_CONTAINER_P;
	  TRT_SEND (, c_tom_Container_all_containers, SEL (v_add_r), self);
	}
    }
  else if (TGC_CONTAINER_P (self->asi))
    {
      self->asi &= ~TGC_ASI_CONTAINER_P;
      TRT_SEND (, c_tom_Container_all_containers, SEL (v_remove_r), self);
    }
}
 
void
i_tom_Container_v_setStackNotify_o (tom_object self, selector cmd, tom_byte yes)
{
  if (yes)
    self->asi |= TGC_ASI_STACK_NOTIFY_P;
  else
    self->asi &= ~TGC_ASI_STACK_NOTIFY_P;
}

void
alloc_init (void)
{
#if !HAVE_VM_PAGE_SIZE
#if HAVE_GETPAGESIZE
  vm_page_size = getpagesize ();
#elif HAVE_SYSCONF_PAGESIZE
  vm_page_size = sysconf (_SC_PAGE_SIZE);
#else
#error no way to deduce page size
#endif
#endif
  vm_page_mask = ~(vm_page_size - 1);

  c_tom_Container_all_containers = TRT_SEND ((reference_imp),
					     _mr_c_tom_MutableEqSet,
					     SEL (r_new));
  TRT_SEND (, c_tom_Container_all_containers, SEL (v_setIsContainer_o), 1);
}

static __inline__ void
gray_stack_add (struct trt_instance *o)
{
  LOCK_GRAY ();

  if (gray_num == gray_cap)
    {
      gray_cap = (gray_cap ? gray_cap * 2
		  : vm_page_size / sizeof (*gray_objects));
      gray_objects = xrealloc (gray_objects, gray_cap * sizeof (*gray_objects));
    }
  gray_objects[gray_num++] = o;

  UNLOCK_GRAY ();
}

void
trt_make_gray (struct trt_instance *o)
{
  TGC_SET_COLOUR (o->asi, TGC_GRAY);

  gray_stack_add (o);
}

static __inline__ void
mark_if_needed_and_not_nil (struct trt_instance *o)
{
  if (o && TGC_COLOUR (o->asi) == TGC_WHITE)
    trt_make_gray (o);
}

/* Mark the thread-local objects.  This locks the runtime lock.  */
static __inline__ void
trt_mark_locals (int offset)
{
  int i, n;

  LOCK_RUNTIME ();

  n = trt_thread_num;

  for (i = 0; n && i < trt_thread_cap; i++)
    if (trt_threads[i].object)
      {
	mark_if_needed_and_not_nil (*(void **) ((char *) trt_threads[i].data
						+ offset));

	n--;
      }

  UNLOCK_RUNTIME ();
}

tom_object
moan_address_status (tom_object o)
{
  int i = address_status (o);
  switch (i)
    {
    case 1:
      return o;

    case -1:
      fprintf (stderr, "object is unallocated\n");
      break;
    case 0:
      if (!o)
	fprintf (stderr, "nil\n");
      else
	{
	  /* XXX Check whether this is a class or meta class object...  */
	  fprintf (stderr, "not an object's address\n");
	}
      break;
    default:
      fprintf (stderr, "unhandled status: %d\n", i);
      break;
    }
  return 0;
}

int
address_status (void *address)
{
  char *addr = address;
  int i;

  /* This is copied from check_for_reference in the stack marking.  */  
  for (i = 0; i < num_chunk_ranges; i++)
    if (ADDRESS_IN_RANGE (addr, &chunk_ranges[i]))
      {
	chunk *c = (void *) ((POINTER_INT_TYPE) addr & vm_page_mask);

	if (c->item_size
	    && !((addr - (char *) &c->data) % c->item_size))
	  {
	    struct trt_instance *o = (void *) addr;

	    if (!o->isa)
	      return -1;
	    return 1;
	  }
      }
  return 0;
}

#if !STACK_REF_STRUCT
/* Allocate a large range of memory, adding the new chunks to the list of
   free chunks, and return a new chunk (which thus does not reside on the
   free list).  The ALLOC lock must be on.  */
static chunk *
alloc_chunks_range (void)
{
  chunk_range *c = &chunk_ranges[num_chunk_ranges - 1];
  chunk *first;

  if (num_chunk_ranges && range_first_empty != c->num)
    first = (void *) ((char *) chunk_ranges[num_chunk_ranges - 1].first
		      + vm_page_size * range_first_empty++);
  else
    {
#if HAVE_VM_ALLOCATE
      vm_address_t a = (vm_address_t) highest_range_addr;

      for (;;)
	{
	  kern_return_t kr = vm_allocate (task_self (), &a, range_size, 0);

	  if (kr == KERN_SUCCESS)
	    break;
	  else if (kr != KERN_NO_SPACE)
	    fatal ("vm_allocate %lx %ld: %s (%d)",
		   a, range_size, mach_error_string (kr), kr);

	  a += range_size;
	}

      first = (void *) a;
#elif CHUNK_RANGE_VALLOC
      /* Note: this does not work under purecoverage on hpux 10.10.  */
      first = valloc (range_size);
#elif HAVE_MMAP
      caddr_t a = (caddr_t) highest_range_addr;

      /* XXX What if this runs out of memory?  */
      for (;;)
	{
	  if (a)
	    {
	      caddr_t kr = mmap (a, range_size, PROT_READ | PROT_WRITE,
				 MAP_ANONYMOUS | MAP_FIXED | MAP_PRIVATE,
				 -1, 0);

	      if ((long int) kr != -1)
		break;
	      else if (errno != ENOMEM)
		fatal ("mmap %lx %ld: %s (%d)",
		       a, range_size, strerror (errno), kr);
	    }

	  a += range_size;
	}
      first = (void *) a;
#else
      first = xmalloc (range_size + vm_page_size - 1);
      first = (void *) (((POINTER_INT_TYPE) first + vm_page_size - 1)
			& ~(vm_page_size -1));
#endif

      /* Enlarge the previous chunk, if possible.  */
      if (num_chunk_ranges
	  && (char *) first == (char *) c->first + c->num * vm_page_size
	  && (!RANGES_ARE_ALIGNED
	      || (((POINTER_INT_TYPE) first & ~(c->num * vm_page_size
						+ range_size - 1))
		  == ((POINTER_INT_TYPE) c->first & ~(c->num * vm_page_size
						      + range_size - 1)))))
	{
	  range_first_empty++;
	  c->num += range_size / vm_page_size;
	}
      else
	{
	  chunk_ranges = xrealloc (chunk_ranges,
				   ((num_chunk_ranges + 1)
				    * sizeof (*chunk_ranges)));
	  c = &chunk_ranges[num_chunk_ranges++];
	  c->first = first;
	  c->num = range_size / vm_page_size;
	  range_first_empty = 1;
	}

#if RANGES_ARE_ALIGNED
      c->mask = ~(c->num * vm_page_size - 1);
#endif

      if (!lowest_range_addr || (char *) first < lowest_range_addr)
	lowest_range_addr = (char *) first;
      if ((char *) first + c->num * vm_page_size > highest_range_addr)
	highest_range_addr = (char *) first + range_size;
    }

  return first;
}
#endif

tom_object
i_tom_Copying_r_copy (tom_object self, selector cmd)
{
  tom_object new_self = TRT_SEND ((reference_imp), self->isa, SEL (r_alloc));

  memcpy (new_self + 1, self + 1,
	  self->isa->info.instance_size - sizeof (*self));

  return TRT_SEND (_PI_, new_self, SEL (r_initCopy));
}

struct trt_instance *
c_tom_State_r_alloc (struct trt_class *class, selector cmd)
{
  int item_size = ROUNDED_SIZE (class->info.instance_size);
  unsigned int i, slot_index;
  slot_entry *slot;
  tgc_vacant *v;
  chunk *c;

  if (!class->info.instance_size)
    fatal ("attempt to allocate deferred instance (class=%s)",
	   class->info.name.s);
#ifdef DEBUG
  if (class->info.instance_size < 8)
    ABORT ();
#endif

#if !STACK_REF_STRUCT
  /* Mark the current top of stack.  */
  trt_threads[trt_thread_self ()].top = &class;
#endif

  if (item_size < SIZE_FOR_INDEX (SMALLEST_INDEX))
    item_size = SIZE_FOR_INDEX (SMALLEST_INDEX);
  slot_index = (INDEX_FOR_SIZE (item_size));

  TRT_PANIC_MODE_P ();

  /* Possibly extend the number of slots in CHUNKS to accommodate a new
     chunk at index SLOT_INDEX.  */
  if (slot_index >= num_slots)
    {
      chunks = xrealloc (chunks, (slot_index + 1) * sizeof (*chunks));
      BZERO ((void *) (chunks + num_slots),
	     (slot_index + 1 - num_slots) * sizeof (*chunks));

      {
	int i;

	for (i = SMALLEST_INDEX; i < num_slots; i++)
	  if (chunks[i].first)
	    {
	      chunks[i].first->previous = &chunks[i].first;
	      if (chunks[i].first_vacant)
		chunks[i].first_vacant->previous_vacant
		  = &chunks[i].first_vacant;
	    }
      }

      num_slots = slot_index + 1;
    }

  /* Allocate a new chunk if this slot does not hold any chunks with
     vacancies.  */
  slot = &chunks[slot_index];
  if (!slot->first_vacant)
    {
      if (chunks_free)
	{
	  c = chunks_free;
	  chunks_free = c->next_vacant;
	  chunks_free_num--;

#if DEBUG_GC > 0
	  ASSERT (chunks_free_num || !chunks_free);
#endif
	}
      else
	{
#if STACK_REF_STRUCT
	  c = xmalloc (vm_page_size);
#else
	  c = alloc_chunks_range ();
#endif
	}

      c->next = slot->first;
      if (c->next)
	c->next->previous = &c->next;
      slot->first = c;
      c->previous = &slot->first;

      c->next_vacant = NULL;
      slot->first_vacant = c;
      c->previous_vacant = &slot->first_vacant;

      c->num = 0;
      c->vacant_object = (void *) &c->data;
      c->cap = (vm_page_size - ((char *) &c->data - (char *) c)) / item_size;
      c->item_size = item_size;
      tgc_num_total += c->cap;

      for (i = 0, v = c->vacant_object; i < c->cap; v = v->next, i++)
	{
	  v->isa = 0;
	  v->next = (void *) ((char *) v + item_size);
	}
      ((tgc_vacant *) ((char *) v - item_size))->next = NULL;
    }

  /* Allocate the new object and initialize the State part.  */
  c = slot->first_vacant;
  v = c->vacant_object;
  c->vacant_object = v->next;
  c->num++;

  if (!c->vacant_object)
    {
#if DEBUG_GC > 0
      ASSERT (c->num == c->cap);
#endif
      slot->first_vacant = c->next_vacant;
      if (slot->first_vacant)
	slot->first_vacant->previous_vacant = &slot->first_vacant;
      c->previous_vacant = NULL;
      c->next_vacant = NULL;
    }

  v->isa = class;
  class->info.num_instances++;
  v->asi = class->info.initial_asi;
  BZERO ((char *) v + sizeof (v->isa) + sizeof (v->asi),
	 item_size - sizeof (v->isa) - sizeof (v->asi));

  if (c_tom_Runtime_gc_atomic)
    TGC_SET_COLOUR (v->asi, TGC_WHITE);
  else
    {
      /* Put this gray object on the gray list.  */
      gray_stack_add ((void *) v);
    }

  c_tom_Runtime_gc_alloc_since_partial++;
  c_tom_Runtime_gc_num_alloc++;

  if (!c_tom_Runtime_gc_inhibit
      && c_tom_Runtime_gc_partial_threshold
      && (c_tom_Runtime_gc_alloc_since_partial
	  > c_tom_Runtime_gc_partial_threshold))
    TRT_SEND ((void (*) (void *, void *, double)), _mr_c_tom_Runtime,
	       SEL (v_garbageCollect_d),
	      ((c_tom_Runtime_gc_total_threshold
		&& (c_tom_Runtime_gc_total_threshold
		    <= (c_tom_Runtime_gc_alloc_since_total
			+ c_tom_Runtime_gc_alloc_since_partial)))
	       ? c_tom_Runtime_gc_total_time_limit
	       : c_tom_Runtime_gc_partial_time_limit));

  TRT_PANIC_MODE_V ();

  return ((void *) v);
}

tom_double
time_since_unix_epoch (void)
{
  struct timeval tv;

  gettimeofday (&tv, NULL);
  return tv.tv_sec + tv.tv_usec / 1e6;
}

void
i_tom_Block_v_gc_mark_elements (tom_object self, selector cmd)
{
  struct _es_i_tom_Block *this = trt_ext_address (self, _ei_i_tom_Block);
  struct trtd_block *bd = this->block_description;

  if (bd)
    {
      char *bv = this->variables;
      int i;

      for (i = 0; i < bd->num_vars; i++)
	if (bd->vars[i].c.type == TRT_TE_REFERENCE)
	  mark_if_needed_and_not_nil (* (void **) (bv + bd->vars[i].offset));
    }
}

void
i_tom_ObjectArray_v_gc_mark_elements (tom_object self, selector cmd)
{
  struct _es_i_tom_Array *this = trt_ext_address (self, _ei_i_tom_Array);
  int i, n;

  for (i = 0, n = this->length; i < n; i++)
    mark_if_needed_and_not_nil (((struct trt_instance **) this->contents)[i]);
}

void
i_tom_State_v_gc_mark_elements (tom_object self, selector cmd)
{
#if 0
  struct trt_refvar_offset_table *rvo = self->isa->info.rvo;
  int i;

  for (i = 1; i < rvo->st.num; i++)
    {
      struct trt_instance *ref = *(void **) ((char *) self + rvo->offset[i]);
      mark_if_needed_and_not_nil (ref);
    }
#endif
}

void
i_tom_State_v_set_kind_r (tom_object self, selector cmd, tom_object other)
{
  struct _es_i_tom_State *this = (void *) self;
  struct trt_class *oc = (void *) this->isa;
  struct trt_class *nc = (void *) other;
  int i;

  if (!TGC_CLASS_P (other->asi))
    ABORT ();

  if (oc->info.eot->st.num != trt_num_eids)
    oc->info.eot = stalloc ((void *) &oc->info.eot, sizeof (*oc->info.eot),
			    sizeof (oc->info.eot->offset[0]), trt_num_eids, 1);
  if (nc->info.eot->st.num != trt_num_eids)
    nc->info.eot = stalloc ((void *) &nc->info.eot, sizeof (*nc->info.eot),
			    sizeof (nc->info.eot->offset[0]), trt_num_eids, 1);

  /* Check for matching state.  We could allow shrinking, reordering
     extensions' state, etc.  */
  for (i = 0; i < trt_num_eids; i++)
    if (oc->info.eot->offset[i] != nc->info.eot->offset[i])
      {
	trt_raise (1, self, cmd, c_tom_Conditions_program_condition,
		   "instances carry different state");
	return;
      }

  this->isa = (void *) nc;
}

#if STACK_REF_STRUCT

/* XXX YYY ZZZ Not adopted to multi threading.
   Mon Oct 28 15:53:45 1996, tiggr@jaguar.ics.ele.tue.nl*/
static void
tgc_mark_stacks (void)
{
#if DEBUG_GC > 0
  int num = 0, num_grayed = 0, num_slot = 0;
#endif
  struct trt_protect_stack *sp;

  /* Protect the stack.  */
  for (sp = _trt_sp; sp; sp = sp->next)
    {
      struct trt_instance *o;
      void **p, ***pp;
      int i;

      GC_DEBUG (num_slot++);

      if (sp->num_locals)
	for (i = 0, p = (void *) (sp + 1); i < sp->num_locals; i++, p++)
	  {
	    o = *p;
	    GC_DEBUG (num++);
	    if (o && TGC_COLOUR (o->asi) == TGC_WHITE)
	      {
		GC_DEBUG (num_grayed++);
		trt_make_gray (o);
	      }
	  }

      if (sp->num_args)
	for (i = 0, pp = sp->arguments; i < sp->num_args; i++, pp++)
	  {
	    o = **pp;
	    GC_DEBUG (num++);
	    if (o && TGC_COLOUR (o->asi) == TGC_WHITE)
	      {
		GC_DEBUG (num_grayed++);
		trt_make_gray (o);
	      }
	  }
    }

#if DEBUG_GC > 0
  if (c_tom_Runtime_gc_debug > 2)
      fprintf (stderr, "%d: stack: %d slot%s, %d object%s, %d grayed\n",
	       trt_thread_self (), num_slot, num_slot == 1 ? "" : "s",
	       num, num == 1 ? "" : "s", num_grayed);
#endif
}

#else

/* Protect objects pointed to from the stack, when _not_ using stack
   reference structs.  */
static void
tgc_mark_stacks (void)
{
#if DEBUG_GC > 0
  int num = 0, num_grayed = 0;
#endif
  char **low, **c, **high;
  int i, n, dummy;

  /* XXX The following is a bogus reason.
     Thu Oct 24 14:42:35 1996, tiggr@jaguar.ics.ele.tue.nl */
  /* Eek!  A nested function!  And that only because I want access to NUM
     and NUM_GRAYED and I don't want them to be global or be passed as
     pointers...  */
  void
  check_for_reference (char *addr)
  {
    int i;

    for (i = 0; i < num_chunk_ranges; i++)
      if (ADDRESS_IN_RANGE (addr, &chunk_ranges[i]))
	{
	  chunk *c = (void *) ((POINTER_INT_TYPE) addr & vm_page_mask);

	  /* XXX Would it be advantageous to put an ITEM_MASK in each
	     chunk, where ITEM_MASK would be !0 for power-of-2 sized
	     items, thus avoiding the modulo here?  Another possible
	     solution is to allocate items in a zero-modulo-2 size...  */
	  if (c->item_size
	      && !((addr - (char *) &c->data) % c->item_size))
	    {
	      struct trt_instance *o = (void *) addr;

	      if (o->isa)
		{
		  GC_DEBUG (num++);
		  if (o && TGC_COLOUR (o->asi) == TGC_WHITE)
		    {
		      GC_DEBUG (num_grayed++);
		      trt_make_gray (o);
		      if (TGC_STACK_NOTIFY_P(o->asi))
			TRT_SEND (, o, SEL (v_gc_stack_notify));
		    }
		}
	    }
	}
  }

  /* Mark the current top of stack.  */
  trt_threads[trt_thread_self ()].top = &dummy;

  for (i = 0, n = trt_thread_num; n && i < trt_thread_cap; i++)
    if (trt_threads[i].bottom)
      {
	n--;

	if ((char *) trt_threads[i].top > (char *) trt_threads[i].bottom)
	  {
	    low = trt_threads[i].bottom;
	    high = trt_threads[i].top;
	  }
	else
	  {
	    low = trt_threads[i].top;
	    high = trt_threads[i].bottom;
	  }
	       
	for (c = low; c < high; c++)
	  if (*(char **) c >= lowest_range_addr)
	    check_for_reference (*(char **) c);

#if DEBUG_GC > 0
	if (c_tom_Runtime_gc_debug > 2)
	  fprintf (stderr, "%d: stack %d: %d object%s, %d grayed\n",
		   trt_thread_self (), i, num, num == 1 ? "" : "s", num_grayed);

	num = num_grayed = 0;
#endif
      }

  /* XXX What about the registers of the other threads?  */
#ifdef TGC_MARK_REGISTERS
  TGC_MARK_REGISTERS ();
#else
    {
      jmp_buf regs;
      int r;

      setjmp (regs);

      for (r = REG_PROT_START; r < REG_PROT_END; r++)
	if (((char **) regs)[r] >= lowest_range_addr)
	  check_for_reference (((char **) regs)[r]);
    }
#endif

#if DEBUG_GC > 0
  if (c_tom_Runtime_gc_debug > 2)
    fprintf (stderr, "%d: registers: %d object%s, %d grayed\n",
	     trt_thread_self (), num, num == 1 ? "" : "s", num_grayed);
#endif
}

#endif

void
tgc_collect_garbage (double seconds)
{
  /* Sweep phase administration.  */
  /* The index in CHUNKS of the current chunk list.  */
  static int sweep_slot;
  /* The index of the next object to be investigated in the current chunk.  */
  static int sweep_index;
  /* The current chunk in the current chunk list.  */
  static chunk *sweep_chunk;

  tom_double sec = seconds;
  tom_double sec_left = sec, sec_total;
  tom_double sec_protect = 0, sec_mark = 0, sec_sweep = 0;
  tom_double enter, start, now;
  unsigned long num_sweep = 0;
  int i;

#if (STACK_PROTECT == SP_MARK)
  int marked_stack_this_time = 0;
#endif

  /* Even though the method frontends' precondition state the relation
     between {seconds} and {gc_atomic}, {seconds} must absolutely be 0 if
     we're running atomically, even with condition checking switched off.  */
  if (seconds && c_tom_Runtime_gc_atomic)
    sec = sec_left = seconds = 0;

  TRT_PANIC_MODE_P ();

  enter = time_since_unix_epoch ();

  tgc_num_mark = 0;
  c_tom_Runtime_gc_alloc_since_total += c_tom_Runtime_gc_alloc_since_partial;
  c_tom_Runtime_gc_alloc_since_partial = 0;

  if (tgc_pass == TGC_PASS_NOT)
    {
      /* We start a new run.  */
      start = time_since_unix_epoch ();

      /* Make sure the container-container itself is black (not white,
         really). */
      TGC_SET_COLOUR (c_tom_Container_all_containers->asi, TGC_BLACK);

      /* Clear this run's statistics.  */
      for (i = 0; i < sizeof (tgc_num) / sizeof (*tgc_num); i++)
	tgc_num[i] = 0;

      tgc_pass = TGC_PASS_PROTECT;

      /* Protect all class objects.  This is not real protecting, since
         they are statically allocated; but they do serve as the root
         objects.  */
      for (i = 0; i < trt_metas->st.num; i++)
	{
	  void *c = trt_metas->metas[i];

	  /* Only mark this class.  There is no need to protect the meta
             class as it does not contain extra state and is itself
             statically allocated.  */
	  trt_make_gray (c);

	  /* Mark the state extensions collection if we have one.  */
	  mark_if_needed_and_not_nil
	    (((struct trt_class *) c)->info.state_extensions);
	  mark_if_needed_and_not_nil
	    (((struct trt_class *) c)->isa->info.state_extensions);

	  /* Incidentally, also protect all static class variables.
	     XXX YYY To do that in this class objects visiting loop is a
	     mistake, obviously.  */
	  {
	    struct trt_meta_extensions *exts;
	    int j, k;

	    exts = ((struct trt_class *) c)->isa->info.extensions;
	    for (j = 0; j < exts->st.num; j++)
	      {
		struct trtd_extension *ext = exts->extensions[j];

		for (k = 0; k < ext->num_statics; k++)
		  if (ext->statics[k].c.type == TRT_TE_REFERENCE)
		    {
		      void *x = ext->statics[k].address;

		      if (ext->statics[k].th_local)
			trt_mark_locals (*(int *) x);
		      else
			{
			  tom_object ref = *(tom_object *) x;
			  if (ref && (TGC_COLOUR (ref->asi) == TGC_WHITE))
			    trt_make_gray (ref);
			}
		    }
	      }
	  }
	}

#if (STACK_PROTECT == SP_PROTECT)
      tgc_mark_stacks ();
#endif

      now = time_since_unix_epoch ();
      sec_protect = now - start;
      tgc_this_protect += sec_protect;
      sec_left -= sec_protect;

      tgc_pass = TGC_PASS_MARK_GRAY;
    }

  if (tgc_pass == TGC_PASS_MARK_GRAY && (!sec || sec_left > 0))
    {
      unsigned long mark_estimate, mark_rate;

      start = time_since_unix_epoch ();
      mark_estimate = sec ? tgc_marks_per_sec * sec_left : -1;

      if (gray_num)
	while (tgc_num_mark < mark_estimate)
	  {
	    struct trt_instance *o;
	    struct trt_refvar_offset_table *rvo;
	    int i;

	    LOCK_GRAY ();
	    o = (void *) gray_objects[--gray_num];
	    UNLOCK_GRAY ();

	    TGC_SET_COLOUR (o->asi, TGC_BLACK);
	    rvo = o->isa->info.rvo;
	    tgc_num_mark++;

	    /* Protect from a NULL RVO for Top and Any.  */
	    /* XXX Why?
	       Mon Jul 27 15:32:33 1998, tiggr@gerbil.org  */
	    if (rvo)
	      {
#if DEBUG_GC > 0
		/* Skip the isa, but it still should be there.  */
		if (rvo->offset[0])
		  ABORT ();
#endif

		if (!TGC_CONTAINER_P (o->asi))
		  {
		    /* Mark the objects referenced.  */
		    for (i = 1; i < rvo->st.num; i++)
		      {
			struct trt_instance *ref;

			ref = *(void **) ((char *) o + rvo->offset[i]);
			mark_if_needed_and_not_nil (ref);
		      }
		  }
	      }

	    /* And let the object do its smart thing if so
	       desired.  */
	    if (TGC_EXPLICIT_MARK_P (o->asi))
	      TRT_SEND (, o, SEL (v_gc_mark_elements));

	    /* This elaborate GRAY_NUM checking is to avoid having to
               check it twice: once here and once in the while condition.  */
	    if (!gray_num)
	      {
#if (STACK_PROTECT == SP_MARK)
		if (!marked_stack_this_time)
		  {
		    marked_stack_this_time = 1;

		    /* XXX This is a rather atomic operation which does
		       not scale well, in the context of elapsed time
		       constrained gc, to large stacks.  */
		    tgc_mark_stacks ();

		    if (gray_num)
		      continue;
		  }
#endif

		/* Have the containers mark their elements.  */
		TRT_SEND ((void_imp), c_tom_Container_all_containers,
			  SEL (v_gc_mark_containers));

		if (!gray_num)
		  break;
	      }
	  }

      now = time_since_unix_epoch ();
      sec_mark = now - start;
      tgc_this_mark += sec_mark;
      mark_rate = tgc_num_mark / sec_mark;
      tgc_marks_per_sec = (tgc_marks_per_sec + mark_rate) / 2;
      sec_left -= sec_mark;

      if (tgc_num_mark < mark_estimate)
	/* We're done with marking!  */
	tgc_pass = TGC_PASS_SWEEP_WHITE;
    }

  if (tgc_pass == TGC_PASS_SWEEP_WHITE && (!sec || sec_left > 0))
    {
      unsigned long sweep_estimate, sweep_rate;
      tgc_vacant *v;
      int limit;

      start = time_since_unix_epoch ();

      sweep_estimate = sec ? tgc_sweeps_per_sec * sec_left : -1;

      if (!sweep_slot)
	{
	  sweep_chunk = NULL;
	  sweep_index = 0;

	  /* Initialize for the first chunk.  */
	  for (sweep_slot = SMALLEST_INDEX;
	       sweep_slot < num_slots; sweep_slot++)
	    if (chunks[sweep_slot].first)
	      {
		sweep_chunk = chunks[sweep_slot].first;
		break;
	      }
	}

      while (sweep_chunk && num_sweep < sweep_estimate)
	{
	  for (v = (void *) ((char *) &sweep_chunk->data
			     + sweep_index * SIZE_FOR_INDEX (sweep_slot)),
		 limit = sweep_chunk->cap;
	       sweep_index < limit && num_sweep < sweep_estimate;
	       sweep_index++,
		 v = (void *) ((char *) v + SIZE_FOR_INDEX (sweep_slot)))
	    {
	      num_sweep++;

	      if (!v->isa)
		tgc_num[TGC_PINK]++;
	      else switch (TGC_COLOUR (v->asi))
		{
		case TGC_GRAY:
		  /* This object has been allocated between GC marking and
		     this sweep.  Consider it having been allocated during
		     the next mark run.  It will be deallocated, if dead,
		     during the next sweep run.  */
		  tgc_num[TGC_GRAY]++;
		  break;

		case TGC_BLACK:
		  /* This is a live object.  */
		  TGC_SET_COLOUR (v->asi, TGC_WHITE);
		  tgc_num[TGC_BLACK]++;
		  break;

		case TGC_WHITE:
		  /* This is a dead object.  */
		  TRT_SEND ((void_imp), v, SEL (v_dealloc));
		  tgc_num[TGC_WHITE]++;
		  c_tom_Runtime_gc_num_dealloc++;

#if DEBUG_GC > 0
		  v->saved_isa = v->isa;

		  /* Enable Purify to be more functional.  */
		  if (c_tom_Runtime_gc_debug > 1)
		    BZERO (v + 1, SIZE_FOR_INDEX (sweep_slot) - sizeof (*v));
#endif
		  v->isa->info.num_instances--;
		  v->isa = 0;

		  if (!--sweep_chunk->num)
		    {
		      /* This chunk now is empty.  This means all remaining
			 objects in this chunk are already pink.  Remove
			 this chunk from the chunk list.  */
		      *sweep_chunk->previous_vacant = sweep_chunk->next_vacant;
		      if (sweep_chunk->next_vacant)
			sweep_chunk->next_vacant->previous_vacant
			  = sweep_chunk->previous_vacant;
		      *sweep_chunk->previous = sweep_chunk->next;
		      if (sweep_chunk->next)
			sweep_chunk->next->previous = sweep_chunk->previous;

		      /* A free chunk is identifiable by a zero item_size.  */
		      sweep_chunk->item_size = 0;

		      /* Put it on the free chunks list.  */
		      sweep_chunk->next_vacant = chunks_free;
		      sweep_chunk->previous_vacant = NULL;
		      chunks_free = sweep_chunk;
		      chunks_free_num++;

		      tgc_num_total -= sweep_chunk->cap;
		      sweep_index = limit;
		    }
		  else
		    {
		      if (!sweep_chunk->vacant_object)
			{
			  /* This chunk was full.  Not anymore.  */
			  slot_entry *slot = &chunks[sweep_slot];

			  sweep_chunk->next_vacant = slot->first_vacant;
			  if (sweep_chunk->next_vacant)
			    sweep_chunk->next_vacant->previous_vacant
			      = &sweep_chunk->next_vacant;
			  slot->first_vacant = sweep_chunk;
			  sweep_chunk->previous_vacant = &slot->first_vacant;
			}

		      v->next = sweep_chunk->vacant_object;
		      sweep_chunk->vacant_object = v;
		    }
		  break;

		default:
		  fatal ("bad colour in ASI value 0x%08x", TGC_COLOUR (v->asi));
		}
	    }

	  if (sweep_index >= limit)
	    {
	      sweep_index = 0;
	      sweep_chunk = sweep_chunk->next;

	      if (!sweep_chunk)
		{
		  for (sweep_slot++; sweep_slot < num_slots; sweep_slot++)
		    if (chunks[sweep_slot].first)
		      {
			sweep_chunk = chunks[sweep_slot].first;
			break;
		      }
		}
	    }
	}

      now = time_since_unix_epoch ();
      sec_sweep = now - start;
      tgc_this_sweep += sec_sweep;
      sweep_rate = num_sweep / sec_sweep;
      if (sweep_rate > tgc_sweeps_per_sec)
	tgc_sweeps_per_sec = (3 * tgc_sweeps_per_sec + sweep_rate) / 4;
      else
	tgc_sweeps_per_sec = (tgc_sweeps_per_sec + sweep_rate) / 4;
      sec_left -= sec_sweep;

      if (num_sweep != sweep_estimate)
	{
	  /* We're done with sweeping!  */
	  tgc_pass = TGC_PASS_NOT;
	  sweep_slot = 0;
	}
    }

  now = time_since_unix_epoch ();
  sec_total = now - enter;
  tgc_this_time += sec_total;

#if DEBUG_GC > 0
  if (c_tom_Runtime_gc_debug > 0)
    {
#if STACK_REF_STRUCT
      fprintf (stderr,
	       "%d: gc (%.3f): %.3f %.3f(%lu) %.3f(%lu) %d %.3f/%.3f %.3f\n"
	       "mark_rate=%ld sweep_rate=%ld\n", trt_thread_self (),
	       sec * 1000, sec_protect * 1000, sec_mark * 1000, tgc_num_mark,
	       sec_sweep * 1000, num_sweep, chunks_free_num,
	       sec_total * 1000, tgc_this_time * 1000, sec_left * 1000,
	       tgc_marks_per_sec, tgc_sweeps_per_sec);
#else
      fprintf (stderr,
	       "%d: gc (%.3f): %.3f %.3f(%lu) %.3f(%lu) %d+%d %.3f/%.3f %.3f\n"
	       "mark_rate=%ld sweep_rate=%ld\n", trt_thread_self (),
	       sec * 1000, sec_protect * 1000, sec_mark * 1000, tgc_num_mark,
	       sec_sweep * 1000, num_sweep, chunks_free_num,
	       chunk_ranges[num_chunk_ranges - 1].num - range_first_empty,
	       sec_total * 1000, tgc_this_time * 1000, sec_left * 1000,
	       tgc_marks_per_sec, tgc_sweeps_per_sec);
#endif
    }
#endif

  c_tom_Runtime_gc_num_runs++;
  if (tgc_pass == TGC_PASS_NOT)
    {
#if DEBUG_GC > 0
      if (c_tom_Runtime_gc_debug > 0)
	{
	  unsigned long free, total;

	  free = tgc_num[TGC_WHITE] + tgc_num[TGC_PINK];
	  total = free + tgc_num[TGC_GRAY] + tgc_num[TGC_BLACK];

	  fprintf (stderr,
		   "%d: stats: white: %lu gray: %lu black: %lu pink: %lu "
		   "o/t: %lu/%lu (%.2f)\ntimes: %.3f %.3f %.3f\n",
		   trt_thread_self (), tgc_num[TGC_WHITE], tgc_num[TGC_GRAY],
		   tgc_num[TGC_BLACK], tgc_num[TGC_PINK],
		   total - free, total, (double) (total - free) / total,
		   tgc_this_protect * 1000, tgc_this_mark * 1000,
		   tgc_this_sweep * 1000);
	}
#endif

      c_tom_Runtime_gc_total_protect += tgc_this_protect;
      c_tom_Runtime_gc_total_mark += tgc_this_mark;
      c_tom_Runtime_gc_total_sweep += tgc_this_sweep;
      c_tom_Runtime_gc_total_all += tgc_this_time;
      c_tom_Runtime_gc_alloc_since_total = 0;
      c_tom_Runtime_gc_num_complete++;

      tgc_this_protect = tgc_this_mark = tgc_this_sweep = tgc_this_time = 0;

      c_tom_Runtime_gc_atomic = c_tom_Runtime_gc_atomic_next;
    }

  TRT_PANIC_MODE_V ();
}