khipu/interp.cpp

/* Definitions for the runtime interpreter.

   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 <cstdio>
#include "khipu.hpp"

KP_DECLS_BEGIN

bool interp_hook::attach (interpreter *ip)
{
  if (this->interp)
    return (false);

  this->interp = ip;
  ++this->interp->num_hooks[this->type];
  this->interp->hooks.add (&this->link);
  return (true);
}

bool interp_hook::detach ()
{
  if (!this->interp)
    return (false);

  --this->interp->num_hooks[this->type];
  this->link.del ();
  return (true);
}

bool interpreter::init (char *base, uint32_t size)
{
  // Initialization order is important for bootstrapping.
  this->values.init_head ();
  this->hooks.init_head ();
  this->mmgr = memmgr_alloc ();

  {
    auto stk = alloc_array (this, 64);
    if (stk.error_p ())
      return (false);

    this->stkobj = deref (stk);
  }

  this->stack = this->stkend = &xaref(this->stkobj, 0);

  this->cur_frame = this->throw_frame = this->exc_offset = 0;

  this->last_err = this->last_tb = NIL;
  this->retval = this->alval = this->aux = UNBOUND;
  this->state = this->saved_state = INTERP_RUNNING;

  this->tbuf = nullptr;
  this->evp = nullptr;

  this->call_depth = 0;
  this->stk_alloc.init (base, size);

  double dvt = monotonic_time ();
  this->rand_seed = hashbuf (&dvt, sizeof (dvt));

  memset (this->pendev_mask, 0, sizeof (this->pendev_mask));
  this->npendev = 0;
  this->evh_active = true;
  this->exc_raised = false;
  this->n_tlsyms = 0;

  for (size_t i = 0; i < KP_NELEM (this->num_hooks); ++i)
    this->num_hooks[i] = 0;

  return (true);
}

uint32_t interpreter::xrand ()
{
  uint32_t next = this->rand_seed;
  next = next * 1103515245 + 12345;
  this->rand_seed = next;
  return (next >> 16);
}

result<void> interpreter::growstk (uint32_t n)
{
  uint32_t sp = this->stklen (), size = sp + n;
  if (kp_likely (size < len_a (this->stkobj)))
    return (0);

  object ns = KP_TRY_IP (this,
                         alloc_array (this, size = upsize (size), UNBOUND));
  memcpy (&xaref(ns, 0), this->stack, sp * sizeof (object));

  this->stkobj = ns;
  this->stack = &xaref(ns, 0);
  this->stkend = this->stack + sp;
  this->call_hooks (HOOK_TYPE_STKMOV);
  return (0);
}

void interpreter::do_call_hooks (unsigned int type, unsigned int n)
{
  for (auto i = this->hooks.iterator (&interp_hook::link); n > 0; ++i)
    if (i->type == type)
      {
        i->call (this);
        --n;
      }
}

KP_TLS_INTERP interpreter *interpreter::self_interp;

#ifndef KP_NO_THREADS

/* We cannot use the internal lightweight locks here, because it may
 * cause a deadlock when contending against the gc-triggering thread.
 * Instead, we use a simple spinlock, since we shouldn't hold this
 * lock for too many instructions, anyway. */

bool interpreter::lock_remote (interpreter *interp)
{
  intptr_t val = (intptr_t)interp;
  auto *ilp = &as_thread(this->thread)->ilock;

  if (*ilp == val)
    return (false);

  while (true)
    {
      if (atomic_cas_bool (ilp, 0, val))
        return (true);

      int nspins = 100;   // An arbitrary value.
      while (*ilp != 0 && --nspins > 0)
        atomic_spin_nop ();
    }
}

bool interpreter::lock ()
{
  return (this->lock_remote (this));
}

void interpreter::unlock (bool release)
{
  if (!release)
    return;

  as_thread(this->thread)->ilock = 0;
  atomic_mfence_rel ();
}

#endif

result<void> interpreter::begin_blocking ()
{
  lock_guard g (this);
  if (kp_unlikely (this->npendev && this->evh_active))
    KP_VTRY (this->do_handle_evs ());

  this->state = INTERP_BLOCKING;
  return (0);
}

void interpreter::end_blocking ()
{
  while (true)
    {
      this->lock ();
      if (this->state != INTERP_SUSPENDED)
        break;

      /* Someone suspended us while we were blocking.
       * We now need to wait on the event they set up for us. */
      this->unlock ();
      this->sync_ev()->wait (this);
    }

  this->state = INTERP_RUNNING;
  this->unlock ();
}

object interpreter::caller () const
{
  if (this->cur_frame == 0)
    return (NIL);

  int nargs = as_int (this->stack[this->cur_frame - 3]);
  return (this->stack[this->cur_frame - nargs - frame_size - 1]);
}

exception interpreter::raise (object exc)
{
  this->throw_frame = this->cur_frame;
  this->exc_raised = true;
  this->last_err = exc;
  return (exception ());
}

