/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * disassembler.d - bytecodes disassembler utilities
 *
 * Copyright (c) 2001 Juan Jose Garcia Ripoll
 *
 * See file 'LICENSE' for the copyright details.
 *
 */

#include <ecl/ecl.h>
#include <ecl/ecl-inl.h>
#include <ecl/bytecodes.h>
#include <ecl/internal.h>

static cl_opcode *disassemble(cl_object bytecodes, cl_opcode *vector);

static cl_opcode *base = NULL;

static void
print_noarg(const char *s) {
  ecl_princ_str(s, ECL_NIL);
}

static void
print_oparg(const char *s, cl_fixnum n) {
  ecl_princ_str(s, ECL_NIL);
  ecl_princ(ecl_make_fixnum(n), ECL_NIL);
}

static void
print_arg(const char *s, cl_object x) {
  ecl_princ_str(s, ECL_NIL);
  ecl_princ(x, ECL_NIL);
}

static void
print_oparg_arg(const char *s, cl_fixnum n, cl_object x) {
  ecl_princ_str(s, ECL_NIL);
  ecl_princ(ecl_make_fixnum(n), ECL_NIL);
  ecl_princ_str(",", ECL_NIL);
  ecl_princ(x, ECL_NIL);
}

#define GET_DATA(r,v,data) {                    \
    cl_oparg ndx;                               \
    GET_OPARG(ndx, v);                          \
    r = data[ndx];                              \
  }

static void
disassemble_lambda(cl_object bytecodes) {
  const cl_env_ptr env = ecl_process_env();
  cl_opcode *vector;

  ecl_bds_bind(env, @'*print-pretty*', ECL_NIL);

  /* Print required arguments */
  cl_print(1,bytecodes->bytecodes.data);

  /* Name of LAMBDA */
  print_arg("\nName:\t\t", bytecodes->bytecodes.name);
  if (bytecodes->bytecodes.name == OBJNULL ||
      bytecodes->bytecodes.name == @'si::bytecodes') {
    print_noarg("\nEvaluated form:");
    goto NO_ARGS;
  }

 NO_ARGS:
  base = vector = (cl_opcode *)bytecodes->bytecodes.code;
  disassemble(bytecodes, vector);

  ecl_bds_unwind1(env);
}

/* -------------------- DISASSEMBLER CORE -------------------- */

/* OP_FLET      nfun{arg}, fun1{object}
   ...

   Executes the enclosed code in a lexical enviroment extended with
   the functions "fun1" ... "funn".
*/
static cl_opcode *
disassemble_flet(cl_object bytecodes, cl_opcode *vector) {
  cl_index nfun;
  cl_object *data = bytecodes->bytecodes.data->vector.self.t;
  GET_OPARG(nfun, vector);
  print_noarg("FLET");
  while (nfun--) {
    cl_object fun;
    GET_DATA(fun, vector, data);
    print_arg("\n\tFLET\t", fun->bytecodes.name);
  }
  return vector;
}

/* OP_LABELS    nfun{arg}, fun1{object}
   ...

   Executes the enclosed code in a lexical enviroment extended with
   the functions "fun1" ... "funn".
*/
static cl_opcode *
disassemble_labels(cl_object bytecodes, cl_opcode *vector) {
  cl_index nfun;
  cl_object *data = bytecodes->bytecodes.data->vector.self.t;
  GET_OPARG(nfun, vector);
  print_noarg("LABELS");
  while (nfun--) {
    cl_object fun;
    GET_DATA(fun, vector, data);
    print_arg("\n\tLABELS\t", fun->bytecodes.name);
  }
  return vector;
}

/* OP_PROGV     bindings{list}
   ...
   OP_EXIT
   Execute the code enclosed with the special variables in BINDINGS
   set to the values in the list which was passed in VALUES(0).
*/
static cl_opcode *
disassemble_progv(cl_object bytecodes, cl_opcode *vector) {
  print_noarg("PROGV");
  vector = disassemble(bytecodes, vector);
  print_noarg("\t\t; progv");
  return vector;
}

