/* libsizzle/gc.c - garbage collector implementation
 
  Copyright (C) 1999, 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2, or (at your option)
  any later version.
  
  This software 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 General Public License for more details.
  
  You should have received a copy of the GNU General Public License
  along with this package; see the file COPYING.  If not, write to
  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  Boston, MA 02111-1307, USA.  */

#if HAVE_CONFIG_H
# include <config.h>
#endif 

#include <assert.h>
#include <stdlib.h>
#include <stdarg.h>
#define _GNU_SOURCE
#include <stdio.h>
#include <string.h>
#if HAVE_TIMES
#include <sys/times.h>
#endif
#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#include "alloc.h"
#include "gc.h"
#include "node.h"
#include "eval.h"
#include "cvar.h"
#include "capi.h"
#include "vector.h"
#include "port.h"


/* Cell chunks and free lists ===================================== */

/* Cell chunk management.  Cells are allocated in chunks of
  CELLS_PER_*_CHUNK entries to reduce memory management overhead. The
  term -1 is necessary for alignment of cell chunks */
#define CELLS_PER_TAGGED_CHUNK ((1024*64) - 1) 
#define CELLS_PER_CONS_CHUNK ((1024*64) - 1)

/* Chunks for tagged cells are kept in this structure.  */
typedef struct tagged_cell_chunk * tagged_cell_chunk_t;
struct tagged_cell_chunk
{
  tagged_cell_chunk_t next;	/* Next chunk in list.  */
  tagged_cell_chunk_t start;	/* Real start of malloc()ed chunk.  */
  zzz_object_t padding[2];	/* Necessary for alignment of the
                                   following array.  */
  struct zzz_tagged cells[CELLS_PER_TAGGED_CHUNK]; /* The data area. */
};

typedef struct cons_cell_chunk * cons_cell_chunk_t;
struct cons_cell_chunk
{
  cons_cell_chunk_t next;	/* Next chunk in list.  */
  cons_cell_chunk_t start;	/* Real start of malloc()ed chunk.  */
  struct zzz_scm cells[CELLS_PER_CONS_CHUNK]; /* The data area. */
};

/* Two different lists of chunks are maintained.  One for cons cells and
   another one for tagged heap cells.  */

/* List of all tagged cell chunks.  */
static tagged_cell_chunk_t tagged_cell_chunk_root = NULL;

/* Freelist for tagged cells.  */
static zzz_tagged_t tagged_cell_root = NULL;

/* List of all cons cell chunks.  */
static cons_cell_chunk_t cons_cell_chunk_root = NULL;

/* Freelist for cons cells.  */
static zzz_scm_t cons_cell_root = NULL;

/* Statistics and gc control variables ============================ */

/* Statistics.  */
static int gc_count;		/* Garbage collection counter. */
static unsigned gc_time;	/* Time spent in gc in clock ticks.  */
static unsigned gc_percent;	/* Percent of runtime taken by gc.  */
static int allocated_tagged_cells; /* # of alloced tagged cells.  */
static int used_tagged_cells;	/* # of tagged cells in use.  */
static int allocated_cons_cells;	/* # of alloced cons cells.  */
static int used_cons_cells;	/* # of cons cells in use.  */
static int allocation_limit = 50000; /* # of allocations before GC.  */
static int allocations = 50000;	/* # of allocations pending until GC.  */

static unsigned cons_heap_usage; /* # of bytes for cons heap.  */
static unsigned tagged_heap_usage; /* # of bytes for tagged heap.  */

/* Garbage collection control.  */
static unsigned gc_lock;	/* GC is locked when greater than
                                   zero.  */
static unsigned gc_requested;	/* True, if GC was requested while
                                   locked.  */
static int gc_message;		/* If true, print GC messages. */

/* This variable is true during shutdown.  */
int zzz_terminating = 0;

/* This is a pointer to a zzz_scm_t value on the C stack whose address is
   guaranteed to be larger than any other stack variable
   address. Needed for conservative garbage collection. */
zzz_scm_t * zzz_top_of_c_stack;