exception interpreter::raise (const char *exctp, object str)
{
  auto name = string::make (this, exctp);
  if (name.error_p ())
    return (exception ());

  object mkexc = find_sym (this, "%mkexc", 6);
  if (symbol_p (mkexc) && fct_p (this->retval = symval (mkexc)))
    {
      if (this->growstk(3).error_p ())
        return (exception ());

      *this->stkend++ = this->retval;
      *this->stkend++ = *name;
      *this->stkend++ = str;
      if (call_n(this, 2).error_p ())
        return (exception ());
    }
  else if (cons::make(this, *name, str).error_p ())
    return (exception ());

  return (this->raise (this->retval));
}

exception interpreter::raise (const char *exctp, const char *msg)
{
  auto tmp = string::make (this, msg);
  if (tmp.error_p ())
    return (exception ());

  valref str (this, *tmp);
  return (this->raise (exctp, *str));
}

void interpreter::nargs_msg (char *bp, int sz, int min,
                             int max, int passed)
{
  const char FMT[] = "wrong number of arguments for %Q (expected ";
  memcpy (bp, FMT, sizeof (FMT) - 1);

  int n = (int)sizeof (FMT) - 1;
  bp += n, sz -= n;

  if (min == max)
    n = snprintf (bp, sz, "%d", min);
  else if (max == -1)
    n = snprintf (bp, sz, "%d or more", min);
  else
    n = snprintf (bp, sz, "%d to %d", min, max);

  bp += n, sz -= n;
  snprintf (bp, sz, ", got %d)", passed);
}

exception interpreter::raise_nargs (object name, int min, int max, int passed)
{
  local_varobj<string> sn;

  if (!symbol_p (name))
    {
      sn.local_init ("#:fct", 5);
      name = sn.as_obj ();
    }

  char buf[128];
  this->nargs_msg (buf, sizeof (buf) - 1, min, max, passed);

  auto msg = KP_SPRINTF (this, buf, name);
  return (msg.error_p () ? exception () : this->raise ("arg-error", *msg));
}

exception interpreter::raise_oob (int idx, int nmax)
{
  char buf[128];
  const char FMT[] = "index out of bounds";
  memcpy (buf, FMT, sizeof (FMT) - 1);
  int n = (int)sizeof (FMT) - 1;

  if (nmax >= 0)
    snprintf (&buf[n], sizeof (buf) - n - 1,
              " (got %d, length is %d)", idx, nmax);
  else
    buf[n] = 0;

  return (this->raise ("index-error", buf));
}

result<bool> interpreter::push_frame (object env, int nargs, int off)
{
  KP_VTRY (this->growstk (frame_size));
  *this->stkend++ = env;
  *this->stkend++ = fixint (this->cur_frame);
  *this->stkend++ = fixint (nargs);
  *this->stkend++ = fixint (off);
  *this->stkend++ = fixint (0);   // Thread-local binding index.
  this->cur_frame = this->stklen ();
  return (true);
}

static result<object>
trace_frame (interpreter *interp, uint32_t frame, object acc)
{
  int size = as_int (interp->stack[frame - 3]) + 1;
  int bp = frame - interpreter::frame_size - size;
  object caller = interp->stack[bp];

  if (fct_p (caller) && as_fct(caller)->flagged_p (function::artificial_flag))
    return (acc);

  object vec = KP_TRY (alloc_array (interp, size, NIL));
  for (int i = 0; i < size; ++i)
    {
      object elem = interp->stack[bp + i];
      xaref(vec, i) = elem == UNBOUND ? NIL :
        (xcons_p (elem) && (xcdr (elem) & EXTRA_BIT) ? xcar (elem) : elem);
    }

  return (cons::make (interp, vec, acc));
}

result<bool> interpreter::exc_handle ()
{
  if (!this->exc_raised || this->exc_offset == 0)
    return (false);

  uint32_t nsp = this->exc_offset;
  this->exc_offset = as_int (this->stack[nsp]);
  this->aux = fixint (this->stack[nsp + 1]);

  for (this->last_tb = NIL; this->cur_frame > nsp; )
    {
      this->last_tb = KP_TRY_IP (this, trace_frame (this, this->cur_frame,
                                                    this->last_tb));
      this->unbind (~0u);
      this->cur_frame = as_int (this->stack[this->cur_frame - 4]);
    }

  this->stkend = this->stack + nsp;
  this->exc_raised = false;
  return (true);
}

result<object> interpreter::dbind_idx (uintptr_t tl_idx, object val)
{
  if (tl_idx == 0)
    return (this->raise ("runtime-error", "cannot bind a non-dynamic symbol"));
  else if (tl_idx > this->n_tlsyms)
    {
      auto ntl = upsize (tl_idx);
      this->tl_syms = (object *)xrealloc (this->tl_syms,
                                          ntl * sizeof (*this->tl_syms));

      for (auto i = this->n_tlsyms; i < ntl; ++i)
        this->tl_syms[i] = UNBOUND;

      this->n_tlsyms = ntl;
    }

  object prev = this->tl_syms[tl_idx - 1];
  this->tl_syms[tl_idx - 1] = val;
  return (this->retval = prev);
}

