#define _POSIX_C_SOURCE 199309L

#include <assert.h>
#include <ctype.h>
#include <inttypes.h>
#include <setjmp.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>

#include "gc.h"
#include "builtin.h"

#if 1
#define ENABLE_BACKTRACE
#include <execinfo.h>
#endif

/****************************************************************************/

#if _CLOCK_MONOTONIC
#  define TIMING_CLOCK CLOCK_MONOTONIC
#else
#  define TIMING_CLOCK CLOCK_REALTIME
#endif

#define FLAG_PROC_BIT  ((uint8_t)0x20)
#define FLAG_LIVE_BIT  ((uint8_t)0x10)

#define FLAG_GC_BITS   ((uint8_t)0x30)
#define FLAG_TAG_BITS  ((uint8_t)0x0f)

/* Helper macros to reduce duplication */
#define VECTOR_BYTES(nelem)    (sizeof(vector_t) + (sizeof(value_t) * (nelem)))
#define BYTESTR_BYTES(nbytes)  (sizeof(byte_string_t) + (nbytes))
#define STRUCT_BYTES(nslots)   (sizeof(struct_t) + (sizeof(value_t) * (nslots)))

#define GC_MIN(x, y)  (((y)<(x))?(y):(x))
#define GC_MAX(x, y)  (((y)>(x))?(y):(x))

#define GC_DEBUG_LEVEL_TRACE 3
#define GC_DEBUG_LEVEL_INFO  2
#define GC_DEBUG_LEVEL_WARN  1
#define GC_DEBUG_LEVEL_QUIET 0

