khipu/table.cpp

/* Definitions for the table type.

   This file is part of khipu.

   khipu 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 3 of the License, or
   (at your option) any later version.

   This program 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 program.  If not, see <https://www.gnu.org/licenses/>.  */

#include "khipu.hpp"

KP_DECLS_BEGIN

static inline object&
tabvec_cnt (array *vecp)
{
  return (*(vecp->data - 1));
}

static inline object&
tabvec_size (array *vecp)
{
  return (*(vecp->data - 2));
}

static inline object&
tabvec_pidx (array *vecp)
{
  return (*(vecp->data - 3));
}

static const int TABVEC_EXTRA = 3;

template <typename T>
static constexpr inline T
tabvec_idx (T idx)
{
  return (idx * 2);
}

static const uint32_t SECONDARY_KEYS[] = { 2, 3, 5, 7 };
static const int N_SECONDARY_KEYS = KP_NELEM (SECONDARY_KEYS);

static const uint32_t PRIMES[] =
{
  0xb, 0x25, 0x71, 0x15b, 0x419, 0xc4d, 0x24f5, 0x6ee3, 0x14cb3, 0x3e61d,
  0xbb259, 0x23170f, 0x694531, 0x13bcf95, 0x3b36ec3, 0xb1a4c4b, 0x214ee4e3,
  0x63ecaead
};

static int
compute_hsize (uint32_t min_size, float mv_ratio, int *idxp)
{
  int i1 = 0, i2 = (int)KP_NELEM (PRIMES);
  while (i1 < i2)
    {
      int step = (i1 + i2) >> 1;
      if (PRIMES[step] < min_size)
        i1 = step + 1;
      else
        i2 = step;
    }

  *idxp = i1;
  return ((int)(PRIMES[i1] * mv_ratio));
}

// Special values used by the table implementation.
static symbol FREE_SYM;
static symbol DELTV_SYM;

#ifdef KP_ARCH_WIDE

static const object FREE_HASH =
  ((object)typecode::SYMBOL << TYPE_SHIFT) | ((object)&FREE_SYM);

static const object DELETED_VAL =
  ((object)typecode::SYMBOL << TYPE_SHIFT) | ((object)&DELTV_SYM);

#else

static const object FREE_HASH = ((object)&FREE_SYM) | 3;
static const object DELETED_VAL = ((object)&DELTV_SYM) | 3;

#endif

static const object DELETED_KEY = FREE_HASH | EXTRA_BIT;

#ifdef KP_HAS_ATOMIC_CASX
static const size_t TABVEC_EXTRA_ROOM = TABVEC_EXTRA + 1;
#else
static const size_t TABVEC_EXTRA_ROOM = TABVEC_EXTRA;
#endif

static array*
make_tabvec (interpreter *interp, int prime_idx)
{
  uint32_t size = PRIMES[prime_idx],
           tsize = tabvec_idx (size) + TABVEC_EXTRA_ROOM;
  array *ret = array::alloc_raw (tsize);

  for (uint32_t i = 0; i < ret->len; ++i)
    ret->data[i] = FREE_HASH;

  ret->data += TABVEC_EXTRA, ret->len -= TABVEC_EXTRA;

#ifdef KP_HAS_ATOMIC_CASX
  if ((uintptr_t)ret->data % 16)
    ++ret->data;

  --ret->len;
#endif

  tabvec_size(ret) = size;
  tabvec_cnt(ret) = 0;
  tabvec_pidx(ret) = prime_idx;

  return (ret);
}

static inline object
register_tabvec (interpreter *interp, array *vecp)
{
  interp->alval = vecp->as_obj ();
  gc_register (interp, vecp, sizeof (*vecp) +
               (vecp->len + TABVEC_EXTRA_ROOM) * sizeof (object));
  return (interp->alval);
}

static result<object>
alloc_empty_table (interpreter *interp, object tst, object hashfn)
{
  auto eg = KP_TRY (evh_guard::make (interp));
  table *ret = alloch<table> ();

  lwlock_init (&ret->lock);
  ret->vector = deref (alloc_array (interp, 0));
  ret->cmpfct = tst == NIL ? fixint (0) : tst;
  ret->hashfct = hashfn == NIL ? fixint (0) : hashfn;
  ret->grow_limit = 0;
  ret->mv_ratio = 0.85f;
  interp->alval = ret->as_obj ();
  gc_register (interp, ret);
  return (interp->alval);
}

