vm.c

/**
 * Copyright 2010 Brian Taylor
 *
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 *     http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 */

#include <stdio.h>
#include <stdlib.h>
#include <signal.h>

#include "vm.h"
#include "types.h"
#include "interp.h"
#include "read.h"
#include "gc.h"
#include "ffi.h"

#define UNPACK1(pkg) (long)((pkg >> 16))
#define UNPACK2(pkg) (long)(pkg & 0xFFFF)

#define ARG1 UNPACK1(((long)codes[pc-1]))
#define ARG2 UNPACK2(((long)codes[pc-1]))
#define BC void*

#define length1(x) (CDR(x) == the_empty_list)

#define opcode_table(define)			\
  define(pushvarargs)				\
  define(chainframe)				\
  define(endframe)				\
  define(argcheck)				\
  define(spush)					\
  define(sset)					\
  define(swap)					\
  define(return)				\
  define(cconst)				\
  define(fn)					\
  define(fjump)					\
  define(tjump)					\
  define(jump)					\
  define(callj)					\
  define(lvar)					\
  define(save)					\
  define(gvar)					\
  define(lset)					\
  define(gset)					\
  define(setcc)					\
  define(cc)					\
  define(pop)					\
  define(cons)					\
  define(car)					\
  define(cdr)					\
  define(setcar)				\
  define(setcdr)

/* generate the symbol variable declarations */
#define generate_decls(opcode) object * opcode ## _op;
opcode_table(generate_decls)

/* generate an enumeration of all of the opcodes */
#define generate_enum(opcode) _ ## opcode ## _,
     enum {
       opcode_table(generate_enum)
	 INVALID_BYTECODE,
     } opcodes;

/* generate the stringified form */
#define generate_string(opcode) "" # opcode,

     const char *bytecode_str[] = {
       opcode_table(generate_string)
     };

/* the dispatch table will be built by vm_execute */
object* dispatch_table;
char build_dispatch_table = 0;

/* generate a function that converts a symbol into the corresponding
   bytecode */