/* Static protection types and variables ========================== */

/* Protection pointers are allocated in chunks of this many pointers.  */
#define POINTERS_PER_PROTECT_AREA 1024

/* Scheme objects which are alive through the runtime of the process
   can be registered as being globally protected.  Information about
   such variables is held in a list of protection areas.  */
typedef struct protect_area * protect_area_t;
struct protect_area
{
  protect_area_t next;		/* Next area in list.  */
  int index;			/* Next free entry in array below.  */
  zzz_scm_t * ptrs[POINTERS_PER_PROTECT_AREA]; /* Pointer array. */
};

/* Head of the list of protect areas.  This list is traversed for
   marking all globally protected zzz_scm_t variables.  */
static protect_area_t global_protect_root;



/* Symbols used for the output association list of @code{gc-stats}.  */
static zzz_scm_t used_cons_cells_sym;
static zzz_scm_t used_tagged_cells_sym;
static zzz_scm_t allocated_cons_cells_sym;
static zzz_scm_t allocated_tagged_cells_sym;
static zzz_scm_t gc_count_sym;
static zzz_scm_t gc_time_sym;
static zzz_scm_t gc_percent_sym;
static zzz_scm_t gc_cons_heap_usage_sym;
static zzz_scm_t gc_tagged_heap_usage_sym;
static zzz_scm_t gc_other_usage_sym;



/* Protect the location to which SCM points globally from garbage
   collection.  */
result_t
zzz_protect_global (zzz_scm_t * scm)
{
  protect_area_t area;

  if (!global_protect_root ||
      global_protect_root->index >= POINTERS_PER_PROTECT_AREA)
    {
      area = zzz_malloc (sizeof (struct protect_area));
      area->next = global_protect_root;
      area->index = 0;
      global_protect_root = area;
    }
  global_protect_root->ptrs[global_protect_root->index++] = scm;
  return RESULT_SUCCESS;
}



/* Create a new chunk of tagged cells and initialize it.  The chunk is
  chained onto the global tagged cell chunk list and all new cells are
  chained onto the tagged cell freelist.  */
static void
new_tagged_cell_chunk (void)
{
  tagged_cell_chunk_t orig, chunk;
  zzz_tagged_t c;

  if (gc_message)
    fprintf (stderr, "%s\n", _("--Growing tagged cell heap--"));
  chunk = zzz_malloc (sizeof (struct tagged_cell_chunk)+16); /* +16
                                                                for
                                                                padding */
  orig = chunk;

  tagged_heap_usage += sizeof (struct tagged_cell_chunk) + 16;

  /* Tagged cell chunks *must* be aligned to an 16-byte boundary.  */
  chunk = (tagged_cell_chunk_t) (((zzz_object_t) chunk + 15) & ~15);
  chunk->next = tagged_cell_chunk_root;
  chunk->start = orig;
  tagged_cell_chunk_root = chunk;
  for (c = chunk->cells; c < chunk->cells + (CELLS_PER_TAGGED_CHUNK - 1); c++)
    {
      c->fill[0] = (zzz_object_t) 2;
      c->fill[1] = (zzz_object_t) (c + 1);
    }
  c->fill[0] = (zzz_object_t) 2;
  c->fill[1] = (zzz_object_t) tagged_cell_root;
  tagged_cell_root = chunk->cells;
  allocated_tagged_cells += CELLS_PER_TAGGED_CHUNK;
  assert (allocated_tagged_cells > 0);
  assert ((((zzz_object_t) chunk->cells) & 15) == 0);
}