static inline result<bool>
table_equal (interpreter *interp, const table *tp,
             object k1, object k2)
{
  if (k1 == DELETED_KEY)
    return (false);

  // We only need to save K1, since K2 is the caller-provided key.
  valref tmp (interp, k1);
  if (kp_likely (tp->cmpfct == fixint (0)))
    return (equal (interp, k1, k2));

  KP_VTRY (interp->growstk (3));
  *interp->stkend++ = tp->cmpfct;
  *interp->stkend++ = k1;
  *interp->stkend++ = k2;
  KP_VTRY (call_n (interp, 2));
  return (interp->retval != NIL);
}

static inline result<uint32_t>
table_hash (interpreter *interp, const table *tp, object key)
{
  if (kp_likely (tp->hashfct == fixint (0)))
    return (xhash (interp, key));

  KP_VTRY (interp->growstk (2));
  *interp->stkend++ = tp->hashfct;
  *interp->stkend++ = key;
  KP_VTRY (call_n (interp, 1));

  int ret;

  if (as<int> (interp->retval, ret))
    return ((uint32_t)ret);
  else if (as<bigint> (interp->retval))
    return (hash_I (interp, interp->retval));

  return (interp->raise ("type-error", "hash function must return an integer"));
}

#ifndef KP_HAS_ATOMIC_CASX

// Try to atomically set the key in the table vector.
static inline bool
setk_cond (array *vecp, int ix, atomic_t ex, atomic_t nv)
{
  return (atomic_cas_bool ((atomic_t *)&vecp->data[ix + 0], ex, nv));
}

#endif

// Try to atomically set the value in the table vector.
static inline bool
setv_cond (array *vecp, int ix, atomic_t ex, atomic_t nv)
{
  return (atomic_cas_bool ((atomic_t *)&vecp->data[ix + 1], ex, nv));
}

static result<int> 
table_probe (interpreter *interp, const table *tp,
             array *vecp, object key, bool put_p, bool& empty)
{
  uint32_t hashcode = KP_TRY (table_hash (interp, tp, key));
  int32_t entries = (int32_t)tabvec_size (vecp);
  int32_t idx = (int32_t)(hashcode % entries);
  int32_t vidx = tabvec_idx (idx);

  empty = false;
  object tmp = vecp->data[vidx];

  if (tmp == FREE_HASH)
    return (put_p ? (empty = true, vidx) : -1);
  else
    {
      bool eq = KP_TRY (table_equal (interp, tp, tmp, key));
      if (eq)
        return (vidx);
    }
  
  int32_t initial_idx = idx;
  uint32_t sec = SECONDARY_KEYS[hashcode % N_SECONDARY_KEYS];

  while (true)
    {
      if ((idx += sec) >= entries)
        idx -= entries;

      if (!put_p && idx == initial_idx)
        return (-1);

      vidx = tabvec_idx (idx);
      tmp = vecp->data[vidx];

      if (tmp == FREE_HASH)
        return (put_p ? (empty = true, vidx) : -1);
      
      bool eq = KP_TRY (table_equal (interp, tp, tmp, key));
      if (eq)
        return (vidx);
    }
}

static result<int>
table_probe (interpreter *interp, const table *tp,
  array *vecp, object key, bool put_p)
{
  bool dummy;
  return (table_probe (interp, tp, vecp, key, put_p, dummy));
}

static inline bool
valid_key_p (object key)
{
  return ((key & ~EXTRA_BIT) != FREE_HASH);
}

