khipu/bytecode.cpp

/* Definitions for the bytecode operations.

   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 <cstring>
#include <cstdio>
#include "bytecode.hpp"
#include "interp.hpp"
#include "array.hpp"
#include "bvector.hpp"
#include "stream.hpp"
#include "function.hpp"
#include "io.hpp"

KP_DECLS_BEGIN

static const char OPC_NAMES[] =
  "nop\0dup\0pop\0ret\0is\0not\0cons\0car\0cdr\0cadr\0apply\0tapply\0"
  "loadt\0loadnil\0load0\0load1\0loada0\0loada1\0loadc00\0loadc01\0mkcont\0"
  "closure\0vframe\0tryend\0ldcaller\0clrexc\0symname\0sympkg\0coroval\0"
  "typep\0typep2\0raise\0loadi8\0loadi32\0loadchr8\0loadchr32\0vargc\0"
  "vargc.l\0jmp\0jmp.l\0brt\0brt.l\0brn\0brn.l\0brneq\0brneq.l\0tcall\0"
  "tcall.l\0call\0call.l\0recur\0recur.l\0trecur\0trecur.l\0setc0\0setc0.l\0"
  "setc\0setc.l\0seta\0seta.l\0setg\0setg.l\0setfgs\0setfgs.l\0loadc0\0"
  "loadc0.l\0loadc\0loadc.l\0loada\0loada.l\0loadg\0loadg.l\0loadv\0"
  "loadv.l\0loadx\0loadx.l\0loadfgs\0loadfgs.l\0bind\0bind.l\0trybegin\0"
  "trybegin.l\0setapop\0setapop.l\0irtjmp\0irtjmp.l\0optargs\0optargs.l\0"
  "brbound\0brbound.l\0kwargs\0kwargs.l\0jmpt\0jmpt.l\0jmpn\0jmpn.l\0"
  "box\0box.l\0loadb\0loadb.l\0setb\0setb.l\0skip\0skip.l\0unbind\0unbind.l\0";

#define BC_CALL_FORM     bcode_instr::BC_CALL_FORM
#define BC_LOAD_FORM     bcode_instr::BC_LOAD_FORM
#define BC_BRANCH_FORM   bcode_instr::BC_BRANCH_FORM
#define BC_LONG_FORM     bcode_instr::BC_LONG_FORM
#define BC_PURE_FORM     bcode_instr::BC_PURE_FORM

static const bcode_instr BCODE_INSTR[] =
{
  { 0, 0 },   // nop
  { 4, 0 },   // dup
  { 8, 0 },   // pop
  { 12, 0 },   // ret
  { 16, 0 },   // is
  { 19, 0 },   // not
  { 23, 0 },   // cons
  { 28, 0 },   // car
  { 32, 0 },   // cdr
  { 36, 0 },   // cadr
  { 41, 1 | BC_CALL_FORM },   // apply
  { 47, 1 | BC_CALL_FORM },   // tapply
  { 54, 0 | BC_LOAD_FORM | BC_PURE_FORM },   // loadt
  { 60, 0 | BC_LOAD_FORM | BC_PURE_FORM },   // loadnil
  { 68, 0 | BC_LOAD_FORM | BC_PURE_FORM },   // load0
  { 74, 0 | BC_LOAD_FORM | BC_PURE_FORM },   // load1
  { 80, 0 | BC_LOAD_FORM | BC_PURE_FORM },   // loada0
  { 87, 0 | BC_LOAD_FORM | BC_PURE_FORM },   // loada1
  { 94, 0 | BC_LOAD_FORM | BC_PURE_FORM },   // loadc00
  { 102, 0 | BC_LOAD_FORM | BC_PURE_FORM },   // loadc01
  { 110, 1 | BC_LOAD_FORM },   // mkcont
  { 117, 0 },   // closure
  { 125, 0 },   // vframe
  { 132, 0 },   // tryend
  { 139, 0 | BC_LOAD_FORM | BC_PURE_FORM },   // ldcaller
  { 148, 0 },   // clrexc
  { 155, 0 },   // symname
  { 163, 0 },   // sympkg
  { 170, 0 },   // coroval
  { 178, 1 | BC_PURE_FORM },   // typep
  { 184, 2 | BC_PURE_FORM },   // typep2
  { 191, 1 },   // raise
  { 197, 1 | BC_LOAD_FORM | BC_PURE_FORM },   // loadi8
  { 204, 1 | BC_LOAD_FORM | BC_PURE_FORM | BC_LONG_FORM },   // loadi32
  { 212, 1 | BC_LOAD_FORM | BC_PURE_FORM },   // loadchr8
  { 221, 1 | BC_LOAD_FORM | BC_PURE_FORM | BC_LONG_FORM },   // loadchr32
  { 231, 1 },   // vargc
  { 237, 1 | BC_LONG_FORM },   // vargc.l
  { 245, 1 | BC_BRANCH_FORM },   // jmp
  { 249, 1 | BC_BRANCH_FORM | BC_LONG_FORM },   // jmp.l
  { 255, 1 | BC_BRANCH_FORM },   // brt
  { 259, 1 | BC_BRANCH_FORM | BC_LONG_FORM },   // brt.l
  { 265, 1 | BC_BRANCH_FORM },   // brn
  { 269, 1 | BC_BRANCH_FORM | BC_LONG_FORM },   // brn.l
  { 275, 1 | BC_BRANCH_FORM },   // brneq
  { 281, 1 | BC_BRANCH_FORM | BC_LONG_FORM },   // brneq.l
  { 289, 1 | BC_CALL_FORM },   // tcall
  { 295, 1 | BC_CALL_FORM | BC_LONG_FORM },   // tcall.l
  { 303, 1 | BC_CALL_FORM },   // call
  { 308, 1 | BC_CALL_FORM | BC_LONG_FORM },   // call.l
  { 315, 1 | BC_CALL_FORM },   // recur
  { 321, 1 | BC_CALL_FORM | BC_LONG_FORM },   // recur.l
  { 329, 1 | BC_CALL_FORM },   // trecur
  { 336, 1 | BC_CALL_FORM | BC_LONG_FORM },   // trecur.l
  { 345, 1 },   // setc0
  { 351, 1 | BC_LONG_FORM },   // setc0.l
  { 359, 2 },   // setc
  { 364, 2 | BC_LONG_FORM },   // setc.l
  { 371, 1 },   // seta
  { 376, 1 | BC_LONG_FORM },   // seta.l
  { 383, 1 },   // setg
  { 388, 1 | BC_LONG_FORM },   // setg.l
  { 395, 1 },   // setfgs
  { 402, 1 | BC_LONG_FORM },   // setfgs.l
  { 411, 1 | BC_LOAD_FORM | BC_PURE_FORM },   // loadc0
  { 418, 1 | BC_LOAD_FORM | BC_PURE_FORM },   // loadc0.l
  { 427, 2 | BC_LOAD_FORM | BC_PURE_FORM },   // loadc
  { 433, 2 | BC_LOAD_FORM | BC_PURE_FORM | BC_LONG_FORM },   // loadc.l
  { 441, 1 | BC_LOAD_FORM | BC_PURE_FORM },   // loada
  { 447, 1 | BC_LOAD_FORM | BC_PURE_FORM | BC_LONG_FORM },   // loada.l
  { 455, 1 | BC_LOAD_FORM },   // loadg
  { 461, 1 | BC_LOAD_FORM | BC_LONG_FORM },   // loadg.l
  { 469, 1 | BC_LOAD_FORM | BC_PURE_FORM },   // loadv
  { 475, 1 | BC_LOAD_FORM | BC_PURE_FORM | BC_LONG_FORM },   // loadv.l
  { 483, 1 | BC_LOAD_FORM },   // loadx
  { 489, 1 | BC_LOAD_FORM | BC_LONG_FORM },   // loadx.l
  { 497, 1 | BC_LOAD_FORM },   // loadfgs
  { 505, 1 | BC_LOAD_FORM | BC_LONG_FORM },   // loadfgs.l
  { 515, 1 },   // bind
  { 520, 1 | BC_LONG_FORM },   // bind.l
  { 527, 1 | BC_BRANCH_FORM },   // trybegin
  { 536, 1 | BC_BRANCH_FORM | BC_LONG_FORM },   // trybegin.l
  { 547, 1 },   // setapop
  { 555, 1 | BC_LONG_FORM },   // setapop.l
  { 565, 1 | BC_BRANCH_FORM },   // irtjmp
  { 572, 1 | BC_BRANCH_FORM | BC_LONG_FORM },   // irtjmp.l
  { 581, 2 },   // optargs
  { 589, 2 | BC_LONG_FORM },   // optargs.l
  { 599, 1 },   // brbound
  { 607, 1 | BC_LONG_FORM },   // brbound.l
  { 617, 3 },   // kwargs
  { 624, 3 | BC_LONG_FORM },   // kwargs.l
  { 633, 1 | BC_BRANCH_FORM },   // jmpt
  { 638, 1 | BC_BRANCH_FORM | BC_LONG_FORM },   // jmpt.l
  { 645, 1 | BC_BRANCH_FORM },   // jmpn
  { 650, 1 | BC_BRANCH_FORM | BC_LONG_FORM },   // jmpn.l
  { 657, 1 },   // box
  { 661, 1 | BC_LONG_FORM },   // box.l
  { 667, 1 | BC_LOAD_FORM | BC_PURE_FORM },   // loadb
  { 673, 1 | BC_LOAD_FORM | BC_LONG_FORM | BC_PURE_FORM },   // loadb.l
  { 681, 1 },   // setb
  { 686, 1 | BC_LONG_FORM },   // setb.l
  { 693, 1 },   // skip
  { 698, 1 | BC_LONG_FORM },   // skip.l
  { 705, 1 },   // unbind
  { 712, 1 | BC_LONG_FORM },   // unbind.l
  { 0, 0 }
};

#undef BC_CALL_FORM
#undef BC_LOAD_FORM
#undef BC_BRANCH_FORM
#undef BC_LONG_FORM
#undef BC_PURE_FORM

const bcode_instr* bcode_get (int opc)
{
  return (&BCODE_INSTR[opc]);
}

int bcode_instr::opcode () const
{
  return ((int)(this - &BCODE_INSTR[0]));
}

const char* bcode_instr::name () const
{
  return (OPC_NAMES + this->name_off);
}

static result<void> disasm_aux (interpreter *, object, stream *, int);

static result<void>
disasm_print (interpreter *interp, object val, stream *strm, int lv)
{
  if (fct_p (val))
    KP_VTRY (strm->putb (interp, '\n'),
             disasm_aux (interp, val, strm, lv + 1));
  else
    {
      io_info info;

      info.flags &= ~io_info::FLG_RAW;
      KP_VTRY (strm->putb (interp, ' '),
               xwrite (interp, strm, val, info));
    }

  return (0);
}

static result<void>
disasm_aux (interpreter *interp, object fn, stream *strm, int lv)
{
  if (native_fct_p (fn))
    {
      const char *nm = fct_sname (fn);
      KP_VTRY (strm->nputb (interp, lv * 2, ' '),
               strm->write (interp, "00: builtin-call ", 17),
               strm->write (interp, nm, strlen (nm)),
               strm->putb (interp, '\n'));
      return (0);
    }

  const bvector *bc = as_bvector (fct_bcode (fn));
  const unsigned char *code = bc->data;
  const array *vals = as_array (fct_vals (fn));
  int sx, width = bc->nbytes < 0xff ? 2 :
    bc->nbytes < 0xffff ? 4 : 8;

  for (uint32_t i = 0; i < bc->nbytes; )
    {
      char buf[64];
      const bcode_instr *instrp = bcode_get (code[i]);

      KP_VTRY (strm->nputb (interp, lv * 2, ' '),
               strm->write (interp, buf, sprintf (buf, "%0*x: %s",
                                                  width, i++,
                                                  instrp->name ())));

      bool done = false;

      switch (instrp->opcode ())
        {
          case OP_LOADV: case OP_LOADVL: case OP_SETG: case OP_SETGL:
          case OP_LOADG: case OP_LOADGL: case OP_LOADX: case OP_LOADXL:
          case OP_BIND: case OP_BINDL:
            sx = instrp->getuarg (&code[i]);
            KP_VTRY (disasm_print (interp, vals->data[sx], strm, lv));
            done = true;
            break;

          case OP_LOADFGS: case OP_LOADFGSL: case OP_SETFGS: case OP_SETFGSL:
            sx = instrp->getuarg (&code[i]);
            KP_VTRY (disasm_print (interp, symbol::fast_global_syms[sx],
                                   strm, lv));
            done = true;

          default:
            break;
        }

      if (done)
        ;
      else if (instrp->branch_p ())
        KP_VTRY (strm->write (interp, buf,
                              sprintf (buf, " %0*x", width,
                                       i + instrp->getsarg (&code[i]))));
      else
        {
          int nops = 0, nx = i;
          for (; nops < instrp->nops () - 1;
              ++nops, nx += instrp->argsize ())
            KP_VTRY (strm->write (interp, buf,
                                  sprintf (buf, " %d",
                                           instrp->getsarg (&code[nx]))));

          if (instrp->nops () > 0)
            KP_VTRY (strm->write (interp, buf,
                                  sprintf (buf, " %d",
                                           instrp->getsarg (&code[nx]))));
        }

      i += instrp->nops () * instrp->argsize ();
      KP_VTRY (strm->putb (interp, '\n'));
    }

  return (0);
}

result<void> disasm (interpreter *interp, object fn, object out)
{
  if (!fct_p (fn))
    return (interp->raise ("type-error", "first argument must be a function"));
  else if (!stream_p (out))
    return (interp->raise ("type-error", "second argument must be a stream"));

  return (disasm_aux (interp, fn, as_stream (out), 0));
}

KP_DECLS_END