khipu/coro.cpp

/* Definitions for the coroutine 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 <cstdio>
#include "khipu.hpp"

KP_DECLS_BEGIN

static result<object>
make_argv (interpreter *interp, uint32_t bp, coroutine *outp)
{
  uint32_t max_sp = as_fct(interp->stack[bp - 1])->max_sp;
  uint32_t nsp = interp->stklen () - (bp - 1);

  KP_VTRY (alloc_array (interp, nsp + max_sp));
  array *ap = as_array (interp->alval);
  copy_objs (ap->data, &interp->stack[bp - 1], nsp);

  uint32_t nargs = as_int (interp->stack[interp->cur_frame - 3]);
  uint32_t start = interp->cur_frame - nargs - interpreter::frame_size - 1;
  outp->frame = interpreter::frame_size + 1 + nargs;
  ap->data[outp->frame - 4] = fixint (0);

  if (interp->exc_offset <= start)
    outp->exc_off = 0;
  else
    { // Adjust exception handler offsets.
      for (uint32_t eoff = interp->exc_offset ; ; )
        {
          uint32_t ipos = eoff - start;
          uint32_t prev = as_int (interp->stack[eoff]);

          if (prev < start)
            {
              ap->data[ipos] = fixint (0);
              break;
            }

          ap->data[ipos] = fixint (prev - start);
          eoff = prev;
        }

      outp->exc_off = interp->exc_offset - start;
    }

  return (ap->as_obj ());
}

struct coro_state : call_guard
{
  valref stkobj;
  uint32_t saved_objlen;

  coro_state (interpreter *ip) : call_guard (ip),
      stkobj (ip, ip->stkobj), saved_objlen (len_a (ip->stkobj))
    { // Make sure the GC doesn't scan past the interpreter's stack end.
      as_array(ip->stkobj)->len = this->sp;
    }

  ~coro_state ()
    {
      as_array(*this->stkobj)->len = saved_objlen;
      this->interp->stkobj = *this->stkobj;
      this->interp->stack = &xaref(*this->stkobj, 0);
    }
};

result<object> coro_next (interpreter *interp, object *argv, int argc)
{
  auto crp = as<coroutine> (*argv);
  if (!crp)
    return (interp->raise ("type-error", "argument must be a coroutine"));
  else if (!crp->valid_p ())
    return (interp->raise ("arg-error", "coroutine exhausted"));

  coro_state state (interp);
  object value = argc == 2 ? argv[1] : crp->value;

  interp->stkobj = crp->argv;
  interp->stack = &xaref(interp->stkobj, 0);
  interp->stkend = interp->stack + crp->frame + crp->sp_diff;
  interp->cur_frame = 0;
  interp->exc_offset = crp->exc_off;

  if (kp_unlikely (array_p (crp->dbinds)))
    // Rebind the dynamic variables.
    for (uint32_t i = 0; i < len_a (crp->dbinds); i += 2)
      interp->tl_syms[symtlidx (xaref (crp->dbinds, i)) - 1] =
        xaref (crp->dbinds, i + 1);

  auto ret = call_coroutine (interp, crp, value);
  if (ret.error_p ())
    { // Generate the stacktrace from the coroutine and rethrow.
      KP_VTRY (interp->stacktrace (interp->throw_frame));
      return (exception ());
    }
  else if (!coro_p (*ret))
    {
      crp->mark_invalid ();
      kp_return (NIL);
    }

  kp_return (*ret);
}

coroutine* coroutine::alloc_raw ()
{
  coroutine *ret = alloch<coroutine> ();
  ret->value = ret->argv = ret->dbinds = NIL;
  ret->frame = 0u;
  ret->ip_offset = ret->sp_diff = 0;
  return (ret);
}

object alloc_coroutine (interpreter *interp)
{
  auto ret = coroutine::alloc_raw ();
  interp->alval = ret->as_obj ();
  gc_register (interp, ret);
  return (interp->alval);
}

result<object> coroutine::make (interpreter *interp, uint32_t bp)
{
  auto eg = KP_TRY (evh_guard::make (interp));
  coroutine *ret = coroutine::alloc_raw ();

  ret->value = UNBOUND;
  ret->argv = KP_TRY (make_argv (interp, bp, ret));
  interp->alval = ret->as_obj ();
  gc_register (interp, ret);
  return (interp->alval);
}

result<int64_t> pack_G (interpreter *interp, stream *strm,
                        object obj, pack_info& info)
{
  coroutine *crp = as_coro (obj);
  int64_t ret = KP_TRY (strm->write (interp, &crp->ip_offset));
  ret += KP_TRY (strm->write (interp, &crp->sp_diff));
  ret += KP_TRY (strm->write (interp, &crp->exc_off));
  ret += KP_TRY (strm->write (interp, &crp->frame));
  ret += KP_TRY (xpack (interp, strm, crp->value, info));
  ret += KP_TRY (xpack (interp, strm, crp->argv, info));
  return (ret);
}

result<object> unpack_G (interpreter *interp, stream *strm,
                         pack_info& info, bool save)
{
  valref ret (interp, alloc_coroutine (interp));
  coroutine *crp = as_coro (*ret);
  bool rv = KP_TRY (strm->sread (interp, &crp->ip_offset));
  rv = rv && KP_TRY (strm->sread (interp, &crp->sp_diff));
  rv = rv && KP_TRY (strm->sread (interp, &crp->exc_off));
  rv = rv && KP_TRY (strm->sread (interp, &crp->frame));

  if (!rv)
    return (info.error ("invalid offsets read"));

  crp->value = KP_TRY (xunpack (interp, strm, info));
  crp->argv = KP_TRY (xunpack (interp, strm, info));

  if (!array_p (crp->argv))
    return (info.error ("coroutine stack must be an array"));
  else if (save)
    KP_VTRY (info.add_mapping (interp, *info.offset, *ret));

  kp_return (*ret);
}

KP_DECLS_END