static result<int>
growtab_probe (interpreter *interp, const table *tp,
               array *vecp, object key)
{
  /* Same as above, only this function is called when migrating, which means
   * it cannot return failure. */
  uint32_t hashcode = KP_TRY (table_hash (interp, tp, key));
  int32_t entries = (int32_t)tabvec_size (vecp);
  int32_t idx = (int32_t)(hashcode % entries);
  int32_t vidx = tabvec_idx (idx);

  if (vecp->data[vidx] == FREE_HASH)
    return (vidx);

  for (uint32_t sec = SECONDARY_KEYS[hashcode % N_SECONDARY_KEYS] ; ; )
    {
      if ((idx += sec) >= entries)
        idx -= entries;
            
      vidx = tabvec_idx (idx);
      if (vecp->data[vidx] == FREE_HASH)
        return (vidx);
    }
}

static result<void>
table_migrate_lk (interpreter *interp, table *tp)
{
  array *oldvp = as_array (tp->vector);
  array *newvp = make_tabvec (interp, tabvec_pidx (oldvp) + 1);

  for (uint32_t i = tabvec_idx (0); i < oldvp->len; i += 2)
    {
      if (!valid_key_p (oldvp->data[i]))
        continue;

      int new_idx = KP_TRY (growtab_probe (interp, tp, newvp, oldvp->data[i]));
      newvp->data[new_idx + 0] = oldvp->data[i + 0];
      newvp->data[new_idx + 1] = oldvp->data[i + 1];
    }

  tp->grow_limit = (atomic_t)(tp->mv_ratio *
    tabvec_size (newvp) - tabvec_cnt (oldvp));

  tabvec_cnt(newvp) = tabvec_cnt (oldvp);
  tp->vector = register_tabvec (interp, newvp);
  return (0);
}

struct table_guard : public lwlock_guard
{
  array *oldp;

  table_guard () : lwlock_guard (), oldp (nullptr)
    {
    }

  static result<table_guard>
  make (interpreter *interp, atomic_t *ptr)
    {
      table_guard ret;
      KP_VTRY (ret.set (interp, ptr));
      return (ret);
    }

  void set_vec (array *ap)
    {
      this->oldp = ap;
    }

  ~table_guard ()
    {
      if (!this->oldp)
        return;

      for (uint32_t i = tabvec_idx (0); i < this->oldp->len; i += 2)
        atomic_and ((atomic_t *)&oldp->data[i + 1], ~EXTRA_BIT);
    }
};

static result<void>
table_migrate_mt (interpreter *interp, table *tp)
{
  auto g = KP_TRY (table_guard::make (interp, &tp->lock));

  if (tp->grow_limit > 0)
    return (0);
  
  array *oldvp = as_array (tp->vector);
  array *newvp = make_tabvec (interp, tabvec_pidx (oldvp) + 1);
  int nelem = 0;

  g.set_vec (oldvp);
      
  for (uint32_t i = tabvec_idx (0); i < oldvp->len; i += 2)
    {
      object key = oldvp->data[i];
      object val = atomic_or ((atomic_t *)&oldvp->data[i + 1], EXTRA_BIT);

      /* No other thread can be migrating the table at this point,
       * so it's safe to do a simplified test here. */
      if (valid_key_p (key) && val != DELETED_VAL && val != FREE_HASH)
        {
          int new_idx = KP_TRY (growtab_probe (interp, tp, newvp, key));
          newvp->data[new_idx + 0] = key;
          newvp->data[new_idx + 1] = val;
          ++nelem;
        }
    }

  g.set_vec (nullptr);
  
  // Set up the new table.
  tabvec_cnt(newvp) = nelem;
  tp->grow_limit = (atomic_t)(tp->mv_ratio * tabvec_size (newvp)) - nelem;
  atomic_mfence_rel ();
  /* At this point, another thread may decrement the growth limit from
   * the wrong table vector. That's fine, it just means we'll have to
   * migrate sooner than necessary. */
  tp->vector = newvp->as_obj ();
  register_tabvec (interp, newvp);
  return (0);
}

static result<object>
table_get_mt (interpreter *interp,
              table *tp, object key, object dfl)
{
  array *vecp = as_array (tp->vector);
  int idx = KP_TRY (table_probe (interp, tp, vecp, key, false));

  if (idx < 0)
    return (dfl);

  object ret = vecp->data[idx + 1] & ~EXTRA_BIT;
  return (ret == DELETED_VAL || ret == FREE_HASH ? dfl : ret);
}

