rosella/interp.c

#include <inttypes.h>
#include <stdbool.h>
#include <stdlib.h>

#include "builtin.h"
#include "gc.h"

/* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */
#define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s])
#define _LAMBDA_SLOT(v,s)  _SLOT_VALUE(LAMBDA, v, s)

typedef struct interp_state
{
  gc_root_t lambda;
  gc_root_t frame;
  gc_root_t argv;
  gc_root_t k;
  gc_root_t ctx;
} interp_state_t;

/* Quick references to main builtins */
static gc_root_t structure_type_root;
static gc_root_t template_type_root;
static gc_root_t lambda_type_root;

/* Local helper routines */
static bool struct_is_a(value_t s, value_t type);
static void translate_callable(interp_state_t *state);
static void run_byte_code(interp_state_t *state);
static void perform_tail_call(interp_state_t *state);
static value_t get_input(const interp_state_t *state, fixnum_t var);
static void set_output(const interp_state_t *state, fixnum_t var, value_t val);
static void register_state(interp_state_t *state, value_t lambda, value_t argv);
static void unregister_state(interp_state_t *state);

void interpreter_init(void)
{
  register_gc_root(&structure_type_root, lookup_builtin(BI_STRUCTURE));
  register_gc_root(&template_type_root,  lookup_builtin(BI_TEMPLATE));
  register_gc_root(&lambda_type_root,    lookup_builtin(BI_LAMBDA));
}

value_t run_interpreter(value_t lambda, value_t argv)
{
  static bool run_finalizers = true;
  interp_state_t state;

  register_state(&state, lambda, argv);

  /* Keep going until something attempt to tail-call NIL, the original 'k', indicating completion. */
  while (!is_nil(state.lambda.value))
  {
    /* 'lambda' may be a callable structure; if so, follow the 'callable' proxies and update argv. */
    translate_callable(&state);

    /*
     * Now 'lambda' really is a lambda structure instance.
     */

    /* Allocate frame variables */
    state.frame.value = make_vector(get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS)), NIL);

    run_byte_code(&state);
    perform_tail_call(&state);

    if (run_finalizers)
    {
      value_t v, f;
      get_next_finalizer(&v, &f);

      if (is_object(v))
      {
        gc_root_t f_root;

        register_gc_root(&f_root, f);
        run_finalizers = false;

        /* Note that recursion is limited to a single level by the static variable. */
        run_interpreter(f_root.value, cons(v, NIL));

        run_finalizers = true;
        unregister_gc_root(&f_root);
      }
    }
  }

  unregister_state(&state);

  /* The arguments passed to NIL continuation are the final return value. */
  return state.argv.value;
}

/* TODO: Check for cycles (besides 'structure') and permit derivatives of 'structure'. */
static bool struct_is_a(value_t s, value_t type)
{
  /* To prevent unbounded loops w/ cyclic 'parent' links. */
  int ttl = 256;

  if (!is_struct(s))
    return false;

  for (value_t t = _get_struct(s)->type; t != type; t = _SLOT_VALUE(STRUCTURE, t, SUPER), --ttl)
  {
    if (is_nil(t))
      return false;

    if (get_struct(t)->type != structure_type_root.value)
      abort();

    if (ttl <= 0)
      abort();
  }

  return true;
}

static void translate_callable(interp_state_t *state)
{
  while (!struct_is_a(state->lambda.value, lambda_type_root.value))
  {
    if (!struct_is_a(get_struct(state->lambda.value)->type, structure_type_root.value))
      abort();

    /* Prepend structure instance to argument list, per proxy protocol. */
    state->argv.value = cons(state->lambda.value, state->argv.value);

    /* Follow link to next callable. */
    state->lambda.value = _SLOT_VALUE(STRUCTURE, _get_struct(state->lambda.value)->type, CALLABLE);
  }
}

static void run_byte_code(interp_state_t *state)
{
  /* TODO */
}

static void perform_tail_call(interp_state_t *state)
{
  value_t new_lambda, new_argv, new_ctx, new_k;

  new_lambda = get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, TAIL_CALL)));
  new_argv   = get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, ARG_LIST)));
  new_k      = get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, CONTINUATION)));
  new_ctx    = get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, CONTEXT)));

  state->lambda.value = new_lambda;
  state->argv.value   = new_argv;
  state->k.value      = new_k;
  state->ctx.value    = new_ctx;
}

static value_t get_input(const interp_state_t *state, fixnum_t var)
{
  if (var >= 256)
    abort();
  else if (var == 255)
    return state->ctx.value;
  else if (var == 254)
    return state->k.value;
  else if (var == 253)
    return state->argv.value;
  else if (var >= 248)
    abort(); /* reserved */
  else if (var >= 128)
  {
    vector_t *vec = _get_vector(state->frame.value);
    var -= 128;

    if (var >= vec->size)
      abort();

    return vec->elements[var];
  }
  else if (var >= 64)
  {
    vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, INSTANCE_VARS));
    var -= 64;

    if (var >= vec->size)
      abort();

    return vec->elements[var];
  }
  else if (var >= 1)
  {
    vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, GLOBAL_VARS));
    var -= 1;

    if (var >= vec->size)
      abort();

    return vec->elements[var];
  }
  else if (var == 0)
    return NIL;
  else
    abort();
}

static void set_output(const interp_state_t *state, fixnum_t var, value_t val)
{
  vector_t *vec = _get_vector(state->frame.value);

  if (var < 128)
    abort();

  var -= 128;

  if (var >= vec->size)
    abort();

  vec->elements[var] = val;
}

static void register_state(interp_state_t *state, value_t lambda, value_t argv)
{
  register_gc_root(&state->lambda, lambda);
  register_gc_root(&state->frame,  NIL);
  register_gc_root(&state->argv,   argv);
  register_gc_root(&state->k,      NIL);
  register_gc_root(&state->ctx,    NIL);
}

static void unregister_state(interp_state_t *state)
{
  unregister_gc_root(&state->lambda);
  unregister_gc_root(&state->frame);
  unregister_gc_root(&state->argv);
  unregister_gc_root(&state->k);
  unregister_gc_root(&state->ctx);
}

/* vim:set sw=2 expandtab: */