zzz_scm_t
zzz_create_tagged_cell (zzz_object_t tag, void * data0,
			void * data1, void * data2)
{
  zzz_tagged_t cell;

  assert (tag > 0 && (tag & 0xffff) < zzz_type_descriptor_count);

  allocations--;
  if (!tagged_cell_root)
    {
      if (allocations <= 0)
	{
	  zzz_garbage_collect ();
	  allocations = allocation_limit;
	}
      if (!tagged_cell_root)
	new_tagged_cell_chunk ();
/*        else  */
	{
	  while ((used_tagged_cells * 100) / allocated_tagged_cells > 50)
	    new_tagged_cell_chunk ();
	}
    }
  cell = tagged_cell_root;
  tagged_cell_root = (zzz_tagged_t) cell->fill[1];
  assert ((((zzz_object_t) cell) & 15) == 0);

  cell->fill[0] = (zzz_object_t) (tag << 3);
  zzz_type_descriptors[tag & 0xffff].constructor_func (cell, data0,
						       data1, data2);
  used_tagged_cells++;
  assert (used_tagged_cells > 0);
  cell = ptr_to_tagged(cell);
  return (zzz_scm_t) cell;
}



/* Create a new chunk of cons cells and initialize it.  The chunk is
  chained onto the global cons cell chunk list and all new cells are
  chained onto the cons cell freelist.  */
static void
new_cons_cell_chunk (void)
{
  cons_cell_chunk_t orig, chunk;
  zzz_scm_t c;

  if (gc_message)
    fprintf (stderr, "%s\n", _("--Growing cons heap--"));
  chunk = zzz_malloc (sizeof (struct cons_cell_chunk) + 8); /* +8 for
                                                               padding */
  orig = chunk;

  cons_heap_usage += sizeof (struct cons_cell_chunk) + 8;

  /* Cons chunks *must* be aligned to an 8-byte boundary.  */
  chunk = (cons_cell_chunk_t) (((zzz_object_t) chunk + 7) & ~7);
  chunk->next = cons_cell_chunk_root;
  chunk->start = orig;
  cons_cell_chunk_root = chunk;
  for (c = chunk->cells; c < chunk->cells + (CELLS_PER_CONS_CHUNK - 1); c++)
    {
      c->ccar = (zzz_scm_t) 2;
      c->ccdr = c + 1;
    }
  c->ccar = (zzz_scm_t) 2;
  c->ccdr = cons_cell_root;
  cons_cell_root = chunk->cells;
  allocated_cons_cells += CELLS_PER_CONS_CHUNK;
  assert (allocated_cons_cells > 0);
}

/* Allocate a cons cell and return a pointer to it.  Invoke garbage
  collection and increase cell heap size if necessary.  */
zzz_scm_t
zzz_alloc_cons_cell (void)
{
  zzz_scm_t c;

  assert (used_cons_cells >= 0);
  if (allocations <= 0)
    {
      zzz_garbage_collect ();
      allocations = allocation_limit;
    }
  if (!cons_cell_root)
    new_cons_cell_chunk ();
/*    else  */
    {
      while ((used_cons_cells * 100) / allocated_cons_cells > 50)
	new_cons_cell_chunk ();
    }
  c = cons_cell_root;
  cons_cell_root = c->ccdr;
  assert ((((zzz_object_t) c) & 7) == 0);
  return c;
}

/* Creates a cons cell with car and cdr initialized to the values of
   @var{car} and @var{cdr}, respectively.  */
zzz_scm_t
zzz_cons (zzz_scm_t car, zzz_scm_t cdr)
{
  zzz_scm_t new_cell;

  allocations--;
  if (cons_cell_root)
    {
      new_cell = cons_cell_root;
      cons_cell_root = new_cell->ccdr;
    }
  else
    new_cell = zzz_alloc_cons_cell ();
  new_cell->ccar = car;
  new_cell->ccdr = cdr;
  used_cons_cells++;
  return new_cell;
}



/* Mark the cell pointed to by CELL as being in use as well as all
   cells transitively referenced by CELL.  Do nothing if CELL is '(),
   a fixnum or an immediate value.  */