static result<object>
table_get_lk (interpreter *interp, table *tp, object key, object dfl)
{
  int idx = KP_TRY (table_probe (interp, tp, as_array (tp->vector),
                                 key, false));
  return (idx < 0 ? dfl : xaref (tp->vector, idx + 1));
}

result<object> table_get (interpreter *interp, object tab,
                          object key, object dfl, bool mtsafe)
{
  auto fn = mtsafe ? table_get_mt : table_get_lk;
  object ret = KP_TRY (fn (interp, as_table (tab), key, dfl));
  kp_return (ret);
}

result<object> get_u (interpreter *interp, object tab, object key, object dfl)
{
  return (table_get (interp, tab, key,
                     dfl == UNBOUND ? NIL : dfl, !singlethr_p ()));
}

static result<object>
table_pop_mt (interpreter *interp, table *tp, object key, object dfl)
{
  while (true)
    {
      array *vecp = as_array (tp->vector);
      int idx = KP_TRY (table_probe (interp, tp, vecp, key, false));

      if (idx < 0)
        return (dfl);
      else
        {
          object oldk = vecp->data[idx + 0];
          object oldv = vecp->data[idx + 1];

          if (!(oldv & EXTRA_BIT))
            { /* The table is not being migrated at the moment. Try to
               * delete the entry if it hasn't already been. */
              if (oldk == DELETED_KEY || oldv == FREE_HASH ||
                  oldv == DELETED_VAL)
                return (dfl);
              else if (setv_cond (vecp, idx, oldv, DELETED_VAL))
                {
                  atomic_add ((atomic_t *)&tabvec_cnt(vecp), -1);
                  // Safe to set the key without atomic ops.
                  vecp->data[idx] = DELETED_KEY;
                  return (oldv);
                }

              continue;
            }

          // The table was being migrated - Retry.
          KP_VTRY (table_migrate_mt (interp, tp));
        }
    }
}

static result<object>
table_pop_lk (interpreter *interp, table *tp, object key, object dfl)
{
  int idx = KP_TRY (table_probe (interp, tp, as_array (tp->vector),
                                 key, false));
  if (idx < 0)
    return (dfl);

  array *vecp = as_array (tp->vector);
  object ret = vecp->data[idx + 1];

  vecp->data[idx + 0] = DELETED_KEY;
  vecp->data[idx + 1] = DELETED_VAL;
  --tabvec_cnt(vecp);
  return (ret);
}

result<object> table_pop (interpreter *interp, object tab,
                          object key, object dfl, bool mtsafe)
{
  table *tp = as_table (tab);
  if (kp_unlikely (tp->flagged_p (FLAGS_CONST)))
    return (interp->raise_const ());

  auto fn = mtsafe ? table_pop_mt : table_pop_lk;
  object ret = KP_TRY (fn (interp, tp, key, dfl));
  kp_return (ret);
}

result<object> npop_u (interpreter *interp, object tab, object key, object dfl)
{
  return (table_pop (interp, tab, key, dfl, !singlethr_p ()));
}

template <typename Fn>
static result<bool> table_update_lk (interpreter *interp, table *tp,
                                     object key, Fn& f)
{
  bool empty;
  array *vecp = as_array (tp->vector);
  int idx = KP_TRY (table_probe (interp, tp, vecp, key, true, empty));

  if (empty)
    {
      vecp->data[idx + 0] = key;
      vecp->data[idx + 1] = KP_TRY (f.call (interp));

      if (--tp->grow_limit <= 0)
        {
          KP_VTRY (table_migrate_lk (interp, tp));
          vecp = as_array (tp->vector);
        }

      ++tabvec_cnt(vecp);
    }
  else
    vecp->data[idx + 1] = KP_TRY (f.call (interp, vecp->data[idx + 1]));

  return (empty);
}

struct table_inserter
{
  object val;

  object call (interpreter *)
    {
      return (this->val);
    }

  object call (interpreter *, object)
    {
      return (this->val);
    }
};