result<object> interpreter::dbind (object sym, object val)
{
  return (this->dbind_idx (symtlidx (sym), val));
}

void interpreter::unbind (uint32_t n)
{
  uint32_t start = as_int (this->stack[this->cur_frame - 1]);
  for (; start && n; --n)
    {
      uint32_t idx = this->cur_frame + start;
      for (int i = 0, j = 1; i < as_int (this->stack[idx]); ++i, j += 2)
        {
          object sym = this->stack[idx + j + 1];
          this->tl_syms[symtlidx (sym) - 1] = this->stack[idx + j];
        }

      start = as_int (this->stack[this->cur_frame + start - 1]);
    }

  this->stack[this->cur_frame - 1] = fixint (start);
}

result<bool> interpreter::unbind (uint32_t n, coroutine *crp)
{
  if (!crp)
    {
      this->unbind (n);
      return (0);
    }

  uint32_t start = as_int (this->stack[this->cur_frame - 1]), last_off = 0;
  uint32_t size = 0;

  while (start)
    {
      uint32_t idx = this->cur_frame + start;
      size += as_int (this->stack[idx]);
      start = as_int (this->stack[this->cur_frame + start - 1]);

      if (--n == 0)
        last_off = start;
    }

  if (!array_p (crp->dbinds) || len_a (crp->dbinds) < size * 2)
    { crp->dbinds = KP_TRY_IP (this, alloc_array (this, size * 2)); }

  for (size = 0, start = as_int (this->stack[this->cur_frame - 1]); start; )
    {
      uint32_t idx = this->cur_frame + start;
      for (int i = 0, j = 1; i < as_int (this->stack[idx]); ++i, j += 2)
        {
          object sym = this->stack[idx + j + 1];
          xaref(crp->dbinds, size++) = sym;
          xaref(crp->dbinds, size++) = this->tl_syms[symtlidx (sym) - 1];
          this->tl_syms[symtlidx (sym) - 1] = this->stack[idx + j];
        }

      start = as_int (this->stack[this->cur_frame + start - 1]);
    }

  this->stack[this->cur_frame - 1] = fixint (last_off);
  return (0);
}

result<object> interpreter::stacktrace (uint32_t frame, uint32_t limit)
{
  valref ret (this, NIL);
  while (frame > limit)
    {
      *ret = KP_TRY_IP (this, trace_frame (this, frame, *ret));
      frame = as_int (this->stack[frame - 4]);
    }

  object argv[] = { *ret, this->last_tb };
  this->last_tb = KP_TRY_IP (this, nconcat (this, argv, 2));
  return (this->retval);
}

// Event management.

static const int EVMASK_BITS = sizeof (atomic_t) * 8;

void interpreter::set_ev (unsigned int evno)
{
  if (--evno >= NPENDEV)
    return;

  auto bit = (uintptr_t)1 << (evno % EVMASK_BITS);
  bool rel = this->lock ();

  if (!(this->pendev_mask[evno / EVMASK_BITS] & bit))
    {
      this->pendev_mask[evno / EVMASK_BITS] |= bit;
      ++this->npendev;
    }

  this->unlock (rel);
}

result<void> interpreter::do_handle_evs ()
{
  KP_VTRY (this->growstk (2));
  for (uintptr_t i = 0 ; ; ++i)
    {
      uintptr_t bit = (uintptr_t)1 << (i % EVMASK_BITS);
      if (!(this->pendev_mask[i / EVMASK_BITS] & bit))
        continue;

      this->pendev_mask[i / EVMASK_BITS] &= ~bit;
      --this->npendev;

      object fn = get_evhandler (this, i + 1);
      if (fn != UNBOUND)
        {
          *this->stkend++ = fn;
          *this->stkend++ = fixint (i + 1);
          KP_VTRY (call_n (this, 1));
        }

      if (!this->npendev)
        break;
    }

  return (0);
}

void* tmp_allocator::slow_alloc (uint32_t size)
{
  auto tp = (interp_tbuf *)xmalloc (sizeof (interp_tbuf) + size);
  tp->next = this->ip->tbuf;
  this->ip->tbuf = tp;
  return ((char *)tp + sizeof (*tp));
}

void tmp_allocator::talloc_cleanup ()
{
  do
   {
     auto curr = this->ip->tbuf;
     this->ip->tbuf = curr->next;
     xfree (curr);
   }
  while (this->ip->tbuf != this->tbuf);
}

result<void> dbinding::init (uintptr_t idx, object val)
{
  *this->val = KP_TRY (this->interp->dbind_idx (idx, val));
  this->tl_idx = idx;
  return (0);
}

dbinding::~dbinding ()
{
  if (this->tl_idx)
    this->interp->tl_syms[this->tl_idx - 1] = *this->val;
}

KP_DECLS_END