void
zzz_mark_cell (zzz_scm_t cell)
{
  /* Some sanity checking.  Do not allow free cell. */
  assert (!(((zzz_object_t) cell) == 2));

  if (gc_imm_p(cell))
    return;
  if (marked_p (cell))
    return;
  if (gc_cons_p (cell))
    {
      while (gc_cons_p (cell))
	{
	  if (marked_p (cell))
	    return;
	  mark_car (cell);
	  zzz_mark_cell (unmarked (car (cell)));
	  cell = cdr (cell);
	}
      if (!gc_null_p (cell))
	{
	  zzz_mark_cell (cell);
	}
    }
  else
    {
      mark_car (cell);
      assert (tagged_type (cell) > 0 && tagged_type (cell) <
	      zzz_type_descriptor_count);
      if (zzz_type_descriptors[tagged_type (cell)].mark_func)
	zzz_type_descriptors[tagged_type (cell)].mark_func
	  (to_tagged_ptr (cell));
    }
}

/* Walk the cons and the tagged heap cell and put all cells not marked
   onto the free list; remove all marks from marked cells.  */
static void
sweep (void)
{
  tagged_cell_chunk_t t_chunk;
  cons_cell_chunk_t c_chunk;
  zzz_scm_t c_c;
  zzz_tagged_t t_c;

  for (c_chunk = cons_cell_chunk_root; c_chunk; c_chunk = c_chunk->next)
    {
      for (c_c = c_chunk->cells; c_c < c_chunk->cells + CELLS_PER_CONS_CHUNK;
	   c_c++)
	{
	  if (car (c_c) != (zzz_scm_t) 2)
	    {
	      if (marked_p (c_c))
		unmark_car (c_c);
	      else
		{
		  c_c->ccar = (zzz_scm_t) 2;
		  c_c->ccdr = cons_cell_root;
		  cons_cell_root = c_c;
		  used_cons_cells--;
		}
	    }
	}
    }
  for (t_chunk = tagged_cell_chunk_root; t_chunk; t_chunk = t_chunk->next)
    {
      for (t_c = t_chunk->cells; t_c < t_chunk->cells +
	     CELLS_PER_TAGGED_CHUNK; t_c++)
	{
	  if (t_c->fill[0] != (zzz_object_t) 2)
	    {
	      if (t_c->fill[0] & 4)
		t_c->fill[0] &= ~4;
	      else
		{
		  if (zzz_type_descriptors[tagged_type (t_c)].free_func)
		    zzz_type_descriptors[tagged_type (t_c)].free_func (t_c);
		  t_c->fill[0] = (zzz_object_t) 2;
		  t_c->fill[1] = (zzz_object_t) tagged_cell_root;
		  tagged_cell_root = t_c;
		  used_tagged_cells--;
		}
	    }
	}
    }
}

/* Conservatively mark all cells reachable from any possible pointers
   in the memory area betwenn START and END.  */
void
zzz_mark_area (zzz_scm_t * start, zzz_scm_t * end)
{
  zzz_scm_t * ptr;
  tagged_cell_chunk_t t_chunk;
  cons_cell_chunk_t c_chunk;
  zzz_scm_t c_c;
  zzz_tagged_t t_c;

  assert ((((zzz_object_t) start) & (sizeof (void *) - 1)) == 0);

  for (ptr = start; ptr < end; ptr++)
    {

      if ((((zzz_object_t) *ptr) & 7) == 0)
	{
	  c_c = *ptr;
	  for (c_chunk = cons_cell_chunk_root; c_chunk;
	       c_chunk = c_chunk->next)
	    {
	      if (c_c >= c_chunk->cells &&
		  c_c < c_chunk->cells + CELLS_PER_CONS_CHUNK)
		{
		  if (c_c->ccar != (zzz_scm_t) 2)
		    zzz_mark_cell (*ptr);
		  else if (gc_message)
		    fprintf (stderr, "pointer to free cons cell at %p\n", ptr);
		  break;
		}	  
	    }
	}
      else if ((((zzz_object_t) *ptr) & 15) == 2)
	{
	  t_c = (zzz_tagged_t) (((zzz_object_t) *ptr) & ~7);
	  assert ((((zzz_object_t) t_c) & 15) == 0);
	  for (t_chunk = tagged_cell_chunk_root; t_chunk;
	       t_chunk = t_chunk->next)
	    {
	      if (t_c >= t_chunk->cells &&
		  t_c < t_chunk->cells + CELLS_PER_TAGGED_CHUNK)
		{
		  if (t_c->fill[0] != (zzz_object_t) 2)
		    zzz_mark_cell (*ptr);
		  else if (gc_message)
		    fprintf (stderr, "pointer to free tagged cell at %p\n",
			     ptr);
		  break;
		}
	    }
	}
    }
}