template <typename Fn>
static result<bool> table_update_mt (interpreter *interp,
                                     table *tp, object key, Fn& f)
{
  while (true)
    {
      bool empty;
      array *vecp = as_array (tp->vector);
      int idx = KP_TRY (table_probe (interp, tp, vecp, key, true, empty));

      if (!empty)
        {
          object tmp = vecp->data[idx + 1];
          object nval;

          if ((tmp & EXTRA_BIT) != 0)
            ;
          else
            {
              if (tmp != DELETED_VAL)
                {
                  nval = KP_TRY (f.call (interp, tmp));
                  if (nval == tmp || setv_cond (vecp, idx, tmp, nval))
                    return (empty);
                }

              continue;
            }
        }
      else if (tp->grow_limit > 0)
        { /* NOTE: If we fail here, then the growth limit will
           * end up too small. This simply means we may have to
           * migrate sooner than it's absolutely necessary, so it's
           * harmless. On the other hand, we must *NOT* try to
           * reincrement the limit back, because it risks ending
           * up too big, which can be harmful if, for instance, a
           * migration is done before the increment. */
          
          atomic_add (&tp->grow_limit, -1);
          object tmp = KP_TRY (f.call (interp));

#ifdef KP_HAS_ATOMIC_CASX
          if (atomic_casx (&vecp->data[idx], FREE_HASH, FREE_HASH, key, tmp))
#else
          if (setk_cond (vecp, idx, FREE_HASH, key) &&
              setv_cond (vecp, idx, FREE_HASH, tmp))
#endif
            {
              atomic_add ((atomic_t *)&tabvec_cnt(vecp), 1);
              return (empty);
            }

          continue;
        }
      
      // The table needs migrating, or it was already being migrated.
      KP_VTRY (table_migrate_mt (interp, tp));
    }
}

result<bool> table_put (interpreter *interp, object tab,
                        object key, object val, bool mtsafe)
{
  table *tp = as_table (tab);
  if (kp_unlikely (tp->flagged_p (FLAGS_CONST)))
    return (interp->raise_const ());

  table_inserter ins;
  ins.val = val;

  auto fn = mtsafe ? table_update_mt<table_inserter> :
                     table_update_lk<table_inserter>;
  bool ret = KP_TRY (fn (interp, as_table (tab), key, ins));

  if (ret)
    deref (gc_wbarrier (interp, tab, key));

  deref (gc_wbarrier (interp, tab, val));
  return (ret);
}

result<object> nput_u (interpreter *interp, object tab,
                       object key, object val)
{
  KP_TRY (table_put (interp, tab, key, val, !singlethr_p ()));
  kp_return (val);
}

static void
table_clr_lk (interpreter *interp, table *tp)
{
  array *vecp = make_tabvec (interp, 0);
  tp->grow_limit = (atomic_t)(tp->mv_ratio * tabvec_size (vecp));
  tp->vector = vecp->as_obj ();
}

static result<void>
table_clr_mt (interpreter *interp, table *tp)
{
  array *np = make_tabvec (interp, 0);
  auto g = KP_TRY (table_guard::make (interp, &tp->lock));
  array *vecp = as_array (tp->vector);

  for (uint32_t ix = tabvec_idx (0); ix < vecp->len; ix += 2)
    {
      vecp->data[ix + 1] = DELETED_VAL | EXTRA_BIT;
      atomic_mfence_rel ();
      vecp->data[ix + 0] = DELETED_KEY;
    }

  tp->grow_limit = (atomic_t)(tp->mv_ratio * tabvec_size (np));
  atomic_mfence_rel ();
  tp->vector = np->as_obj ();
  return (0);
}

result<void> table_clr (interpreter *interp, object tab, bool mtsafe)
{
  table *tp = as_table (tab);
  if (kp_unlikely (tp->flagged_p (FLAGS_CONST)))
    return (interp->raise_const ());
  else if (mtsafe)
    KP_VTRY (table_clr_mt (interp, tp));
  else
    table_clr_lk (interp, tp);

  return (0);
}

struct table_nzapper
{
  valref ret;
  object dfl;
  int stack_idx;
  int nargs;

  table_nzapper (interpreter *interp) : ret (interp)
    {
    }