#define generate_sym_to_code(opcode)					\
  if(sym == opcode ## _op) {						\
    return VARRAY(dispatch_table)[_ ## opcode ## _];			\
  }

object *symbol_to_code(object * sym) {
  opcode_table(generate_sym_to_code);
  return g->false;
}

DEFUN1(symbol_to_code_proc) {
  return symbol_to_code(FIRST);
}

DEFUN1(make_bytecode_array_proc) {
  BC *bca = MALLOC(LONG(FIRST) * sizeof(BC));
  return make_alien(bca, g->free_ptr_fn);
}

DEFUN1(get_bytecode_proc) {
  BC *bca = ALIEN_PTR(FIRST);
  return make_alien(bca[LONG(SECOND)], g->empty_list);
}

DEFUN1(set_bytecode_proc) {
  BC *bca = ALIEN_PTR(FIRST);
  if(is_alien(THIRD)) {
    bca[LONG(SECOND)] = (BC) ALIEN_PTR(THIRD);
  } else {
    return g->error_sym;
  }
  return THIRD;
}

DEFUN1(set_bytecode_operands_proc) {
  BC *bca = ALIEN_PTR(FIRST);
  long idx = LONG(SECOND);
  long arg1 = LONG(THIRD);
  long arg2 = LONG(FOURTH);

  long combined = ((arg1 << 16) | (arg2 & 0xFFFF));
  bca[idx] = (BC)combined;
  return FIRST;
}

DEFUN1(get_bytecode_operands_proc) {
  BC *bca = ALIEN_PTR(FIRST);
  long idx = LONG(SECOND);
  long combined = (long)bca[idx];

  object *arg1 = make_fixnum(UNPACK1(combined));
  push_root(&arg1);
  object *arg2 = make_fixnum(UNPACK2(combined));
  push_root(&arg2);
  object *result = cons(arg1, arg2);
  pop_root(&arg2);
  pop_root(&arg1);
  return result;
}

/* generate a function that converts a bytecode back into its
   corresponding symbol */

#define generate_code_to_sym(opcode)					\
  if(ALIEN_PTR(FIRST) == ALIEN_PTR(VARRAY(dispatch_table)[_ ## opcode ## _])) { \
    return make_symbol("" # opcode);					\
  }

DEFUN1(code_to_symbol_proc) {
  opcode_table(generate_code_to_sym)
    return g->false;
}

#define VM_ERROR_RESTART(obj)			\
  do {						\
    VPUSH(obj, stack, stack_top);		\
    fn_first_arg = stack_top - 1;		\
    fn = g->vm_error_restart;			\
    pc = 0;					\
    n_args = 1;					\
    env = CENV(g->vm_error_restart);		\
    goto vm_fn_begin;				\
  } while(0)

#define VM_ASSERT(test, msg, ...)			\
  do {							\
    if(!(test)) {					\
      char * buffer = MALLOC(1024);			\
      snprintf(buffer, 1024, msg, ##__VA_ARGS__);	\
      object *msg_obj = make_string(buffer);		\
      FREE(buffer);					\
      VM_ERROR_RESTART(msg_obj);			\
    }							\
  } while(0)

void vector_push(object * stack, object * thing, long top) {
  if(unlikely(top == VSIZE(stack))) {
    long old_size = VSIZE(stack);
    VSIZE(stack) = old_size * 2;
    VARRAY(stack) = REALLOC(VARRAY(stack), sizeof(object *)
			    * VSIZE(stack));
    int ii;
    for(ii = old_size; ii < VSIZE(stack); ++ii) {
      VARRAY(stack)[ii] = g->empty_list;
    }
  }
  VARRAY(stack)[top++] = thing;
}

object *vector_pop(object * stack, long top) {
  object *old = VARRAY(stack)[--top];
  VARRAY(stack)[top] = g->empty_list;
  return old;
}

char sigint_set = 0;

void vm_sigint_handler(int arg __attribute__ ((unused))) {
  sigint_set = 1;
}

#define VM_RETURN(obj)				\
  do {						\
    pop_root(&top);				\
    pop_root(&env);				\
    pop_root(&fn);				\
    pop_root(&stack);				\
    return obj;					\
  } while(0)

/** this code needs to be spliced into several
 *  locations so we just define it once here
 */
#define RETURN_OPCODE_INSTRUCTIONS			\
  /* if there's only one value on the stack,		\
   * we're done */                                      \
  if(stack_top == initial_top + 1) {			\
    object *val;					\
    VPOP(val, stack, stack_top);			\
    VM_RETURN(val);					\
  } else {						\
    object *retval;					\
    object *val;					\
    VPOP(retval, stack, stack_top);			\
    VPOP(val, stack, stack_top);			\
    fn_first_arg = SMALL_FIXNUM(val);			\
    VPOP(val, stack, stack_top);			\
    pc = SMALL_FIXNUM(val);				\
    VPOP(fn, stack, stack_top);				\
    VPOP(env, stack, stack_top);			\
    /* setup for the next loop */			\
    VPUSH(retval, stack, stack_top);			\
    goto vm_fn_begin;					\
  }

#ifdef VM_DEBUGGING
#define VM_DEBUG(msg, obj)			\
  do {						\
    fprintf(stdout, "%s: ", msg);		\
    owrite(stdout, obj);			\
    fprintf(stdout, "\n");			\
  } while(0)
#else
#define VM_DEBUG(msg, obj)
#endif

#define NEXT_INSTRUCTION					\
  do {								\
    const int tgt = pc;						\
    pc += 2;							\
    goto *codes[tgt];						\
  } while(0)

object *vm_execute(object * fn, object * stack, long stack_top, long n_args, object* genv) {
  object *const_array;

  object *env;

  object *top;

  long initial_top = stack_top - n_args;
  long fn_first_arg = stack_top - n_args;
  long pc = 0;
  int ii;
  int nvarargs;
  int dist;
  object *result;
  object *fn_arg;
  object *new_fn;
  int args_for_call;
  int env_num;
  int idx;
  object *next;
  object *data;
  object *var;
  object *val;
  object *slot;
  object *new_stack_top;
  object *cc_env;
  object *new_stack;
  object *cc_fn;

  if(build_dispatch_table) {
    /* build the dispatch table and exit immediately */
    dispatch_table = make_vector(g->error_sym, INVALID_BYTECODE);
    push_root(&dispatch_table);

#define generate_dispatch(opcode)			\
    VARRAY(dispatch_table)[ _ ## opcode ## _] =		\
      make_alien(&& __ ## opcode ## __, g->empty_list);

    opcode_table(generate_dispatch);
    build_dispatch_table = 0;
    return g->error_sym;
  }

  /* bootstrap an empty frame for this function since the callj opcode
     won't have built one for us */

  env = CENV(fn);
  top = g->empty_list;

  push_root(&stack);
  push_root(&fn);
  push_root(&env);
  push_root(&top);

vm_fn_begin:
  if(!is_compiled_proc(fn) && !is_compiled_syntax_proc(fn)) {
    owrite(stderr, fn);
    return g->false;
  }

  BC *codes = ALIEN_PTR(cadr(BYTECODE(fn)));
  const_array = caddr(BYTECODE(fn));

  VM_DEBUG("stack", stack);

  if(sigint_set) {
    sigint_set = 0;
    VM_ASSERT(0, "received SIGINT");
  }

  NEXT_INSTRUCTION;

 __pushvarargs__:
      nvarargs = (int)n_args - ARG1;
      result = g->empty_list;
      push_root(&result);

      for(ii = 0; ii < nvarargs; ++ii) {
	VPOP(top, stack, stack_top);
	result = cons(top, result);
      }

      VPUSH(result, stack, stack_top);
      pop_root(&result);

      VM_DEBUG("after_args environment", env);

      NEXT_INSTRUCTION;

 __chainframe__:
      /* generate a fresh frame for the callee */
      top = make_vector(g->empty_list, ARG1);
      env = cons(top, env);

      NEXT_INSTRUCTION;

 __endframe__:
      /* throw away the stack portion of this function's frame, except
	 the top N. */
      dist = (stack_top - ARG1) - fn_first_arg;
      if(dist > 0) {
	for(ii = 0; ii < ARG1; ++ii) {
	  VARRAY(stack)[fn_first_arg + ii] = VARRAY(stack)[(stack_top - ARG1) + ii];
	}
      }
      stack_top = fn_first_arg + ARG1;

      NEXT_INSTRUCTION;

 __argcheck__:
      /* verify that a function was given the correct number of
	 arguments */
      if(ARG2 == 0) {
	/* looking for an exact match */
	VM_ASSERT(n_args == ARG1, "function expects exactly %ld arguments, got %ld",
		  ARG1,
		  n_args);
      } else {
	/* looking for at least some value */
	VM_ASSERT(n_args >= ARG1, "function expects at least %ld arguments, got %ld",
		  ARG1,
		  n_args);
      }

      NEXT_INSTRUCTION;

 __spush__:
      /* push the Nth argument onto the stack */
      top = VARRAY(stack)[fn_first_arg + ARG1];
      VPUSH(top, stack, stack_top);

      NEXT_INSTRUCTION;

 __sset__:
      /* set stack position N to the value at the top of the
	 stack. leaves the stack unchanged */
      VARRAY(stack)[fn_first_arg + ARG1] = VARRAY(stack)[stack_top - 1];

      NEXT_INSTRUCTION;

 __swap__:
      top = VARRAY(stack)[stack_top - 1];
      VARRAY(stack)[stack_top - 1] = VARRAY(stack)[stack_top - 2];
      VARRAY(stack)[stack_top - 2] = top;

      NEXT_INSTRUCTION;

 __fjump__:
      VPOP(top, stack, stack_top);
      if(is_falselike(top)) {
	pc = ARG1 * 2;		/* offsets are in instructions */
      }

      NEXT_INSTRUCTION;

 __tjump__:
      VPOP(top, stack, stack_top);
      if(!is_falselike(top)) {
	pc = ARG1 * 2;
      }

      NEXT_INSTRUCTION;

 __jump__:
      pc = ARG1 * 2;

      NEXT_INSTRUCTION;

 __fn__:
      fn_arg = VARRAY(const_array)[ARG1];
      new_fn = make_compiled_proc(BYTECODE(fn_arg),
					  env);
      VPUSH(new_fn, stack, stack_top);

      NEXT_INSTRUCTION;

 __callj__:
      VPOP(top, stack, stack_top);

      /* unwrap meta */
      if(is_meta(top)) {
	top = METAPROC(top);
      }

      args_for_call = ARG1;

      /* special case for apply */
      if(args_for_call == -1) {
	/* the args are in a list next, expand those */
	object *args;
	VPOP(args, stack, stack_top);
	VM_ASSERT(is_pair(args) || is_the_empty_list(args), "cannot apply fn to non list");

	args_for_call = 0;
	while(!is_the_empty_list(args)) {
	  VM_ASSERT(is_pair(args), "cannot apply fn to improper list");

	  VPUSH(CAR(args), stack, stack_top);
	  args = CDR(args);
	  ++args_for_call;
	}
      }

      fn_first_arg = stack_top - args_for_call;

      if(is_compiled_proc(top) || is_compiled_syntax_proc(top)) {
	fn = top;
	pc = 0;
	n_args = args_for_call;
	env = CENV(fn);
	goto vm_fn_begin;
      }
      else if(is_primitive_proc(top)) {
	/* build the list the target expects for the call */
	long ii;
	object *pfn = top;

	top = pfn->data.primitive_proc.fn(stack, args_for_call, stack_top);
	/* unwind the stack since primitives don't clean up after
	   themselves */
	object *temp;
	for(ii = 0; ii < args_for_call; ++ii) {
	  VPOP(temp, stack, stack_top);
	}

	if(is_primitive_exception(top)) {
	  object *temp = top;
	  VM_ERROR_RESTART(CDR(temp));
	}

	VPUSH(top, stack, stack_top);

	RETURN_OPCODE_INSTRUCTIONS;
      }
      else {
	owrite(stderr, top);
	fprintf(stderr, "\n");
	VM_ASSERT(0, "don't know how to invoke");
      }

      NEXT_INSTRUCTION;

 __lvar__:
      env_num = ARG1;
      idx = ARG2;

      next = env;
      while(env_num-- > 0) {
	next = CDR(next);
      }

      data = VARRAY(CAR(next))[idx];
      VPUSH(data, stack, stack_top);

      NEXT_INSTRUCTION;

 __lset__:
      env_num = ARG1;
      idx = ARG2;

      next = env;
      while(env_num-- > 0) {
	next = CDR(next);
      }

      VARRAY(CAR(next))[idx] = VARRAY(stack)[stack_top - 1];

      NEXT_INSTRUCTION;

 __gvar__:
      var = VARRAY(const_array)[ARG1];

      /* see if we can get it from cache */
      if(is_pair(var)) {
	val = var;
      }
      else {
	val = lookup_global_value(VARRAY(const_array)[ARG1], genv);
	if(is_primitive_exception(val)) {
	  VM_ERROR_RESTART(CDR(val));
	}
	VARRAY(const_array)[ARG1] = val;
      }

      VPUSH(CDR(val), stack, stack_top);

      NEXT_INSTRUCTION;

 __gset__:
      var = VARRAY(const_array)[ARG1];
      val = VARRAY(stack)[stack_top - 1];
      slot = get_hashtab(genv, var, NULL);
      if(slot) {
	CDR(slot) = val;
      }
      else {
	val = cons(var, val);
	define_global_variable(var, val, genv);
      }

      NEXT_INSTRUCTION;

 __setcc__:

      VPOP(top, stack, stack_top);
      VPOP(new_stack_top, stack, stack_top);

      /* need to copy the stack into the current stack */
      stack_top = LONG(new_stack_top);

      stack = make_vector(g->empty_list, stack_top);

      for(idx = 0; idx < stack_top; ++idx) {
	VARRAY(stack)[idx] = VARRAY(top)[idx];
      }

      NEXT_INSTRUCTION;

 __cc__:
      cc_env = make_vector(g->empty_list, 2);
      push_root(&cc_env);

      /* copy the stack */
      new_stack = make_vector(g->empty_list, stack_top);

      for(idx = 0; idx < stack_top; ++idx) {
	VARRAY(new_stack)[idx] = VARRAY(stack)[idx];
      }

      /* insert it into the environment */
      VARRAY(cc_env)[0] = new_stack;
      VARRAY(cc_env)[1] = make_fixnum(stack_top);

      cc_env = cons(cc_env, g->empty_list);

      cc_fn = make_compiled_proc(g->cc_bytecode, cc_env);
      pop_root(&cc_env);

      VPUSH(cc_fn, stack, stack_top);

      NEXT_INSTRUCTION;

 __pop__:
      VPOP(top, stack, stack_top);

      NEXT_INSTRUCTION;

 __cons__:
      VARRAY(stack)[stack_top - 2] =
	cons(VARRAY(stack)[stack_top - 2],
	     VARRAY(stack)[stack_top - 1]);
      stack_top = stack_top - 1;

      NEXT_INSTRUCTION;

 __car__:
      top = VARRAY(stack)[stack_top - 1];
      VM_ASSERT(is_pair(top) || is_the_empty_list(top), "car expects pair");
      VARRAY(stack)[stack_top - 1] = CAR(top);

      NEXT_INSTRUCTION;

 __cdr__:
      top = VARRAY(stack)[stack_top - 1];
      VM_ASSERT(is_pair(top) || is_the_empty_list(top), "cdr expects pair");
      VARRAY(stack)[stack_top - 1] = CDR(top);

      NEXT_INSTRUCTION;

 __setcar__:
      top = VARRAY(stack)[stack_top - 2];
      VM_ASSERT(is_pair(top), "set-car! expects pair");
      CAR(top) = VARRAY(stack)[stack_top - 1];
      VARRAY(stack)[stack_top - 2] = VARRAY(stack)[stack_top - 1];
      stack_top = stack_top - 1;

      NEXT_INSTRUCTION;

 __setcdr__:
      top = VARRAY(stack)[stack_top - 2];
      VM_ASSERT(is_pair(top), "set-cdr! expects pair");
      CDR(top) = VARRAY(stack)[stack_top - 1];
      VARRAY(stack)[stack_top - 2] = VARRAY(stack)[stack_top - 1];
      stack_top = stack_top - 1;

      NEXT_INSTRUCTION;

 __save__:
      VPUSH(env, stack, stack_top);
      VPUSH(fn, stack, stack_top);
      VPUSH(make_small_fixnum(ARG1 * 2), stack, stack_top);
      VPUSH(make_small_fixnum(fn_first_arg), stack, stack_top);

      NEXT_INSTRUCTION;

 __return__:
      RETURN_OPCODE_INSTRUCTIONS;

      NEXT_INSTRUCTION;

 __cconst__:
      idx = ARG1;
      VPUSH(VARRAY(const_array)[idx], stack, stack_top);

      NEXT_INSTRUCTION;

  VM_RETURN(g->error_sym);
}

DEFUN1(vm_tag_macro_proc) {
  FIRST->type = COMPILED_SYNTAX_PROC;
  return FIRST;
}


DEFUN1(set_cc_bytecode) {
  g->cc_bytecode = BYTECODE(FIRST);
  return FIRST;
}

DEFUN1(set_error_restart_proc) {
  g->vm_error_restart = FIRST;
  return FIRST;
}

#define generate_syminit(opcode) opcode ## _op = make_symbol("" # opcode);

void vm_definer(char *sym, object * value) {
  object *symbol = make_symbol(sym);
  object *slot = get_hashtab(g->vm_env, symbol, NULL);

  if(slot) {
    set_cdr(slot, value);
  }
  else {
    push_root(&value);
    value = cons(symbol, value);
    define_global_variable(symbol, value, g->vm_env);
    pop_root(&value);
  }
}

void vm_boot(void) {
  /* generate the symbol initializations */
  opcode_table(generate_syminit)

  /* ask the vm to generate the jump table */
  build_dispatch_table = 1;
  vm_execute(NULL, NULL, 0, 0, NULL);

  /* register for sigint */
  struct sigaction sa;
  sa.sa_handler = vm_sigint_handler;
  sigaction(SIGINT, &sa, NULL);
}

void vm_add_roots(void) {
  push_root(&(g->cc_bytecode));
  push_root(&(g->vm_error_restart));
}

void vm_init(void) {
  vm_boot();

  vm_definer("set-macro!", make_primitive_proc(vm_tag_macro_proc));

  vm_definer("set-cc-bytecode!", make_primitive_proc(set_cc_bytecode));

  vm_definer("set-error-restart!",
	     make_primitive_proc(set_error_restart_proc));

  g->cc_bytecode = g->empty_list;
  push_root(&(g->cc_bytecode));

  g->vm_error_restart = g->empty_list;
  push_root(&(g->vm_error_restart));
}

void vm_init_environment(definer defn) {

  defn("symbol->bytecode", make_primitive_proc(symbol_to_code_proc));

  defn("bytecode->symbol", make_primitive_proc(code_to_symbol_proc));

  defn("make-bytecode-array", make_primitive_proc(make_bytecode_array_proc));

  defn("bytecode-ref", make_primitive_proc(get_bytecode_proc));

  defn("bytecode-set!", make_primitive_proc(set_bytecode_proc));

  defn("bytecode-operands-ref", make_primitive_proc(get_bytecode_operands_proc));

  defn("bytecode-operands-set!", make_primitive_proc(set_bytecode_operands_proc));
}

void wb(object * fn) {
  long idx = 0;
  object *code_array = car(BYTECODE(fn));
  object *arg_vector = cadr(BYTECODE(fn));

  long size = VSIZE(arg_vector);
  char *codes = ALIEN_PTR(code_array);
  object **args = VARRAY(arg_vector);

  fprintf(stderr, "#<bytecode: ");
  for(idx = 0; idx < size; ++idx) {
    int code = (int)codes[idx];
    fprintf(stderr, "(%s . ", bytecode_str[code]);
    owrite(stderr, args[idx]);
    fprintf(stderr, ") ");
  }
  fprintf(stderr, ">\n");
}