/* Walk through the C stack and mark all objects in one of the two
   heaps which are pointed to by any stack location.  */
static void
mark_c_stack_variables (void)
{
  jmp_buf jbuf;
  /* Make sure that the stack bottom is below the jmp_buf structure.  */
  zzz_scm_t * bottom_of_c_stack = (zzz_scm_t *) &jbuf;

  if (gc_message)
    fprintf (stderr, "--C stack: %8p-%8p--\n", bottom_of_c_stack,
	     zzz_top_of_c_stack);
  FLUSH_REGISTER_WINDOWS();
  /* Try hard to get register contents onto the C stack.  I hope
     setjmp() will do the job (together with register window flushing
     above).  */
  setjmp (jbuf);
  
  /* PORTABILITY-NOTE: This depends on the stack to grow downwards. */
  zzz_mark_area (bottom_of_c_stack, zzz_top_of_c_stack);
}

/* Mark the spine of the list @var{list}, but do not mark the list
   elements themselves.  */
static void
mark_list_spine (zzz_scm_t list)
{
  while (gc_cons_p (list))
    {
      mark_car (unmarked (list));
      list = cdr (list);
    }
}

/* Restore a valid list from @var{list}, which may have freed entries.  */
static void
revalidate_list (zzz_scm_t * list)
{
  assert (list_p (*list));
  while (cons_p (*list))
    {
      if (tagged_p (car (*list)) &&
	  tagged_type (car (*list)) == zzz_tagged_type_free)
	{
/*  	  fprintf (stderr, "freed list entry found, reclaiming\n"); */
	  *list = cdr (*list);
	}
      else
	list = cdr_addr (*list);
    }
}

/* Mark the symbol table data structures, but do not mark the symbols
   in the table, so that we can delete the unused symbols from the
   table after sweeping the heap.  */
static void
mark_symbol_table (void)
{
  unsigned i;
  zzz_scm_t c;

  if (!zzz_symbol_table)	/* In case we're not initialized.  */
    return;
  for (i = 0; i < vector_len (zzz_symbol_table); i++)
    {
      c = zzz_vector_get (zzz_symbol_table, i);
      while (gc_cons_p (c))
	{
	  if (symbol_value (car (c)) != zzz_undefined)
	    {
	      zzz_mark_cell (car (c));
	    }
	  mark_car (unmarked (c));
	  c = cdr (c);
	}
    }
  mark_car (zzz_symbol_table);
}

/* Mark the keyword table data structures, but do not mark the
   keywords in the table, so that we can delete the unused keywords
   from the table after sweeping the heap.  */
static void
mark_keyword_table (void)
{
  unsigned i;
  zzz_scm_t c;

  if (!zzz_keyword_table)	/* In case we're not initialized.  */
    return;
  for (i = 0; i < vector_len (zzz_keyword_table); i++)
    {
      c = zzz_vector_get (zzz_keyword_table, i);
      mark_list_spine (c);
    }
  mark_car (zzz_keyword_table);
}

/* After sweeping, delete all symbol table entries which hold now
   freed symbols from the symbol table.  */
static void
reclaim_symbol_table (void)
{
  unsigned i;
  zzz_scm_t c, prev;

  if (!zzz_symbol_table)	/* In case we're not initialized.  */
    return;
  for (i = 0; i < vector_len (zzz_symbol_table); i++)
    {
      prev = NULL;
      c = zzz_vector_get (zzz_symbol_table, i);
      revalidate_list (&c);
      zzz_vector_put (zzz_symbol_table, i, c);
    }
  for (i = 0; i < vector_len (zzz_symbol_table); i++)
    {
      c = zzz_vector_get (zzz_symbol_table, i);
      assert (list_p (c));
      while (cons_p (c))
	{
	  assert (symbol_p (car (c)));
	  c = cdr (c);
	}
    }
}