  result<void> init (interpreter *interp, uint32_t flags,
                     object fn, object *argv, int argc)
    {
      KP_VTRY (interp->growstk (argc + 1));
      *interp->stkend++ = fn;
      *interp->stkend++ = fixint (0);
      this->stack_idx = interp->stklen () - 1;

      if (flags & NZAP_DFL)
        {
          this->dfl = *argv++;
          --argc;
        }
      else
        this->dfl = NIL;

      for (int i = 0; i < argc; ++i)
        *interp->stkend++ = argv[i];

      this->nargs = argc + 1;
      return (0);
    }

  result<object> call (interpreter *interp, object prev)
    {
      interp->stack[this->stack_idx] = *this->ret = prev;
      KP_VTRY (call_n (interp, this->nargs));
      return (interp->retval);
    }

  result<object> call (interpreter *interp)
    {
      return (this->call (interp, this->dfl));
    }
};

result<object> nzap_u (interpreter *interp, object obj, object key,
                       uint32_t flags, object fn, object *argv, int argc)
{
  table *tp = as_table (obj);

  if (kp_unlikely (tp->flagged_p (FLAGS_CONST)))
    return (interp->raise_const ());

  table_nzapper nz (interp);
  KP_VTRY (nz.init (interp, flags, fn, argv, argc));

  auto fx = (flags & NZAP_NOMT) ? table_update_lk<table_nzapper> :
                                  table_update_mt<table_nzapper>;
  bool wb = KP_TRY (fx (interp, tp, key, nz));

  deref (gc_wbarrier (interp, obj, interp->retval));
  if (wb)
    deref (gc_wbarrier (interp, obj, key));

  if (flags & NZAP_PREV)
    interp->retval = *nz.ret;

  return (interp->retval);
}

uint32_t len_u (object tab)
{
  return (as_int (tabvec_cnt (as_array (as_table(tab)->vector))));
}

static result<object>
fill_table (interpreter *interp, table *tp, object *argv, int argc)
{
  int idx;

  tp->grow_limit = compute_hsize (argc / 2 + 1, tp->mv_ratio, &idx);
  array *vecp = KP_TRY (make_tabvec (interp, idx));

  for (int i = 0; i < argc; i += 2)
    {
      object key = argv[i];
      idx = KP_TRY (growtab_probe (interp, tp, vecp, key));
      vecp->data[idx + 0] = key;
      vecp->data[idx + 1] = argv[i + 1];
    }

  if (argc % 2 != 0)
    {
      object key = argv[argc - 1];
      idx = KP_TRY (growtab_probe (interp, tp, vecp, key));
      vecp->data[idx + 0] = key;
      vecp->data[idx + 1] = NIL;
      ++argc;
    }

  tabvec_cnt(vecp) = fixint (argc / 2);
  tp->vector = register_tabvec (interp, vecp);
  kp_return (tp->as_obj ());
}

// (table eq_fn hash_fn [...args])
result<object> table_fct (interpreter *interp, object *argv, int argc)
{
  valref ret = KP_TRY (alloc_empty_table (interp, argv[0], argv[1]));
  return (fill_table (interp, as_table (*ret), argv + 2, argc - 2));
}

static inline size_t
table_capacity (object vec, float mv_ratio)
{
  return ((size_t)(as_array(vec)->len * mv_ratio));
}

size_t table::capacity () const
{
  return (table_capacity (this->vector, this->mv_ratio));
}

table::iterator::iterator (interpreter *interp, object table) :
  c_key (interp, UNBOUND), c_val (interp, UNBOUND),
  vec (interp, as_table(table)->vector), idx (0)
{
  ++*this;
}

static inline void
iter_bump (const array *vecp, object& key, object& val, int& idx)
{
  for (key = FREE_HASH; idx < (int)vecp->len; )
    {
      key = vecp->data[idx];
      val = vecp->data[idx + 1] & ~EXTRA_BIT;

      idx += 2;
      if (valid_key_p (key) && val != DELETED_VAL && val != FREE_HASH)
        return;
    }

  idx = -1;
}