/* OP_TAGBODY   n{arg}
   label1
   ...
   labeln
   label1:
   ...
   labeln:
   ...
   OP_EXIT

   High level construct for the TAGBODY form.
*/
static cl_opcode *
disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) {
  cl_index i, ntags;
  cl_opcode *destination;
  GET_OPARG(ntags, vector);
  print_noarg("TAGBODY");
  for (i=0; i<ntags; i++) {
    GET_LABEL(destination, vector);
    ecl_princ_str("\n\tTAG\t", ECL_NIL);
    ecl_princ(ecl_make_fixnum(i), ECL_NIL);
    ecl_princ_str(" @@ ", ECL_NIL);
    ecl_princ(ecl_make_fixnum(destination - base), ECL_NIL);
  }
  vector = disassemble(bytecodes, vector);
  print_noarg("\t\t; tagbody");

  return vector;
}

static cl_opcode *
disassemble(cl_object bytecodes, cl_opcode *vector) {
  const char *string;
  cl_object o;
  cl_fixnum n, m;
  cl_object line_format;
  cl_object *data = bytecodes->bytecodes.data->vector.self.t;
  cl_object line_no;

  if (cl_fboundp(@'si::formatter-aux') != ECL_NIL)
    line_format = @"~%~4d\t";
  else
    line_format = ECL_NIL;
 BEGIN:
  if (1) {
    line_no = ecl_make_fixnum(vector-base);
  } else {
    line_no = @'*';
  }
  if (line_format != ECL_NIL) {
    cl_format(3, ECL_T, line_format, line_no);
  } else {
    ecl_princ_char('\n', ECL_NIL);
    ecl_princ(line_no, ECL_NIL);
    ecl_princ_char('\t', ECL_NIL);
  }
  switch (GET_OPCODE(vector)) {

    /* OP_NOP
       Sets VALUES(0) = NIL and NVALUES = 1
    */
  case OP_NOP:            string = "NOP"; goto NOARG;

  case OP_INT:            string = "QUOTE\t";
    GET_OPARG(n, vector);
    goto OPARG;

  case OP_PINT:           string = "PUSH\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_QUOTE
       Sets VALUES(0) to an immediate value.
    */
  case OP_QUOTE:          string = "QUOTE\t";
    GET_DATA(o, vector, data);
    goto ARG;

    /* OP_CSET      n{arg}
       Replace constant with a computed value
    */
  case OP_CSET:           string = "CSET\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_VAR       n{arg}
       Sets reg0 to the value of the n-th local.
    */
  case OP_VAR:            string = "VAR\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_VARC      n{arg}
       Sets reg0 to the value of the n-th lexical.
    */
  case OP_VARC:           string = "VARC\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_VARS      var{symbol}
       Sets reg0 to the value of the symbol VAR.
       VAR should be either a special variable or a constant.
    */
  case OP_VARS:           string = "VARS\t";
    GET_DATA(o, vector, data);
    goto ARG;

    /* OP_PUSH
       Pushes the object in VALUES(0).
    */
  case OP_PUSH:           string = "PUSH\tVALUES(0)";
    goto NOARG;

  case OP_VALUEREG0:      string = "SET\tVALUES(0),REG0";
    goto NOARG;

    /* OP_PUSHV     n{arg}
       Pushes the value of the n-th local onto the stack.
    */
  case OP_PUSHV:          string = "PUSHV\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_PUSHV     n{arg}
       Pushes the value of the n-th lexical onto the stack.
    */
  case OP_PUSHVC:         string = "PUSHVC\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_PUSHVS    var{symbol}
       Pushes the value of the symbol VAR onto the stack.
       VAR should be either a special variable or a constant.
    */
  case OP_PUSHVS:         string = "PUSHVS\t";
    GET_DATA(o, vector, data);
    goto ARG;

    /* OP_PUSHQ     value{object}
       Pushes "value" onto the stack.
    */
  case OP_PUSHQ:          string = "PUSH\t'";
    GET_DATA(o, vector, data);
    goto ARG;

    /* OP_PUSHVALUES
       Pushes the values output by the last form, plus the number
       of values.
    */
  case OP_PUSHVALUES:     string = "PUSH\tVALUES";
    goto NOARG;
    /* OP_PUSHMOREVALUES
       Adds more values to the ones pushed by OP_PUSHVALUES.
    */
  case OP_PUSHMOREVALUES: string = "PUSH\tMORE VALUES";
    goto NOARG;
    /* OP_POP
       Pops a single value pushed by a OP_PUSH[V[S]] operator.
    */
  case OP_POP:            string = "POP";
    goto NOARG;
    /* OP_POP1
       Pops a single value pushed by a OP_PUSH[V[S]] operator.
    */
  case OP_POP1:           string = "POP1";
    goto NOARG;
    /* OP_POPVALUES
       Pops all values pushed by a OP_PUSHVALUES operator.
    */
  case OP_POPVALUES:      string = "POP\tVALUES";
    goto NOARG;

  case OP_BLOCK:          string = "BLOCK\t";
    GET_DATA(o, vector, data);
    goto ARG;
  case OP_CATCH:          string = "CATCH\tREG0";
    goto NOARG;
  case OP_DO:             string = "BLOCK\t";
    o = ECL_NIL;
    goto ARG;
  case OP_FRAME:          string = "FRAME\t";
    goto JMP;

    /* OP_CALL      n{arg}
       Calls the function in VALUES(0) with N arguments which
       have been deposited in the stack. The output values
       are left in VALUES(...)
    */
  case OP_CALL:           string = "CALL\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_CALLG     n{arg}, name{arg}
       Calls the function NAME with N arguments which have been
       deposited in the stack. The output values are left in VALUES.
    */
  case OP_CALLG:          string = "CALLG\t";
    GET_OPARG(n, vector);
    GET_DATA(o, vector, data);
    goto OPARG_ARG;

    /* OP_FCALL     n{arg}
       Calls the function in the stack with N arguments which
       have been also deposited in the stack. The output values
       are left in VALUES(...)
    */
  case OP_STEPCALL:
  case OP_FCALL:          string = "FCALL\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_MCALL
       Similar to FCALL, but gets the number of arguments from
       the stack (They all have been deposited by OP_PUSHVALUES)
    */
  case OP_MCALL:          string = "MCALL";
    goto NOARG;

    /* OP_POPREQ
       Extracts next required argument.
    */
  case OP_POPREQ:         string = "POP\tREQ";
    goto NOARG;
    /* OP_NOMORE
       Ensure there are no more arguments.
    */
  case OP_NOMORE:         string = "NOMORE";
    goto NOARG;
    /* OP_POPOPT
       Extracts next optional argument.
    */
  case OP_POPOPT:         string = "POP\tOPT";
    goto NOARG;
    /* OP_POPREST
       Extracts list of remaining arguments.
    */
  case OP_POPREST:        string = "POP\tREST";
    goto NOARG;
    /* OP_PUSHKEYS
       Parses the keyword arguments
    */
  case OP_PUSHKEYS:       string = "PUSH\tKEYS ";
    GET_DATA(o, vector, data);
    goto ARG;

    /* OP_EXIT
       Marks the end of a high level construct
    */
  case OP_EXIT:           print_noarg("EXIT");
    return vector;
    /* OP_EXIT_FRAME
       Marks the end of a high level construct (BLOCK, CATCH...)
    */
  case OP_EXIT_FRAME:     string = "EXIT\tFRAME";
    goto NOARG;
    /* OP_EXIT_TAGBODY
       Marks the end of a high level construct (TAGBODY)
    */
  case OP_EXIT_TAGBODY:   print_noarg("EXIT\tTAGBODY");
    return vector;

  case OP_FLET:           vector = disassemble_flet(bytecodes, vector);
    break;
  case OP_LABELS:         vector = disassemble_labels(bytecodes, vector);
    break;

    /* OP_LFUNCTION index{fixnum}
       Extracts nth function defined in the local environment.
    */
  case OP_LFUNCTION:      string = "LOCFUNC\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_CFUNCTION index{fixnum}
       Extracts nth function defined in the lexical environment.
    */
  case OP_CFUNCTION:      string = "LEXFUNC\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_FUNCTION  name{symbol}
       Extracts the function associated to a symbol. The function
       is defined in the global environment.
    */
  case OP_FUNCTION:       string = "SYMFUNC\t";
    GET_DATA(o, vector, data);
    goto ARG;

    /* OP_CLOSE     name{arg}
       Extracts the function associated to a symbol. The function
       may be defined in the global environment or in the local
       environment. This last value takes precedence.
    */
  case OP_CLOSE:          string = "CLOSE\t";
    GET_DATA(o, vector, data);
    goto ARG;

    /* OP_GO        n{arg}, tag-ndx{arg}
       OP_GO_CFB    n{lex}, tag-ndx{arg}

       Jumps to the tag which is defined for the tagbody
       frame registered at the n-th position in the lexical
       environment. TAG-NDX is the number of tag in the list.
    */
  case OP_GO:             string = "GO\t";
    GET_OPARG(n, vector);
    GET_OPARG(m, vector);
    o = ecl_make_fixnum(m);
    goto OPARG_ARG;

  case OP_GO_CFB:         string = "GO_CFB\t";
    GET_OPARG(n, vector);
    GET_OPARG(m, vector);
    o = ecl_make_fixnum(m);
    goto OPARG_ARG;

    /* OP_RETURN        n{arg}
       OP_RETURN_CFB    n{lex}

       Returns from the block whose record in the lexical environment
       occuppies the n-th position.
   */
  case OP_RETURN:         string = "RETFROM\t";
    GET_OPARG(n, vector);
    goto OPARG;

  case OP_RETURN_CFB:         string = "RETFROM_CFB\t";
    GET_OPARG(n, vector);
    goto OPARG;

    /* OP_THROW
       Jumps to an enclosing CATCH form whose tag matches the one
       of the THROW. The tag is taken from the stack, while the
       output values are left in VALUES(...).
    */
  case OP_THROW:          string = "THROW";
    goto NOARG;

    /* OP_JMP       label{arg}
       OP_JNIL      label{arg}
       OP_JT        label{arg}
       OP_JEQ       label{arg}, value{object}
       OP_JNEQ      label{arg}, value{object}
       Direct or conditional jumps. The conditional jumps are made
       comparing with the value of VALUES(0).
    */
  case OP_JMP:            string = "JMP\t";
    goto JMP;
  case OP_JNIL:           string = "JNIL\t";
    goto JMP;
  case OP_JT:             string = "JT\t";
  JMP: {                  GET_OPARG(m, vector);
      n = vector + m - OPARG_SIZE - base;
      goto OPARG;
    }
  case OP_JEQL:           string = "JEQL\t";
    goto JEQL;
  case OP_JNEQL:          string = "JNEQL\t";
  JEQL: {                 GET_DATA(o, vector, data);
      GET_OPARG(m, vector);
      n = vector + m - OPARG_SIZE - base;
      goto OPARG_ARG;
    }
  case OP_NOT:            string = "NOT";
    goto NOARG;

    /* OP_UNBIND    n{arg}
       Undo "n" bindings of lexical variables.
    */
  case OP_UNBIND:         string = "UNBIND\t";
    GET_OPARG(n, vector);
    goto OPARG;
    /* OP_UNBINDS   n{arg}
       Undo "n" bindings of special variables.
    */
  case OP_UNBINDS:        string = "UNBINDS\t";
    GET_OPARG(n, vector);
    goto OPARG;
    /* OP_BIND      name{symbol}
       OP_PBIND     name{symbol}
       OP_BINDS     name{symbol}
       OP_PBINDS    name{symbol}
       Binds a lexical or special variable to the either the
       value of VALUES(0), to the first value of the stack, or
       to the n-th value of VALUES(...).
    */
  case OP_BIND:           string = "BIND\t";
    GET_DATA(o, vector, data);
    goto ARG;
  case OP_PBIND:          string = "PBIND\t";
    GET_DATA(o, vector, data);
    goto ARG;
  case OP_VBIND:          string = "VBIND\t";
    GET_OPARG(n, vector);
    GET_DATA(o, vector, data);
    goto OPARG_ARG;
  case OP_BINDS:          string = "BINDS\t";
    GET_DATA(o, vector, data);
    goto ARG;
  case OP_PBINDS:         string = "PBINDS\t";
    GET_DATA(o, vector, data);
    goto ARG;
  case OP_VBINDS:         string = "VBINDS\t";
    GET_OPARG(n, vector);
    GET_DATA(o, vector, data);
    goto OPARG_ARG;
    /* OP_SETQ      n{arg}
       OP_SETQC     n{arg}
       OP_SETQS     n{arg}

       OP_PSETQ     n{arg}
       OP_PSETQC    n{arg}
       OP_PSETQS    n{arg}

       OP_VSETQ     n{arg}, nvalue{arg}
       OP_VSETQC    n{arg}, nvalue{arg}
       OP_VSETQS    n{arg}, nvalue{arg}

       Sets either the n-th variable to either the value in REG0 (OP_SETQ[CS])
       or to the first value on the stack (OP_PSETQ[CS]), or to a given value
       from the multiple values array (OP_VSETQ[CS]). Note NVALUE > 0 strictly.
    */
  case OP_SETQ:           string = "SETQ\t";
    GET_OPARG(n, vector);
    goto OPARG;
  case OP_SETQC:          string = "SETQC\t";
    GET_OPARG(n, vector);
    goto OPARG;
  case OP_SETQS:          string = "SETQS\t";
    GET_DATA(o, vector, data);
    goto ARG;

  case OP_PSETQ:          string = "PSETQ\t";
    GET_OPARG(n, vector);
    goto OPARG;
  case OP_PSETQC:         string = "PSETQC\t";
    GET_DATA(o, vector, data);
    goto ARG;
  case OP_PSETQS:         string = "PSETQS\t";
    GET_DATA(o, vector, data);
    goto ARG;

  case OP_VSETQ:          string = "VSETQ\t";
    GET_OPARG(m, vector);
    o = ecl_make_fixnum(m);
    GET_OPARG(n, vector);
    goto OPARG_ARG;
  case OP_VSETQC:         string = "VSETQC\t";
    GET_OPARG(m, vector);
    o = ecl_make_fixnum(m);
    GET_OPARG(n, vector);
    goto OPARG_ARG;
  case OP_VSETQS:         string = "VSETQS\t";
    GET_DATA(o, vector, data);
    GET_OPARG(n, vector);
    goto OPARG_ARG;

  case OP_PROGV:          vector = disassemble_progv(bytecodes, vector);
    break;
  case OP_EXIT_PROGV:     print_noarg("PROGV\tEXIT");
    return vector;

    /* OP_VALUES    n{arg}
       Pop N values from the stack and store them in VALUES(...)
    */
  case OP_VALUES:         string = "VALUES\t";
    GET_OPARG(n, vector);
    goto OPARG;
    /* OP_NTHVAL
       Set VALUES(0) to the N-th value of the VALUES(...) list.
       The index N-th is extracted from the top of the stack.
    */
  case OP_NTHVAL:         string = "NTHVAL\t";
    goto NOARG;
  case OP_TAGBODY:        vector = disassemble_tagbody(bytecodes, vector);
    break;
  case OP_PROTECT:        string = "PROTECT\t";
    goto JMP;
  case OP_PROTECT_NORMAL: string = "PROTECT\tNORMAL";
    goto NOARG;
  case OP_PROTECT_EXIT:   string = "PROTECT\tEXIT";
    goto NOARG;
  case OP_NIL:            string = "QUOTE\tNIL";
    goto NOARG;
  case OP_PUSHNIL:        string = "PUSH\t'NIL";
    goto NOARG;
  case OP_STEPIN:         string = "STEP\tIN,";
    GET_DATA(o, vector, data);
    goto ARG;
  case OP_STEPOUT:        string = "STEP\tOUT";
    goto NOARG;

  case OP_CONS:           string = "CONS"; goto NOARG;
  case OP_ENDP:           string = "ENDP\tREG0"; goto NOARG;
  case OP_CAR:            string = "CAR\tREG0"; goto NOARG;
  case OP_CDR:            string = "CDR\tREG0"; goto NOARG;
  case OP_LIST:           string = "LIST\t";
    GET_OPARG(n, vector);
    goto OPARG;
  case OP_LISTA:          string = "LIST*\t";
    GET_OPARG(n, vector);
    goto OPARG;
  case OP_CONS_CAR:       string = "CONS-CAR\tREG0"; goto NOARG;
  case OP_CONS_CDR:       string = "CONS-CDR\tREG0"; goto NOARG;

  case OP_CALLG1:         string = "CALLG1\t";
    GET_DATA(o, vector, data);
    goto ARG;
  case OP_CALLG2:         string = "CALLG2\t";
    GET_DATA(o, vector, data);
    goto ARG;

  default:
    FEerror("Unknown code ~S", 1, ecl_make_fixnum(*(vector-1)));
    return vector;
  NOARG:                  print_noarg(string);
    break;
  ARG:                    print_noarg(string);
    @prin1(1, o);
    break;
  OPARG:                  print_oparg(string, n);
    break;
  OPARG_ARG:              print_oparg_arg(string, n, o);
    break;
  }
  goto BEGIN;
}