/* After sweeping, delete all keyword table entries which hold now
   freed keywords from the symbol table.  */
static void
reclaim_keyword_table (void)
{
  unsigned i;
  zzz_scm_t c, prev;

  if (!zzz_keyword_table)	/* In case we're not initialized.  */
    return;
  for (i = 0; i < vector_len (zzz_keyword_table); i++)
    {
      prev = NULL;
      c = zzz_vector_get (zzz_keyword_table, i);
      revalidate_list (&c);
      zzz_vector_put (zzz_keyword_table, i, c);
    }
  for (i = 0; i < vector_len (zzz_keyword_table); i++)
    {
      c = zzz_vector_get (zzz_keyword_table, i);
      assert (list_p (c));
      while (cons_p (c))
	{
	  assert (keyword_p (car (c)));
	  c = cdr (c);
	}
    }
}

/* Return all unreferenced cells to their respective free list, making
   them available for new allocation.  */
void
zzz_garbage_collect (void)
{
  long i;
  protect_area_t area;
#if HAVE_TIMES
  struct tms begin_tms, end_tms;
#endif
  
  if (gc_lock)
    {
      gc_requested++;
      return;
    }
  gc_count++;
  if (gc_message)
    fprintf (stderr, "%s\n", _("--Garbage Collection--"));

#if HAVE_TIMES
  times (&begin_tms);
#endif

  /* Mark all globally accessible objects.  */
  for (i = 0; i < 256; i++)
    zzz_mark_cell (zzz_char_values[i]);

  area = global_protect_root;
  while (area)
    {
      for (i = 0; i < area->index; i++)
	zzz_mark_cell (*area->ptrs[i]);
      area = area->next;
    }
  mark_c_stack_variables();

  mark_symbol_table ();
  mark_keyword_table ();

  zzz_run_after_mark_hook ();

  /* Now sweep all unmarked objects from memory.  */
  sweep ();

  reclaim_symbol_table ();
  reclaim_keyword_table ();

  zzz_run_after_sweep_hook ();

#if HAVE_TIMES
  times (&end_tms);
  gc_time += (end_tms.tms_utime + end_tms.tms_stime)
    - (begin_tms.tms_utime + begin_tms.tms_stime);
#endif
}

void
zzz_gc_lock (void)
{
  gc_lock++;
}

void 
zzz_gc_unlock (void)
{
  gc_lock--;
  if (!gc_lock && gc_requested)
    {
      zzz_garbage_collect ();
      gc_requested = 0;
    }
}

/*:doc
  gc-stats
  (gc-stats) => alist
  Return an association list with some garbage collection statistics.
  doc:*/