table::iterator& table::iterator::operator++ ()
{
  iter_bump (as_array (*this->vec), *this->c_key, *this->c_val, this->idx);
  return (*this);
}

table::iterator table::iterator::operator++ (int)
{
  iterator ret { interpreter::self (), *this };
  ++*this;
  return (ret);
}

result<object> iter_u (interpreter *interp, object obj, object token, bool adv)
{
  if (token == UNBOUND)
    {
      valref out_k (interp), out_v (interp), vec (interp, as_table(obj)->vector);
      int ix = 0;

      iter_bump (as_array (*vec), *out_k, *out_v, ix);
      if (!valid_key_p (*out_k))
        kp_return (NIL);

      object ret = KP_TRY (alloc_array (interp, 4));
      xaref(ret, 0) = *out_k;
      xaref(ret, 1) = *out_v;
      xaref(ret, 2) = *vec;
      xaref(ret, 3) = fixint (ix);

      kp_return (ret);
    }

  object vec, ival;

  if (!array_p (token) || len_a (token) != 4 ||
      !fixint_p (ival = xaref (token, 3)) || !array_p (vec = xaref (token, 2)))
    return (interp->raise ("arg-error", "invalid token"));
  else if (!adv)
    kp_return (xaref (token, 0));

  int ix = as_int (ival);
  object out_k, out_v;

  iter_bump (as_array (vec), out_k, out_v, ix);
  if (ix < 0)
    kp_return (NIL);

  xaref(token, 0) = out_k;
  xaref(token, 1) = out_v;
  xaref(token, 3) = fixint (ix);

  deref (gc_wbarrier (interp, token, out_k));
  deref (gc_wbarrier (interp, token, out_v));
  kp_return (token);
}

static const uint32_t TABLE_HASH_SEED = 1818386804;

result<uint32_t> hash_u (interpreter *interp, object obj)
{
  uint32_t ret = TABLE_HASH_SEED;
  uint32_t t1 = KP_TRY (xhash (interp, as_table(obj)->cmpfct));
  uint32_t t2 = KP_TRY (xhash (interp, as_table(obj)->hashfct));

  for (table::iterator it (interp, obj); it.valid (); ++it)
    {
      t1 = KP_TRY (xhash (interp, it.key ()));
      t2 = KP_TRY (xhash (interp, it.val ()));
      ret = mix_hash (ret, mix_hash (t1, t2));
    }

  return (ret);
}

result<int64_t> write_u (interpreter *interp, stream *strm,
                         object tab, io_info& info)
{
  table::iterator it (interp, tab);
  int64_t ret = 0;

  ret += KP_TRY (strm->putb (interp, '{'));
  if (it.valid ())
    while (true)
      {
        ret += KP_TRY (xwrite (interp, strm, it.key (), info));
        ret += KP_TRY (strm->putb (interp, ' '));
        ret += KP_TRY (xwrite (interp, strm, it.val (), info));

        if (!(++it).valid ())
          break;

        ret += KP_TRY (strm->putb (interp, ' '));
      }

  ret += KP_TRY (strm->putb (interp, '}'));
  return (ret);
}

result<object> copy_u (interpreter *interp, object obj, bool deep)
{
  table::iterator it (interp, obj);
  sp_guard sg (interp);

  KP_VTRY (interp->growstk (2 + table_capacity (*it.vec,
                                                as_table(obj)->mv_ratio)));

  *interp->stkend++ = as_table(obj)->cmpfct;
  *interp->stkend++ = as_table(obj)->hashfct;

  if (deep)
    // We have to copy every key-value pair as well.
    for (; it.valid (); ++it)
      {
        *interp->stkend++ = KP_TRY (copy (interp, it.key (), true));
        *interp->stkend++ = KP_TRY (copy (interp, it.val (), true));
      }
  else
    for (; it.valid (); ++it)
      {
        *interp->stkend++ = it.key ();
        *interp->stkend++ = it.val ();
      }

  return (table_fct (interp, interp->stack + sg.sp, interp->stklen () - sg.sp));
}

result<int64_t> pack_u (interpreter *interp, stream *strm,
                        object obj, pack_info& info)
{
  pack_info::eviction_guard eg { info, true };
  table *tp = as_table (obj);
  int64_t ret = 0;