cl_object
si_bc_disassemble(cl_object v)
{
  if (ecl_t_of(v) == t_bclosure) {
    v = v->bclosure.code;
  }
  if (ecl_t_of(v) == t_bytecodes) {
    disassemble_lambda(v);
    @(return v);
  }
  @(return ECL_NIL);
}

cl_object
si_bc_split(cl_object b)
{
  cl_object vector, data, name, lex = ECL_NIL;

  if (ecl_t_of(b) == t_bclosure) {
    b = b->bclosure.code;
    lex = b->bclosure.lex;
  }
  if (ecl_t_of(b) != t_bytecodes) {
    vector = ECL_NIL;
    data = ECL_NIL;
    name = ECL_NIL;
  } else {
    vector = ecl_alloc_simple_vector(b->bytecodes.code_size *
                                     sizeof(cl_opcode), ecl_aet_b8);
    vector->vector.self.b8 = (uint8_t*)b->bytecodes.code;
    data = cl_copy_seq(b->bytecodes.data);
    name = b->bytecodes.name;
  }
  @(return lex vector data name);
}

cl_object
si_bc_join(cl_object lex, cl_object code, cl_object data, cl_object name)
{
  cl_object output;
  if (lex != ECL_NIL) {
    output = ecl_alloc_object(t_bclosure);
    output->bclosure.code = si_bc_join(ECL_NIL, code, data, name);
    output->bclosure.lex = lex;
    output->bclosure.entry = _ecl_bclosure_dispatch_vararg;
  } else {
    /* Ensure minimal sanity of data */
    unlikely_if (!ECL_VECTORP(code) ||
                 (code->vector.elttype != ecl_aet_b8)) {
      FEwrong_type_nth_arg(@[si::bc-join],
                           0, code,
                           cl_list(2,
                                   @'simple-array',
                                   @'ext::byte8'));
    }
    unlikely_if (!ECL_VECTORP(code) ||
                 (data->vector.elttype != ecl_aet_object)) {
      FEwrong_type_nth_arg(@[si::bc-join],
                           0, code,
                           cl_list(2,
                                   @'simple-array',
                                   ECL_T));
    }
    /* Duplicate the vectors and steal their data pointers */
    code = cl_copy_seq(code);
    data = cl_copy_seq(data);
    output = ecl_alloc_object(t_bytecodes);
    output->bytecodes.name = ECL_NIL;
    output->bytecodes.definition = ECL_NIL;
    output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg;
    output->bytecodes.code_size = code->vector.fillp / sizeof(cl_opcode);
    output->bytecodes.code = (void*)code->vector.self.b8;
    output->bytecodes.data = data;
    output->bytecodes.file = ECL_NIL;
    output->bytecodes.file_position = ECL_NIL;
  }
  @(return output);
}