#define debug_warn(fmt, args...) \
  ((gc_debug_level >= GC_DEBUG_LEVEL_WARN) ? (void)(fprintf(stderr,fmt,##args)) : (void)0)

#define debug_info(fmt, args...) \
  ((gc_debug_level >= GC_DEBUG_LEVEL_INFO) ? (void)(fprintf(stderr,fmt,##args)) : (void)0)

#define debug_trace(fmt, args...) \
  ((gc_debug_level >= GC_DEBUG_LEVEL_TRACE) ? (void)(fprintf(stderr,fmt,##args)) : (void)0)

/****************************************************************************/

typedef struct seen_value
{
  value_t value;
  struct seen_value *prev;
} seen_value_t;

/****************************************************************************/

const char *const object_tag_names[16] = {
  "special", "box",         "weak box", "pair", "fpnum", "builtin", "(6)",  "(7)",
  "vector",  "byte string", "struct",   "will", "(12)",  "(13)",    "(14)", "(15)"
};

object_block_t object_blocks[OBJECT_BLOCK_MAX + 1];
gc_stats_t     gc_stats;

static value_t gc_free_list;
static value_t gc_weak_box_list;
static value_t gc_will_list;
static value_t gc_will_active_list;
static value_t gc_next_live_value;

static size_t gc_live_bytes;   /* as of last GC pass */
static size_t gc_total_bytes;  /* as of last allocate_object()/free_object() or GC pass */

static bool gc_enabled;

static gc_root_t gc_root_list = {
  .value = UNDEFINED,
  .prev  = &gc_root_list,
  .next  = &gc_root_list
};

static gc_root_t structure_type_root;

static int gc_debug_level = GC_DEBUG_LEVEL_QUIET;

/****************************************************************************/

static inline value_t value_from_index(int blk, int idx);

static void allocate_block(void);
static value_t allocate_object(int tag);
static void free_object(value_t value);
static void clear_gc_flag_bits(void);

static inline bool is_object_live(value_t value);
static inline bool is_object_processed(value_t value);
static inline void set_object_live(value_t value);
static inline void set_object_processed(value_t value);
static inline void clear_object_live(value_t value);
static inline void clear_object_processed(value_t value);

/* The 'will' accessors are private to the GC, unlike other similar routines. */
static inline bool is_will(value_t value);
static inline will_t *get_will(value_t value);
static value_t make_will(value_t value, value_t finalizer);

/****************************************************************************/

static inline uint8_t *_get_flags(value_t value)
{
  return &object_blocks[OBJECT_BLOCK(value)].flag_bits[OBJECT_INDEX(value)];
}

static inline value_t value_from_index(int blk, int idx)
{
  int tag = (int)object_blocks[blk].flag_bits[idx] & FLAG_TAG_BITS;

  /* Unallocated objects have zeroed flag bitfields */
  if (tag == 0) return UNDEFINED;

  return OBJECT(blk, idx, tag);
}

static void allocate_block(void)
{
  int blk;

  for (blk = 0; blk <= OBJECT_BLOCK_MAX; ++blk)
  {
    object_block_t *block = &object_blocks[blk];

    /* stop at first unallocated block */
    if (!block->objects)
    {
      int idx;

      block->objects = (object_t*)calloc(OBJECT_INDEX_MAX+1, sizeof(object_t));

      if (!block->objects)
      {
        release_assert(NOTREACHED("out of memory"));
        return;
      }

      block->flag_bits = (uint8_t*)calloc(OBJECT_INDEX_MAX+1, sizeof(uint8_t));

      if (!block->flag_bits)
      {
        free(block->objects);
        block->objects = NULL;
        release_assert(NOTREACHED("out of memory"));
        return;
      }

      /* Connect the objects inside the block into a linked list */
      for (idx = 0; idx < OBJECT_INDEX_MAX; ++idx)
      {
        /* Any object type would work here; box is simplest */
        block->objects[idx].next = OBJECT(blk, idx+1, OBJECT_TAG_BOX);
      }

      /* Prepend the list of objects in the block to the free list */
      block->objects[OBJECT_INDEX_MAX].next = gc_free_list;
      gc_free_list = OBJECT(blk, 0, OBJECT_TAG_BOX);

      return;
    }
  }

  /* reached end of block array without finding any unallocated */
  release_assert(NOTREACHED("out of object blocks"));
}

static value_t allocate_object(int tag)
{
  assert((0 <= tag) && (tag <= 15));

  /*
  ** Run GC when total memory used is 75% more than either total
  ** live after last GC pass, or 4MB, whichever is greater.
  */
  if ((4 * gc_total_bytes) >= (7 * GC_MAX(gc_live_bytes, 4 * 1024 * 1024)))
  {
    if (gc_enabled)
    {
      collect_garbage();
    }
  }

  if (is_nil(gc_free_list))
  {
    allocate_block();
    assert(!is_nil(gc_free_list));
  }

  {
    int blk = OBJECT_BLOCK(gc_free_list);
    int idx = OBJECT_INDEX(gc_free_list);
    value_t result = OBJECT(blk, idx, tag);

    gc_free_list    = _get_object(gc_free_list)->next;
    gc_total_bytes += sizeof(object_t);

    *_get_flags(result) = (uint8_t)tag;
    memset(_get_object(result), 0, sizeof(object_t));

    return result;
  }
}

static void free_object(value_t value)
{
  object_t *obj = _get_object(value);

  if (is_vector(value))
  {
    gc_total_bytes -= VECTOR_BYTES(obj->vector->nelements);
    free(obj->vector);
  }
  else if (is_byte_string(value))
  {
    gc_total_bytes -= BYTESTR_BYTES(obj->byte_string->nbytes);
    free(obj->byte_string);
  }
  else if (is_struct(value))
  {
    gc_total_bytes -= STRUCT_BYTES(obj->structure->nslots);
    free(obj->structure);
  }
  else if (is_will(value))
  {
    gc_total_bytes -= sizeof(will_t);
    free(obj->will);
  }

  *_get_flags(value) = 0;
  obj->next = gc_free_list;

  gc_total_bytes -= sizeof(object_t);
  gc_free_list = value;
}

/* Prepare for GC by clearing all "live" and "processed" bits */
static void clear_gc_flag_bits(void)
{
  int blk;

  for (blk = 0; (blk <= OBJECT_BLOCK_MAX) && object_blocks[blk].objects; ++blk)
  {
    object_block_t *block = &object_blocks[blk];
    int idx;

    for (idx = 0; idx <= OBJECT_INDEX_MAX; ++idx)
    {
      block->flag_bits[idx] &= ~FLAG_GC_BITS;
    }
  }
}

static inline bool is_object_live(value_t v)
{
  /* non-objects can't be added to the free list, so they're always "live" */
  return !is_object(v) || (*_get_flags(v) & FLAG_LIVE_BIT) != 0;
}

static inline bool is_object_processed(value_t v)
{
  /* non-objects don't need to be processed */
  return !is_object(v) || (*_get_flags(v) & FLAG_PROC_BIT) != 0;
}

static inline void set_object_live(value_t v)
{
  assert(is_object(v));
  *_get_flags(v) |= FLAG_LIVE_BIT;
}

static inline void set_object_processed(value_t v)
{
  assert(is_object(v));
  *_get_flags(v) |= FLAG_PROC_BIT;
}

static inline void clear_object_live(value_t v)
{
  assert(is_object(v));
  *_get_flags(v) &= ~FLAG_LIVE_BIT;
}

static inline void clear_object_processed(value_t v)
{
  assert(is_object(v));
  *_get_flags(v) &= ~FLAG_PROC_BIT;
}

/****************************************************************************/

static inline bool is_will(value_t value)
{
  return is_object_type(value, OBJECT_TAG_WILL);
}

static inline will_t *get_will(value_t value)
{
  return _get_typed_object(value, OBJECT_TAG_WILL)->will;
}

/****************************************************************************/

void register_gc_root(gc_root_t *root, value_t v)
{
  root->value = v;
  root->next = &gc_root_list;
  gc_root_list.prev->next = root;
  root->prev = gc_root_list.prev;
  gc_root_list.prev = root;
}

void unregister_gc_root(gc_root_t *root)
{
  assert(root && root->prev && root->next);             /* Uninitialized */
  assert((root->prev != root) && (root->next != root)); /* Already removed */

  /* Cut the given root out of the list */
  root->prev->next = root->next;
  root->next->prev = root->prev;

  /* Remove dead references to root list; protects against double-removal */
  root->prev = root->next = root;
}

/****************************************************************************/

value_t make_box(value_t init)
{
  gc_root_t init_root;
  value_t   result;

  register_gc_root(&init_root, init);
  result = allocate_object(OBJECT_TAG_BOX);
  unregister_gc_root(&init_root);

  get_box(result)->value = init;

  return result;
}

value_t make_weak_box(value_t init)
{
  gc_root_t init_root;
  value_t   result;

  register_gc_root(&init_root, init);
  result = allocate_object(OBJECT_TAG_WEAK_BOX);
  unregister_gc_root(&init_root);

  get_weak_box(result)->value = init;
  get_weak_box(result)->next = gc_weak_box_list;

  gc_weak_box_list = result;

  return result;
}

value_t make_pair(value_t car, value_t cdr)
{
  gc_root_t car_root;
  gc_root_t cdr_root;
  value_t   result;

  register_gc_root(&car_root, car);
  register_gc_root(&cdr_root, cdr);

  result = allocate_object(OBJECT_TAG_PAIR);

  unregister_gc_root(&car_root);
  unregister_gc_root(&cdr_root);

  get_pair(result)->car = car;
  get_pair(result)->cdr = cdr;

  return result;
}

value_t make_float(fpnum_t value)
{
  value_t result = allocate_object(OBJECT_TAG_FPNUM);
  _get_object(result)->fpnum = value;
  return result;
}

value_t make_builtin_fn(builtin_fn_t *fn)
{
  value_t result = allocate_object(OBJECT_TAG_BUILTIN_FN);
  _get_object(result)->builtin_fn = fn;
  return result;
}

value_t make_vector(size_t nelem, value_t init)
{
  gc_root_t  init_root;
  value_t    result;
  vector_t  *vec;

  register_gc_root(&init_root, init);
  result = allocate_object(OBJECT_TAG_VECTOR);
  unregister_gc_root(&init_root);

  vec = (vector_t*)malloc(VECTOR_BYTES(nelem));
  release_assert(vec != NULL);

  gc_total_bytes += VECTOR_BYTES(nelem);
  _get_object(result)->vector = vec;

  vec->immutable = false;
  vec->nelements = nelem;

  for (size_t i = 0; i < nelem; ++i)
    vec->elements[i] = init;

  return result;
}

value_t make_byte_string(size_t nbytes, int init)
{
  value_t result;
  byte_string_t *bstr;

  result = allocate_object(OBJECT_TAG_BYTE_STRING);

  bstr = (byte_string_t*)malloc(BYTESTR_BYTES(nbytes));
  release_assert(bstr != NULL);

  gc_total_bytes += BYTESTR_BYTES(nbytes);
  _get_object(result)->byte_string = bstr;

  bstr->immutable = false;
  bstr->nbytes    = nbytes;

  memset(bstr->bytes, init, nbytes);

  return result;
}

value_t make_struct(value_t type)
{
  gc_root_t  type_root;
  fixnum_t   nslots;
  value_t    result;
  struct_t  *str;

  register_gc_root(&type_root, type);

  release_assert(struct_is_a(type, get_structure_type()));
  release_assert(get_struct(type)->immutable);

  nslots = get_fixnum(SLOT_VALUE(STRUCTURE, type, NSLOTS));

  result = allocate_object(OBJECT_TAG_STRUCT);

  unregister_gc_root(&type_root);

  str = (struct_t*)malloc(STRUCT_BYTES(nslots));
  release_assert(str != NULL);

  gc_total_bytes += STRUCT_BYTES(nslots);
  _get_object(result)->structure = str;

  str->immutable = false;
  str->nslots    = nslots;
  str->type      = type;

  for (int i = 0; i < nslots; ++i)
    str->slots[i] = UNDEFINED;

  return result;
}

/* wills can only be created in this module, via register_finalizer() */
static value_t make_will(value_t value, value_t finalizer)
{
  gc_root_t  value_root;
  gc_root_t  finalizer_root;
  value_t    result;
  will_t    *will;

  register_gc_root(&value_root,     value);
  register_gc_root(&finalizer_root, finalizer);

  result = allocate_object(OBJECT_TAG_WILL);

  unregister_gc_root(&value_root);
  unregister_gc_root(&finalizer_root);

  will = (will_t*)malloc(sizeof(will_t));
  release_assert(will != NULL);

  gc_total_bytes += sizeof(will_t);
  _get_object(result)->will = will;

  will->value     = value;
  will->finalizer = finalizer;
  will->next      = gc_will_list;
  gc_will_list    = result;

  return result;
}

/****************************************************************************/

value_t string_to_value(const char *s)
{
  size_t len = strlen(s);
  value_t v = make_byte_string(len, '\0');
  memcpy(get_byte_string(v)->bytes, s, len);
  return v;
}

char *value_to_string(value_t v)
{
  byte_string_t *str = get_byte_string(v);
  char *s = (char*)malloc(str->nbytes + 1);

  memcpy(s, str->bytes, str->nbytes);
  s[str->nbytes] = '\0';

  return s;
}

int byte_strcmp(value_t s1, value_t s2)
{
  byte_string_t *bstr1 = get_byte_string(s1);
  byte_string_t *bstr2 = get_byte_string(s2);
  int cmp = memcmp(bstr1->bytes, bstr2->bytes, GC_MIN(bstr1->nbytes, bstr2->nbytes));

  if (cmp == 0)
  {
    /* Prefix is the same, so compare lengths */
    if (bstr1->nbytes < bstr2->nbytes)
      cmp = -1;
    else if (bstr1->nbytes > bstr2->nbytes)
      cmp =  1;
  }

  return cmp;
}

value_t get_structure_type(void)
{
  return structure_type_root.value;
}

value_t make_struct_type(value_t super, fixnum_t nslots, value_t callable)
{
  gc_root_t super_root;
  gc_root_t callable_root;
  value_t   result;

  register_gc_root(&super_root,    super);
  register_gc_root(&callable_root, callable);

  if (super != FALSE_VALUE)
  {
    release_assert(struct_is_a(super, get_structure_type()));
    release_assert(get_struct(super)->immutable);
  }

  result = make_struct(get_structure_type());

  unregister_gc_root(&super_root);
  unregister_gc_root(&callable_root);

  get_struct(result)->slots[STRUCTURE_SLOT_SUPER]    = super;
  get_struct(result)->slots[STRUCTURE_SLOT_NSLOTS]   = make_fixnum(nslots);
  get_struct(result)->slots[STRUCTURE_SLOT_CALLABLE] = callable;
  get_struct(result)->immutable = true;

  return result;
}

bool struct_is_a(value_t value, value_t type)
{
  value_t tortoise, hare;

  /* The trivial cases: non-struct and exact match */
  if (!is_struct(value)) return false;
  if (get_struct(value)->type == type) return true;

  /* Look for type in superclasses; detect cycles using "tortoise and hare" algorithm */
  tortoise = hare = SLOT_VALUE(STRUCTURE, get_struct(value)->type, SUPER);

  do {
    if (hare == type) return true;
    if (hare == FALSE_VALUE) return false;

    release_assert(is_struct(hare));
    hare = SLOT_VALUE(STRUCTURE, hare, SUPER);

    if (hare == type) return true;
    if (hare == FALSE_VALUE) return false;

    release_assert(is_struct(hare));
    hare = SLOT_VALUE(STRUCTURE, hare, SUPER);

    /* Tortoise moves ahead one item for every two items covered by hare. */
    /* If there are no cycles in the superclass list, it will always be behind. */
    tortoise = SLOT_VALUE(STRUCTURE, tortoise, SUPER);
  } while (hare != tortoise);

  /* Tortoise caught up with hare, meaning we detected a cycle. */
  /* If type was in the cycle, it would have been found by now. */
  return false;
}

void register_finalizer(value_t value, value_t finalizer)
{
  /* Non-objects are never GC'd, so their finalizers will never be invoked. */
  if (is_object(value))
  {
    (void)make_will(value, finalizer);
  }
}

/*************************** Common Collector Code **************************/

static void structure_init(void);
static void mark_roots_live(void);
static void mark_children_live(value_t parent);
static void process_weak_boxes(void);
static void process_wills(void);
static void update_weak_box_list(void);

static void structure_init(void)
{
  value_t result;
  struct_t *str;

  /* Instances of this structure describe structures. */
  /* It is both a structure and a structure description, and thus an instance of itself. */
  result = allocate_object(OBJECT_TAG_STRUCT);

  str = (struct_t*)malloc(STRUCT_BYTES(STRUCTURE_SLOTS));
  release_assert(str != NULL);

  gc_total_bytes += STRUCT_BYTES(STRUCTURE_SLOTS);
  _get_object(result)->structure = str;

  str->immutable = true;
  str->type      = result;
  str->nslots    = STRUCTURE_SLOTS;

  /* Slot 1: Superclass, if any, or #f */
  str->slots[STRUCTURE_SLOT_SUPER] = FALSE_VALUE;

  /* Slot 2: Total number of slots (excl. type) */
  str->slots[STRUCTURE_SLOT_NSLOTS] = make_fixnum(STRUCTURE_SLOTS);

  /* Slot 3: Callable object used as proxy when structure is APPLY'd. */
  /* Can be LAMBDA, callable structure instance, builtin, or FALSE_VALUE. */
  str->slots[STRUCTURE_SLOT_CALLABLE] = FALSE_VALUE;

  register_gc_root(&structure_type_root, result);
}

void gc_init(void)
{
  const char *gc_debug_env;

  memset(object_blocks, 0, sizeof object_blocks);

  gc_free_list        = NIL;
  gc_weak_box_list    = NIL;
  gc_will_list        = NIL;
  gc_will_active_list = NIL;
  gc_next_live_value  = NIL;

  gc_live_bytes  = 0;
  gc_total_bytes = 0;

  clear_gc_stats();

  if ((gc_debug_env = getenv("GC_DEBUG")) != NULL)
  {
    if (strcmp(gc_debug_env, "warn") == 0)
    {
      gc_debug_level = GC_DEBUG_LEVEL_WARN;
    }
    else if (strcmp(gc_debug_env, "info") == 0)
    {
      gc_debug_level = GC_DEBUG_LEVEL_INFO;
    }
    else if (strcmp(gc_debug_env, "trace") == 0)
    {
      gc_debug_level = GC_DEBUG_LEVEL_TRACE;
    }
    else
    {
      char *endp;
      long val;

      val = strtol(gc_debug_env, &endp, 0);

      if (endp && (endp[0] == '\0'))
      {
        gc_debug_level = val;
      }
    }
  }

  gc_enabled = true;

  structure_init();
}

void clear_gc_stats(void)
{
  gc_stats.passes         = 0;
  gc_stats.total_ns       = 0;
  gc_stats.peak_ns        = 0;
  gc_stats.total_freed    = 0;
  gc_stats.peak_allocated = 0;
}

static inline void mark_object_live(value_t value)
{
  if (is_object(value) && !is_object_live(value))
  {
    set_object_live(value);

    if ((gc_next_live_value > value) ||
        (gc_next_live_value == NIL))
    {
      gc_next_live_value = value;
    }
  }
}

static void mark_roots_live(void)
{
  /* Mark registered GC roots as live */
  for (gc_root_t *root = gc_root_list.next; root != &gc_root_list; root = root->next)
  {
    mark_object_live(root->value);
  }

  /* Pending wills and associated finalizers are also roots */
  for (value_t will = gc_will_list; !is_nil(will); will = get_will(will)->next)
  {
    mark_object_live(will);
    mark_object_live(get_will(will)->finalizer);

    /* Processing for values of pending wills occurs separately from the main GC */
    set_object_processed(will);
  }

  /* Active wills and associated values and finalizers are also roots */
  for (value_t will = gc_will_active_list; !is_nil(will); will = get_will(will)->next)
  {
    mark_object_live(will);
    mark_object_live(get_will(will)->value);
    mark_object_live(get_will(will)->finalizer);

    /* No further processing is required for active wills */
    set_object_processed(will);
  }
}

static void mark_children_live(value_t value)
{
  if (is_box(value))
  {
    mark_object_live(get_box(value)->value);
  }
  else if (is_pair(value))
  {
    mark_object_live(get_pair(value)->car);
    mark_object_live(get_pair(value)->cdr);
  }
  else if (is_vector(value))
  {
    vector_t *vec = get_vector(value);
    int i;

    for (i = 0; i < vec->nelements; ++i)
      mark_object_live(vec->elements[i]);
  }
  else if (is_struct(value))
  {
    struct_t *str = get_struct(value);
    int i;

    mark_object_live(str->type);

    for (i = 0; i < str->nslots; ++i)
      mark_object_live(str->slots[i]);
  }
}

static value_t next_live_object(void)
{
  int blk;
  int idx;

  if (is_nil(gc_next_live_value))
    return NIL;

  blk = OBJECT_BLOCK(gc_next_live_value);

  for (idx = OBJECT_INDEX(gc_next_live_value); idx <= OBJECT_INDEX_MAX; ++idx)
  {
    uint8_t flags = object_blocks[blk].flag_bits[idx];

    if ((flags & (FLAG_LIVE_BIT | FLAG_PROC_BIT)) == FLAG_LIVE_BIT)
    {
      gc_next_live_value = value_from_index(blk, idx);;
      return gc_next_live_value;;
    }
  }

  for (++blk; (blk <= OBJECT_BLOCK_MAX) && object_blocks[blk].objects; ++blk)
  {
    for (idx = 0; idx <= OBJECT_INDEX_MAX; ++idx)
    {
      uint8_t flags = object_blocks[blk].flag_bits[idx];

      if ((flags & (FLAG_LIVE_BIT | FLAG_PROC_BIT)) == FLAG_LIVE_BIT)
      {
        gc_next_live_value = value_from_index(blk, idx);
        return gc_next_live_value;
      }
    }
  }

  gc_next_live_value = NIL;
  return NIL;
}

static void process_live_objects(void)
{
  value_t next;

  while (!is_nil(next = next_live_object()))
  {
    mark_children_live(next);
    set_object_processed(next);
  }
}

static void process_weak_boxes(void)
{
  value_t wb;
  
  for (wb = gc_weak_box_list; !is_nil(wb); wb = get_weak_box(wb)->next)
  {
    weak_box_t *box = get_weak_box(wb);

    if (!is_object_live(box->value))
    {
      /* The value in the box is an unreachable object; change to #f. */

      /*
      ** NOTE: An object is considered unreachable via weak box when it
      ** could be finalized, even though it will be kept alive until any
      ** finalizers are removed from the 'active' list. The finalizers
      ** may restore the object to a reachable state, in which case it
      ** will not be collected--but the weak reference will remain broken.
      **
      ** Restoring references to otherwise GC'able objects is not recommended.
      */

      box->value = FALSE_VALUE;
    }
  }
}

static void process_wills(void)
{
  value_t *will = &gc_will_list;

  while (!is_nil(*will))
  {
    will_t *w = get_will(*will);

    if (!is_object_live(w->value))
    {
      /* The will is associated with an unreachable object; activate it. */

      /* First, ensure the object remains reachable for the finalizer. */
      mark_object_live(w->value);

      /* Insert the will into the 'active' list. */
      w->next = gc_will_active_list;
      gc_will_active_list = *will;

      /* Remove the will from the 'pending' list. */
      *will = w->next;
    }
    else
    {
      /* Move on to this will's 'next' pointer */
      will = &w->next;
    }
  }
}

static void update_weak_box_list(void)
{
  value_t *wb = &gc_weak_box_list;

  while (!is_nil(*wb))
  {
    if (!is_object_live(*wb))
    {
      /* Box is no longer reachable; remove it from the list by updating *wb. */
      *wb = get_weak_box(*wb)->next;
    }
    else
    {
      /* Move on to next box */
      wb = &get_weak_box(*wb)->next;
    }
  }
}

static void free_unreachable_objects(void)
{
  int blk;

  for (blk = 0; (blk <= OBJECT_BLOCK_MAX) && object_blocks[blk].objects; ++blk)
  {
    int idx;

    for (idx = 0; idx <= OBJECT_INDEX_MAX; ++idx)
    {
      value_t value = value_from_index(blk, idx);

      if (is_object(value) && !is_object_live(value))
      {
        free_object(value);
      }
    }
  }
}

static void _out_of_memory(void) __attribute__ ((noreturn));
static void _out_of_memory(void)
{
  out_of_memory();
  abort();
}

void collect_garbage(void)
{
#ifndef NO_STATS
  size_t initial_bytes = gc_total_bytes;
#ifndef NO_TIMING_STATS
  struct timespec start_time;
  clock_gettime(TIMING_CLOCK, &start_time);
#endif
#endif

  debug_info("Performing garbage collection pass...\n");

  /* Start with no live/processed values */
  clear_gc_flag_bits();
  gc_next_live_value = NIL;

  /* Prime the pump */
  mark_roots_live();

  /* Keep marking children until there are no more live, unprocessed objects. */
  process_live_objects();

  /* These have to be examined after normal reachability has been determined. */
  process_weak_boxes();
  process_wills();

  /*
  ** Keep marking children until there are no more live, unprocessed objects.
  **
  ** This is so that values which are otherwise unreachable, but have
  ** finalizers which may be able to reach them, are not collected
  ** prematurely. process_wills() marks the value of any will newly placed
  ** on the active list as live. Note that these values may be finalized
  ** in any order, and that any weak references have already been cleared.
  */
  process_live_objects();

  /* Remove any unreachable weak boxes from the weak box list. */
  update_weak_box_list();

  /* Finally, return any unreachable objects to the free list. */
  free_unreachable_objects();

  /* Record total "live" allocation after GC. Determines threshold for next GC. */
  gc_live_bytes = gc_total_bytes;
  
  debug_info("Finished collection; active set is %ld bytes.\n", (long)gc_live_bytes);

#ifndef NO_STATS
  gc_stats.passes += 1;

#ifndef NO_TIMING_STATS
  {
    struct timespec end_time;
    nsec_t nsec;

    clock_gettime(TIMING_CLOCK, &end_time);

    nsec  = (end_time.tv_sec  - start_time.tv_sec) * 1000000000LL;
    nsec += (end_time.tv_nsec - start_time.tv_nsec);

    gc_stats.total_ns += nsec;

    if (nsec > gc_stats.peak_ns)
      gc_stats.peak_ns = nsec;
  }
#endif

  gc_stats.total_freed += (initial_bytes - gc_live_bytes);

  if (initial_bytes > gc_stats.peak_allocated)
    gc_stats.peak_allocated = initial_bytes;
#endif
}

bool set_gc_enabled(bool enable)
{
  bool was_enabled = gc_enabled;
  gc_enabled = enable;
  return was_enabled;
}

bool are_finalizers_pending(void)
{
  return !is_nil(gc_will_active_list);
}

/* Finalizer can be registered as #f, but value must be an object.
 * Returning with value == #f means there are no more finalizers. */
void get_next_finalizer(value_t *value, value_t *finalizer)
{
  assert(value && finalizer);

  if (is_nil(gc_will_active_list))
  {
    *value = *finalizer = FALSE_VALUE;
  }
  else
  {
    will_t *w  = get_will(gc_will_active_list);
    *value     = w->value;
    *finalizer = w->finalizer;

    /* Remove this finalizer from the list -- up to caller to keep values reachable. */
    gc_will_active_list = w->next;
  }
}

void print_backtrace(void)
{
#ifdef ENABLE_BACKTRACE
  void *frames[32];
  backtrace(frames, 32);
  backtrace_symbols_fd(frames, 32, 2);
#endif
}

void _release_assert(const char *str, const char *file, int line)
{
  fprintf(stderr, "ERROR: Invalid state detected in %s, line %d.\n"
                  "Assertion failed: %s\n",
      file, line, str);

  abort();
}

static void _fprint_value(FILE *f, value_t v, seen_value_t *seen)
{
  seen_value_t new_seen = { v, seen };
  int depth = 0;
  value_t builtin_name = reverse_lookup_builtin(v);

  if (is_byte_string(builtin_name))
  {
    fputs("#=", f);
    _fprint_value(f, builtin_name, NULL);
    return;
  }

  if (is_object(v) && !(is_float(v) || is_builtin_fn(v) || is_byte_string(v)))
  {
    for (seen_value_t *sv = seen; sv; sv = sv->prev)
    {
      if (v == sv->value)
      {
        fputs("#<cycle>", f);
        return;
      }

      if (++depth >= 3)
      {
        fputs("...", f);
        return;
      }
    }
  }

  if (v == UNDEFINED)
  {
    fputs("#<undefined>", f);
  }
  else if (v == NIL)
  {
    fputs("nil", f);
  }
  else if (v == FALSE_VALUE)
  {
    fputs("#f", f);
  }
  else if (v == TRUE_VALUE)
  {
    fputs("#t", f);
  }
  else if (v == END_PROGRAM)
  {
    fputs("#<endp>", f);
  }
  else if (is_fixnum(v))
  {
    fprintf(f, "%lld", (long long int)get_fixnum(v));
  }
  else if (is_box(v))
  {
    fputs("#&", f);
    _fprint_value(f, get_box(v)->value, &new_seen);
  }
  else if (is_weak_box(v))
  {
    fputs("#W&", f);
    _fprint_value(f, get_weak_box(v)->value, &new_seen);
  }
  else if (is_pair(v))
  {
    fputc('(', f);

    _fprint_value(f, get_pair(v)->car, &new_seen);
    v = get_pair(v)->cdr;

    while (is_pair(v))
    {
      fputc(' ', f);
      _fprint_value(f, get_pair(v)->car, &new_seen);
      v = get_pair(v)->cdr;
    }

    if (v != NIL)
    {
      fputs(" . ", f);
      _fprint_value(f, v, &new_seen);
    }

    fputc(')', f);
  }
  else if (is_float(v))
  {
    fprintf(f, "%f", (double)get_float(v));
  }
  else if (is_builtin_fn(v))
  {
    fprintf(f, "#<builtin:%p>", get_builtin_fn(v));
  }
  else if (is_vector(v))
  {
    vector_t *vec = get_vector(v);

    if (vec->immutable)
      fputs("#@", f);

    fputs("#(", f);

    for (size_t i = 0; i < vec->nelements; ++i)
    {
      if (i != 0) fputc(' ', f);
      _fprint_value(f, vec->elements[i], &new_seen);
    }

    fputc(')', f);
  }
  else if (is_byte_string(v))
  {
    byte_string_t *str = get_byte_string(v);
    size_t written = 0;

    if (str->immutable)
      fputs("#@", f);

    fputc('"', f);

    for (size_t i = 0; i < str->nbytes; ++i)
    {
      int ch = str->bytes[i];

      if (isprint(ch) && (ch != '\\') && (ch != '\"'))
      {
        fputc(str->bytes[i], f);
        ++written;
      }
      else
      {
        fprintf(f, "\\x%.2X", (int)str->bytes[i]);
        written += 4;
      }

      if (written >= 20)
      {
        fputs("...", f);
        break;
      }
    }

    fputc('"', f);
  }
  else if (is_struct(v))
  {
    struct_t *str = get_struct(v);

    if (str->immutable)
      fputs("#@", f);

    fputs("#S(", f);
    _fprint_value(f, str->type, &new_seen);

    for (size_t i = 0; i < str->nslots; ++i)
    {
      fputc(' ', f);
      _fprint_value(f, str->slots[i], &new_seen);
    }

    fputc(')', f);
  }
  else
  {
    fprintf(f, "#<unknown:0x%08lx>", (unsigned long)v);
  }
}

void fprint_value(FILE *f, value_t v)
{
  _fprint_value(f, v, NULL);
}

static double ns2sec(nsec_t ns) __attribute__ ((const));
static double ns2sec(nsec_t ns)
{
  return ns / 1.0e9;
}

void fprint_gc_stats(FILE *f)
{
  if (gc_stats.passes)
  {
    fprintf(f, "GC: %lld bytes freed by %d GCs in %0.6f sec => %0.3f MB/sec.\n"
               "GC: Peak pre-GC memory use was %lld bytes.\n",
        gc_stats.total_freed,
        gc_stats.passes,
        ns2sec(gc_stats.total_ns),
        (gc_stats.total_freed / ns2sec(gc_stats.total_ns)) / (1024*1024),
        gc_stats.peak_allocated);
  }
  else
  {
    fputs("GC: No garbage collection was performed.\n", f);
  }
}

/* vim:set sw=2 expandtab: */