#define FUNC_NAME "gc-stats"
static result_t
gc_stats (zzz_scm_t env, zzz_scm_t * result)
{
  *result = zzz_make_list
    (zzz_cons (used_cons_cells_sym, zzz_make_integer (used_cons_cells)),
     zzz_cons (used_tagged_cells_sym, zzz_make_integer (used_tagged_cells)),
     zzz_cons (allocated_cons_cells_sym,
	       zzz_make_integer (allocated_cons_cells)),
     zzz_cons (allocated_tagged_cells_sym,
	       zzz_make_integer (allocated_tagged_cells)),
     zzz_cons (gc_cons_heap_usage_sym, zzz_make_integer (cons_heap_usage)),
     zzz_cons (gc_tagged_heap_usage_sym, zzz_make_integer (tagged_heap_usage)),
     zzz_cons (gc_other_usage_sym,
	       zzz_make_integer (zzz_allocated_bytes -
				 cons_heap_usage -
				 tagged_heap_usage)),
     zzz_cons (gc_count_sym, zzz_make_integer (gc_count)),
     zzz_cons (gc_time_sym, zzz_make_integer (gc_time)),
     zzz_eval_time_taken ?
     zzz_cons (gc_percent_sym,
	       zzz_make_integer ((gc_time * 100) / zzz_eval_time_taken)) :
     zzz_cons (gc_percent_sym, zzz_make_integer (0)),
     NULL);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Initialize the memory management. */
void
zzz_init_gc_variables (void)
{
  zzz_protect_global (&used_cons_cells_sym);
  zzz_protect_global (&used_tagged_cells_sym);
  zzz_protect_global (&allocated_cons_cells_sym);
  zzz_protect_global (&allocated_tagged_cells_sym);
  zzz_protect_global (&gc_cons_heap_usage_sym);
  zzz_protect_global (&gc_tagged_heap_usage_sym);
  zzz_protect_global (&gc_other_usage_sym);
  zzz_protect_global (&gc_count_sym);
  zzz_protect_global (&gc_time_sym);
  zzz_protect_global (&gc_percent_sym);

  used_cons_cells_sym = zzz_make_symbol ("used-cons-cells", -1);
  used_tagged_cells_sym = zzz_make_symbol ("used-tagged-cells", -1);
  allocated_cons_cells_sym = zzz_make_symbol ("allocated-cons-cells", -1);
  allocated_tagged_cells_sym = zzz_make_symbol ("allocated-tagged-cells", -1);
  gc_cons_heap_usage_sym = zzz_make_symbol ("cons-heap-usage", -1);
  gc_tagged_heap_usage_sym = zzz_make_symbol ("tagged-heap-usage", -1);
  gc_other_usage_sym = zzz_make_symbol ("other-usage", -1);
  gc_count_sym = zzz_make_symbol ("gc-count", -1);
  gc_time_sym = zzz_make_symbol ("gc-time", -1);
  gc_percent_sym = zzz_make_symbol ("gc-percent", -1);
 
  zzz_define_function ("gc-stats", (zzz_prim_t) gc_stats, argv_0_0_0);
  /*:doc
    gc-message
    Boolean variable
    If set to @var{#t}, messages will printed whenever garbage collection
    takes place.
    doc:*/
  zzz_bind_bool_variable ("gc-message", &gc_message, 0);
}

void
zzz_init_gc (void)
{
  /* No-op for now.  */
}

/* Free all resources taken by the memory manager.  */
void
zzz_finalize_gc (void)
{
  tagged_cell_chunk_t t_chunk;
  cons_cell_chunk_t c_chunk;
  protect_area_t area;

  zzz_terminating++;

  /* Sweep without mark frees all remaining cells.  */
  sweep ();

  /* Get rid of cell memory and the protection array. */
  while (cons_cell_chunk_root)
    {
      c_chunk = cons_cell_chunk_root;
      cons_cell_chunk_root = c_chunk->next;
      zzz_free (c_chunk->start, sizeof (struct cons_cell_chunk) + 8);
    }
  cons_cell_root = NULL;
  while (tagged_cell_chunk_root)
    {
      t_chunk = tagged_cell_chunk_root;
      tagged_cell_chunk_root = t_chunk->next;
      zzz_free (t_chunk->start, sizeof (struct tagged_cell_chunk) + 16);
    }
  tagged_cell_root = NULL;
  while (global_protect_root)
    {
      area = global_protect_root;
      global_protect_root = area->next;
      zzz_free (area, sizeof (struct protect_area));
    }

  gc_count = 0;
  gc_time = 0;
  gc_percent = 0;
  allocated_tagged_cells = 0;
  used_tagged_cells = 0;
  allocated_cons_cells = 0;
  used_cons_cells = 0;
  allocation_limit = 20000;
  allocations = 20000;

  cons_heap_usage = 0;
  tagged_heap_usage = 0;
  
  gc_lock = 0;
  gc_requested = 0;
  gc_message = 0;

  zzz_top_of_c_stack = NULL;
  zzz_terminating--;
}

void
zzz_set_top_of_stack (zzz_scm_t * cell)
{
  zzz_top_of_c_stack = cell;
}