  ret += KP_TRY (tp->cmpfct == UNBOUND ?
                 result<int64_t> (strm->putb (interp, PACK_NIL)) :
                 xpack (interp, strm, tp->cmpfct, info));
  ret += KP_TRY (tp->hashfct == UNBOUND ?
                 result<int64_t> (strm->putb (interp, PACK_NIL)) :
                 xpack (interp, strm, tp->hashfct, info));

  ret += KP_TRY (strm->write (interp, &tp->mv_ratio));
  for (table::iterator it (interp, obj); it.valid (); ++it)
    {
      ret += KP_TRY (xpack (interp, strm, it.key (), info));
      ret += KP_TRY (xpack (interp, strm, it.val (), info));
    }

  ret += KP_TRY (strm->putb (interp, PACK_END));
  return (ret);
}

result<object> unpack_u (interpreter *interp, stream *strm,
                         pack_info& info, bool save)
{
  int tst = KP_TRY (strm->peekb (interp));
  valref e1 (interp, NIL), e2 (interp, NIL),
         saved_pos (interp, *info.offset);

  if (tst == PACK_NIL)
    deref (strm->getb (interp));
  else if (tst < 0)
    return (info.error ("failed to read table hasher"));
  else
    { *e1 = KP_TRY (xunpack (interp, strm, info)); }

  tst = KP_TRY (strm->peekb (interp));
  if (tst == PACK_NIL)
    KP_VTRY (strm->getb (interp));
  else if (tst < 0)
    return (info.error ("failed to read table tester"));
  else
    { *e2 = KP_TRY (xunpack (interp, strm, info)); }

  float mv_ratio;
  {
    bool rv = KP_TRY (strm->sread (interp, &mv_ratio));
    if (!rv)
      return (info.error ("failed to read table migration ratio"));
  }

  valref ret = KP_TRY (alloc_empty_table (interp, *e1, *e2));
  table *tp = as_table (*ret);
  tp->mv_ratio = mv_ratio;

  if (save)
    KP_VTRY (info.add_mapping (interp, *info.offset, *ret));

  sp_guard sg (interp);
  while (true)
    {
      tst = KP_TRY (strm->peekb (interp));
      if (tst == PACK_END)
        {
          deref (strm->getb (interp));
          break;
        }
      else
        {
          *e1 = KP_TRY (xunpack (interp, strm, info));
          *e2 = KP_TRY (xunpack (interp, strm, info));
        }

      KP_VTRY (interp->push (*e1),
               interp->push (*e2));
    }

  return (fill_table (interp, tp, interp->stack + sg.sp,
                      interp->stklen () - sg.sp));
}

result<object> alloc_table (interpreter *interp, object eqfn, object hashfn)
{
  KP_VTRY (interp->push (eqfn),
           interp->push (hashfn));
  return (table_fct (interp, interp->stkend - 2, 2));
}

static int
do_init_tables (interpreter *interp)
{
  static const unsigned char free_name[] = { 'f', 'r', 'e', 'e', 0 };
  static const unsigned char delt_name[] = { 'd', 'e', 'l', 't', 0 };

  static string free_str;
  static string delt_str;

  free_str.vo_type = delt_str.vo_type = typecode::STR;

  free_str.data = (unsigned char *)free_name;
  delt_str.data = (unsigned char *)delt_name;

  free_str.nbytes = free_str.len = KP_NELEM (free_name) - 1;
  delt_str.nbytes = delt_str.len = KP_NELEM (delt_name) - 1;

  FREE_SYM.vo_type = DELTV_SYM.vo_type = typecode::SYMBOL;
  FREE_SYM.name = ensure_mask(&free_str)->as_obj ();
  DELTV_SYM.name = ensure_mask(&delt_str)->as_obj ();

  FREE_SYM.pkg = DELTV_SYM.pkg = NIL;
  FREE_SYM.value = DELTV_SYM.value = UNBOUND;
  return (init_op::result_ok);
}

init_op init_tables (do_init_tables, "tables");

KP_DECLS_END