593 lines
21 KiB
C
593 lines
21 KiB
C
#define _XOPEN_SOURCE 500
|
|
#define _REENTRANT 1
|
|
#define _SVID_SOURCE 1
|
|
|
|
/* Required for lgamma_r on Solaris */
|
|
#define __EXTENSIONS__ 1
|
|
|
|
#include <inttypes.h>
|
|
#include <math.h>
|
|
#include <stdbool.h>
|
|
#include <stdlib.h>
|
|
#include <string.h>
|
|
#include <stdio.h>
|
|
|
|
#include "gc.h"
|
|
#include "builtin.h"
|
|
#include "interp.h"
|
|
|
|
/* Shorthand for frequently-used fields */
|
|
#define _LAMBDA_SLOT(v,s) _SLOT_VALUE(LAMBDA, v, s)
|
|
#define ST1 (state->in1.value)
|
|
#define ST2 (state->in2.value)
|
|
#define ST3 (state->in3.value)
|
|
|
|
/* 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 value_t vector_ref(value_t v, fixnum_t idx);
|
|
static char byte_string_ref(value_t v, fixnum_t idx);
|
|
static value_t struct_ref(value_t v, fixnum_t idx);
|
|
|
|
static void vector_set(value_t v, fixnum_t idx, value_t newval);
|
|
static void byte_string_set(value_t v, fixnum_t idx, char newval);
|
|
static void struct_set(value_t v, fixnum_t idx, value_t newval);
|
|
|
|
static value_t make_lambda(interp_state_t *state, value_t templ);
|
|
|
|
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 eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2);
|
|
static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uint8_t in);
|
|
|
|
static void run_statement(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2, uint32_t in3);
|
|
|
|
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 attempts to tail-call FALSE_VALUE, the original 'k', indicating completion. */
|
|
while (state.lambda.value != FALSE_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 (or builtin).
|
|
*/
|
|
|
|
#if 0
|
|
fflush(stdout);
|
|
fputs("LAMBDA: ", stderr); fprint_value(stderr, state.lambda.value); fputc('\n', stderr);
|
|
fputs("ARGLIST: ", stderr); fprint_value(stderr, state.argv.value); fputc('\n', stderr);
|
|
fputs("CONTEXT: ", stderr); fprint_value(stderr, state.ctx.value); fputc('\n', stderr);
|
|
fputs("CONT'N: ", stderr); fprint_value(stderr, state.k.value); fputc('\n', stderr);
|
|
fputc('\n', stderr);
|
|
fflush(stderr);
|
|
#endif
|
|
|
|
if (is_builtin_fn(state.lambda.value))
|
|
{
|
|
/* Builtin functions replace the byte-code and tail-call
|
|
* steps; they also do not require frame variables. */
|
|
state.nframe = 0;
|
|
_get_builtin_fn(state.lambda.value)(&state);
|
|
}
|
|
else
|
|
{
|
|
state.nframe = get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS));
|
|
release_assert((0 <= state.nframe) && (state.nframe <= 120));
|
|
|
|
run_byte_code(&state);
|
|
perform_tail_call(&state);
|
|
}
|
|
|
|
/* Clear (used) frame-variable slots so they can be GC'd. */
|
|
for (fixnum_t i = 0; i < state.nframe; ++i)
|
|
_get_vector(state.frame.value)->elements[i] = UNDEFINED;
|
|
|
|
/* Clear temporaries. */
|
|
state.in1.value = UNDEFINED;
|
|
state.in2.value = UNDEFINED;
|
|
state.in3.value = UNDEFINED;
|
|
|
|
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 continuation are the final return value. */
|
|
return state.argv.value;
|
|
}
|
|
|
|
static value_t vector_ref(value_t v, fixnum_t idx)
|
|
{
|
|
vector_t *vec = get_vector(v);
|
|
release_assert((idx >= 0) && (idx < vec->size));
|
|
return vec->elements[idx];
|
|
}
|
|
|
|
static char byte_string_ref(value_t v, fixnum_t idx)
|
|
{
|
|
byte_string_t *str = get_byte_string(v);
|
|
release_assert((idx >= 0) && (idx < str->size));
|
|
return str->bytes[idx];
|
|
}
|
|
|
|
static value_t struct_ref(value_t v, fixnum_t idx)
|
|
{
|
|
struct_t *s = get_struct(v);
|
|
release_assert((idx >= 0) && (idx < s->nslots));
|
|
return s->slots[idx];
|
|
}
|
|
|
|
static void vector_set(value_t v, fixnum_t idx, value_t newval)
|
|
{
|
|
vector_t *vec = get_vector(v);
|
|
release_assert((idx >= 0) && (idx < vec->size));
|
|
vec->elements[idx] = newval;
|
|
WRITE_BARRIER(v);
|
|
}
|
|
|
|
static void byte_string_set(value_t v, fixnum_t idx, char newval)
|
|
{
|
|
byte_string_t *str = get_byte_string(v);
|
|
release_assert((idx >= 0) && (idx < str->size));
|
|
str->bytes[idx] = newval;
|
|
}
|
|
|
|
static void struct_set(value_t v, fixnum_t idx, value_t newval)
|
|
{
|
|
struct_t *s = get_struct(v);
|
|
|
|
release_assert(struct_is_a(s->type, structure_type_root.value));
|
|
release_assert(_get_boolean(_SLOT_VALUE(STRUCTURE, s->type, MUTABLE)));
|
|
release_assert((idx >= 0) && (idx < s->nslots));
|
|
|
|
s->slots[idx] = newval;
|
|
WRITE_BARRIER(v);
|
|
}
|
|
|
|
static value_t make_lambda(interp_state_t *state, value_t templ)
|
|
{
|
|
gc_root_t templ_root, lambda_root;
|
|
struct_t *ls;
|
|
struct_t *ts;
|
|
vector_t *l_inst;
|
|
byte_string_t *t_inst;
|
|
value_t temp;
|
|
|
|
/* If it's not a template object, just return as-is. */
|
|
if (!struct_is_a(templ, template_type_root.value))
|
|
return templ;
|
|
|
|
register_gc_root(&templ_root, templ);
|
|
register_gc_root(&lambda_root, make_struct(lambda_type_root.value, LAMBDA_SLOTS));
|
|
|
|
/* Need to do this first, since it can call the garbage collector. */
|
|
temp = make_vector(get_byte_string(get_struct(templ_root.value)
|
|
->slots[TEMPLATE_SLOT_INSTANCE_VARS])->size,
|
|
UNDEFINED);
|
|
_LAMBDA_SLOT(lambda_root.value, INSTANCE_VARS) = temp;
|
|
WRITE_BARRIER(lambda_root.value);
|
|
|
|
ls = _get_struct(lambda_root.value);
|
|
ts = _get_struct(templ_root.value);
|
|
|
|
/* All but the instance variables are just shallow-copied. */
|
|
ls->slots[LAMBDA_SLOT_GLOBAL_VARS] = ts->slots[TEMPLATE_SLOT_GLOBAL_VARS];
|
|
ls->slots[LAMBDA_SLOT_FRAME_VARS] = ts->slots[TEMPLATE_SLOT_FRAME_VARS];
|
|
ls->slots[LAMBDA_SLOT_BYTE_CODE] = ts->slots[TEMPLATE_SLOT_BYTE_CODE];
|
|
ls->slots[LAMBDA_SLOT_TAIL_CALL] = ts->slots[TEMPLATE_SLOT_TAIL_CALL];
|
|
ls->slots[LAMBDA_SLOT_ARG_LIST] = ts->slots[TEMPLATE_SLOT_ARG_LIST];
|
|
ls->slots[LAMBDA_SLOT_CONTINUATION] = ts->slots[TEMPLATE_SLOT_CONTINUATION];
|
|
ls->slots[LAMBDA_SLOT_CONTEXT] = ts->slots[TEMPLATE_SLOT_CONTEXT];
|
|
WRITE_BARRIER(lambda_root.value);
|
|
|
|
l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]);
|
|
t_inst = get_byte_string(ts->slots[TEMPLATE_SLOT_INSTANCE_VARS]);
|
|
|
|
for (size_t i = 0; i < t_inst->size; ++i)
|
|
{
|
|
l_inst->elements[i] = get_input(state, t_inst->bytes[i]);
|
|
}
|
|
WRITE_BARRIER(object_value(l_inst));
|
|
|
|
unregister_gc_root(&templ_root);
|
|
unregister_gc_root(&lambda_root);
|
|
|
|
return lambda_root.value;
|
|
}
|
|
|
|
static void translate_callable(interp_state_t *state)
|
|
{
|
|
while (!is_builtin_fn(state->lambda.value) &&
|
|
!struct_is_a(state->lambda.value, lambda_type_root.value))
|
|
{
|
|
/* If it's not a lambda, built-in function, or typed structure, then
|
|
* it's not callable and I have no idea what to do with it. */
|
|
release_assert(struct_is_a(get_struct(state->lambda.value)->type, structure_type_root.value));
|
|
|
|
/* 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)
|
|
{
|
|
gc_root_t bc_root;
|
|
|
|
register_gc_root(&bc_root, _LAMBDA_SLOT(state->lambda.value, BYTE_CODE));
|
|
|
|
for (size_t offset = 0; (offset+3) < _get_byte_string(bc_root.value)->size; offset += 4)
|
|
{
|
|
uint8_t bytes[4];
|
|
|
|
memcpy(bytes, _get_byte_string(bc_root.value)->bytes + offset, 4);
|
|
|
|
switch (bytes[0])
|
|
{
|
|
bool cond;
|
|
case 0x00 ... 0x3f: /* expression */
|
|
set_output(state, bytes[1], eval_expression(state, bytes[0], bytes[2], bytes[3]));
|
|
break;
|
|
case 0x40 ... 0x41: /* goto-end-if, goto-end-unless */
|
|
cond = _get_boolean(get_input(state, bytes[1]));
|
|
if ((bytes[0] & 1) ? !cond : cond)
|
|
{
|
|
goto break_for_loop;
|
|
}
|
|
break;
|
|
case 0x42 ... 0x7f: /* statement */
|
|
run_statement(state, bytes[0], bytes[1], bytes[2], bytes[3]);
|
|
break;
|
|
case 0x80 ... 0xff: /* conditional */
|
|
set_output(state, bytes[0],
|
|
get_input(state, _get_boolean(get_input(state, bytes[1]))
|
|
? bytes[2] : bytes[3]));
|
|
break;
|
|
}
|
|
}
|
|
break_for_loop:
|
|
|
|
unregister_gc_root(&bc_root);
|
|
}
|
|
|
|
static void perform_tail_call(interp_state_t *state)
|
|
{
|
|
gc_root_t new_lambda, new_argv, new_ctx, new_k;
|
|
|
|
register_gc_root(&new_lambda, get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, TAIL_CALL))));
|
|
register_gc_root(&new_argv, get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, ARG_LIST))));
|
|
register_gc_root(&new_ctx, get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, CONTEXT))));
|
|
register_gc_root(&new_k, get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, CONTINUATION))));
|
|
|
|
/* If new lambda or continuation is a template, instantiate it here */
|
|
new_lambda.value = make_lambda(state, new_lambda.value);
|
|
new_k.value = make_lambda(state, new_k.value);
|
|
|
|
/* Transfer control to new function */
|
|
state->lambda.value = new_lambda.value;
|
|
state->argv.value = new_argv.value;
|
|
state->ctx.value = new_ctx.value;
|
|
state->k.value = new_k.value;
|
|
|
|
unregister_gc_root(&new_lambda);
|
|
unregister_gc_root(&new_argv);
|
|
unregister_gc_root(&new_ctx);
|
|
unregister_gc_root(&new_k);
|
|
}
|
|
|
|
static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2)
|
|
{
|
|
if (code != 0x00)
|
|
{
|
|
ST1 = get_input(state, in1);
|
|
ST2 = get_input(state, in2);
|
|
}
|
|
|
|
switch (code)
|
|
{
|
|
case 0x00: return eval_unary_expression(state, in1, in2);
|
|
case 0x01: return boolean_value(ST1 == ST2);
|
|
case 0x02: return cons(ST1, ST2);
|
|
case 0x03: return make_vector(get_fixnum(ST1), ST2);
|
|
case 0x04: return make_byte_string(get_fixnum(ST1), (char)get_fixnum(ST2));
|
|
case 0x05: return vector_ref(ST1, get_fixnum(ST2));
|
|
case 0x06: return fixnum_value(byte_string_ref(ST1, get_fixnum(ST2)));
|
|
case 0x07: return struct_ref(ST1, get_fixnum(ST2));
|
|
case 0x08: return fixnum_value(get_fixnum(ST1) + get_fixnum(ST2));
|
|
case 0x09: return fixnum_value(get_fixnum(ST1) - get_fixnum(ST2));
|
|
case 0x0a: return fixnum_value(get_fixnum(ST1) * get_fixnum(ST2));
|
|
case 0x0b: return fixnum_value(get_fixnum(ST1) / get_fixnum(ST2));
|
|
case 0x0c: return fixnum_value(get_fixnum(ST1) % get_fixnum(ST2));
|
|
case 0x0d: return boolean_value(get_fixnum(ST1) < get_fixnum(ST2));
|
|
case 0x0e: return boolean_value(get_fixnum(ST1) >= get_fixnum(ST2));
|
|
case 0x10: return fixnum_value(get_fixnum(ST1) & get_fixnum(ST2));
|
|
case 0x11: return fixnum_value(get_fixnum(ST1) | get_fixnum(ST2));
|
|
case 0x12: return fixnum_value(get_fixnum(ST1) ^ get_fixnum(ST2));
|
|
case 0x14: return fixnum_value(get_fixnum(ST1) << get_fixnum(ST2));
|
|
case 0x15: return fixnum_value(get_fixnum(ST1) >> get_fixnum(ST2));
|
|
case 0x16: return fixnum_value((unsigned long)get_fixnum(ST1) >> get_fixnum(ST2));
|
|
case 0x18: return make_float(get_float(ST1) + get_float(ST2));
|
|
case 0x19: return make_float(get_float(ST1) - get_float(ST2));
|
|
case 0x1a: return make_float(get_float(ST1) * get_float(ST2));
|
|
case 0x1b: return make_float(get_float(ST1) / get_float(ST2));
|
|
case 0x1c: return boolean_value(get_float(ST1) == get_float(ST2));
|
|
case 0x1d: return boolean_value(get_float(ST1) < get_float(ST2));
|
|
case 0x1e: return boolean_value(get_float(ST1) >= get_float(ST2));
|
|
case 0x20: return make_float(atan2(get_float(ST1), get_float(ST2)));
|
|
case 0x21: return make_float(pow(get_float(ST1), get_float(ST2)));
|
|
case 0x22: return make_float(ldexp(get_float(ST1), get_fixnum(ST2)));
|
|
case 0x23: return make_float(fmod(get_float(ST1), get_float(ST2)));
|
|
case 0x24: return make_float(hypot(get_float(ST1), get_float(ST2)));
|
|
case 0x25: return make_float(jn(get_fixnum(ST1), get_float(ST2)));
|
|
case 0x26: return make_float(yn(get_fixnum(ST1), get_float(ST2)));
|
|
case 0x27: return make_float(nextafter(get_float(ST1), get_float(ST2)));
|
|
case 0x28: return make_float(remainder(get_float(ST1), get_float(ST2)));
|
|
case 0x29: return make_float(scalb(get_float(ST1), get_float(ST2)));
|
|
case 0x30: return boolean_value(struct_is_a(ST1, ST2));
|
|
default: release_assert(NOTREACHED("Invalid byte-code!"));
|
|
}
|
|
|
|
return UNDEFINED;
|
|
}
|
|
|
|
static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uint8_t in)
|
|
{
|
|
release_assert(subcode != 0);
|
|
ST1 = get_input(state, in);
|
|
|
|
switch (subcode)
|
|
{
|
|
case 0x01: return ST1;
|
|
case 0x02: return get_box(ST1)->value;
|
|
case 0x03: return get_pair(ST1)->car;
|
|
case 0x04: return get_pair(ST1)->cdr;
|
|
case 0x08: return boolean_value(is_boolean(ST1));
|
|
case 0x09: return boolean_value(is_fixnum(ST1));
|
|
case 0x0a: return boolean_value(is_box(ST1));
|
|
case 0x0b: return boolean_value(is_pair(ST1));
|
|
case 0x0c: return boolean_value(is_vector(ST1));
|
|
case 0x0d: return boolean_value(is_byte_string(ST1));
|
|
case 0x0e: return boolean_value(is_struct(ST1));
|
|
case 0x0f: return boolean_value(is_float(ST1));
|
|
case 0x10: return boolean_value(is_builtin_fn(ST1));
|
|
case 0x18: return make_box(ST1);
|
|
case 0x19: {
|
|
vector_t *vec;
|
|
release_assert(struct_is_a(ST1, structure_type_root.value));
|
|
vec = get_vector(_SLOT_VALUE(STRUCTURE, ST1, SLOTS));
|
|
return make_struct(ST1, vec->size);
|
|
}
|
|
case 0x1a: return make_float((native_float_t)get_fixnum(ST1));
|
|
case 0x1b: return make_lambda(state, ST1);
|
|
case 0x20: return boolean_value(!_get_boolean(ST1));
|
|
case 0x21: return fixnum_value(~get_fixnum(ST1));
|
|
case 0x22: return fixnum_value(-get_fixnum(ST1));
|
|
case 0x23: return make_float(-get_float(ST1));
|
|
case 0x28: return fixnum_value(get_vector(ST1)->size);
|
|
case 0x29: return fixnum_value(get_byte_string(ST1)->size);
|
|
case 0x2a: return fixnum_value(get_struct(ST1)->nslots);
|
|
case 0x2b: return get_struct(ST1)->type;
|
|
case 0x30: return make_float(acos(get_float(ST1)));
|
|
case 0x31: return make_float(asin(get_float(ST1)));
|
|
case 0x32: return make_float(atan(get_float(ST1)));
|
|
case 0x33: return make_float(cos(get_float(ST1)));
|
|
case 0x34: return make_float(sin(get_float(ST1)));
|
|
case 0x35: return make_float(tan(get_float(ST1)));
|
|
case 0x36: return make_float(cosh(get_float(ST1)));
|
|
case 0x37: return make_float(sinh(get_float(ST1)));
|
|
case 0x38: return make_float(tanh(get_float(ST1)));
|
|
case 0x39: return make_float(exp(get_float(ST1)));
|
|
case 0x3a: {
|
|
int exp;
|
|
ST2 = make_float(frexp(get_float(ST1), &exp));
|
|
return cons(ST2, fixnum_value(exp));
|
|
}
|
|
case 0x3b: return make_float(log(get_float(ST1)));
|
|
case 0x3c: return make_float(log10(get_float(ST1)));
|
|
case 0x3d: {
|
|
double integral_part;
|
|
ST2 = make_float(modf(get_float(ST1), &integral_part));
|
|
ST3 = make_float(integral_part);
|
|
return cons(ST2, ST3);
|
|
}
|
|
case 0x3e: return make_float(sqrt(get_float(ST1)));
|
|
case 0x3f: return make_float(ceil(get_float(ST1)));
|
|
case 0x40: return make_float(fabs(get_float(ST1)));
|
|
case 0x41: return make_float(floor(get_float(ST1)));
|
|
case 0x50: return make_float(erf(get_float(ST1)));
|
|
case 0x51: return make_float(erfc(get_float(ST1)));
|
|
case 0x52: return make_float(j0(get_float(ST1)));
|
|
case 0x53: return make_float(j1(get_float(ST1)));
|
|
case 0x54: {
|
|
int signgamp;
|
|
ST2 = make_float(lgamma_r(get_float(ST1), &signgamp));
|
|
return cons(ST2, fixnum_value(signgamp));
|
|
}
|
|
case 0x55: return make_float(y0(get_float(ST1)));
|
|
case 0x56: return make_float(y1(get_float(ST1)));
|
|
case 0x57: return make_float(asinh(get_float(ST1)));
|
|
case 0x58: return make_float(acosh(get_float(ST1)));
|
|
case 0x59: return make_float(atanh(get_float(ST1)));
|
|
case 0x5a: return make_float(cbrt(get_float(ST1)));
|
|
case 0x5b: return make_float(logb(get_float(ST1)));
|
|
case 0x5c: return make_float(expm1(get_float(ST1)));
|
|
case 0x5d: return make_float(ilogb(get_float(ST1)));
|
|
case 0x5e: return make_float(log1p(get_float(ST1)));
|
|
case 0x70: return boolean_value(isnormal(get_float(ST1)));
|
|
case 0x71: return boolean_value(isfinite(get_float(ST1)));
|
|
case 0x72: return boolean_value(fpclassify(get_float(ST1)) == FP_SUBNORMAL);
|
|
case 0x73: return boolean_value(isinf(get_float(ST1)));
|
|
case 0x74: return boolean_value(isnan(get_float(ST1)));
|
|
default: release_assert(NOTREACHED("Invalid unary sub-bytecode."));
|
|
}
|
|
|
|
return UNDEFINED;
|
|
}
|
|
|
|
static void run_statement(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2, uint32_t in3)
|
|
{
|
|
ST1 = get_input(state, in1);
|
|
|
|
if (code >= 0x50)
|
|
{
|
|
ST2 = get_input(state, in2);
|
|
}
|
|
|
|
if (code >= 0x60)
|
|
{
|
|
ST3 = get_input(state, in3);
|
|
}
|
|
|
|
switch (code)
|
|
{
|
|
/* 0x40 and 0x41 (goto-end-if, goto-end-unless) are handled by run_byte_code() directly. */
|
|
case 0x50: get_box(ST1)->value = ST2; WRITE_BARRIER(ST1); break;
|
|
case 0x51: get_pair(ST1)->car = ST2; WRITE_BARRIER(ST1); break;
|
|
case 0x52: get_pair(ST1)->cdr = ST2; WRITE_BARRIER(ST1); break;
|
|
case 0x60: vector_set(ST1, get_fixnum(ST2), ST3); break;
|
|
case 0x61: byte_string_set(ST1, get_fixnum(ST2), (char)get_fixnum(ST3)); break;
|
|
case 0x62: struct_set(ST1, get_fixnum(ST2), ST3); break;
|
|
default: release_assert(NOTREACHED("Invalid statement bytecode."));
|
|
}
|
|
}
|
|
|
|
/*
|
|
* IMPORTANT: It is assumed that get_input() does not trigger garbage collection.
|
|
* If this were to change additional write barriers and/or GC roots may be required.
|
|
*/
|
|
static value_t get_input(const interp_state_t *state, fixnum_t var)
|
|
{
|
|
release_assert((var >= 0) && (var <= 255));
|
|
|
|
switch (var)
|
|
{
|
|
case 0:
|
|
return NIL;
|
|
case 1 ... 63:
|
|
{
|
|
vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, GLOBAL_VARS));
|
|
var -= 1;
|
|
|
|
release_assert(var < vec->size);
|
|
return vec->elements[var];
|
|
}
|
|
case 64 ... 127:
|
|
{
|
|
vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, INSTANCE_VARS));
|
|
var -= 64;
|
|
|
|
release_assert(var < vec->size);
|
|
return vec->elements[var];
|
|
}
|
|
case 128 ... 247:
|
|
{
|
|
/* Frame is allocated by interpreter, so we know it's a vector already. */
|
|
vector_t *vec = _get_vector(state->frame.value);
|
|
var -= 128;
|
|
|
|
release_assert(var < state->nframe);
|
|
return vec->elements[var];
|
|
}
|
|
/* 248 ... 251 are reserved */
|
|
case 252:
|
|
return state->lambda.value;
|
|
case 253:
|
|
return state->argv.value;
|
|
case 254:
|
|
return state->ctx.value;
|
|
case 255:
|
|
return state->k.value;
|
|
default:
|
|
return UNDEFINED;
|
|
}
|
|
}
|
|
|
|
static void set_output(const interp_state_t *state, fixnum_t var, value_t val)
|
|
{
|
|
vector_t *vec = _get_vector(state->frame.value);
|
|
|
|
/* Only frame variables can be output targets for bytecode instructions. */
|
|
release_assert((var >= 128) && (var <= 255));
|
|
|
|
var -= 128;
|
|
release_assert(var < state->nframe);
|
|
vec->elements[var] = val;
|
|
WRITE_BARRIER(state->frame.value);
|
|
}
|
|
|
|
static void register_state(interp_state_t *state, value_t lambda, value_t argv)
|
|
{
|
|
register_gc_root(&state->lambda, lambda);
|
|
register_gc_root(&state->argv, argv);
|
|
register_gc_root(&state->frame, make_vector(120, UNDEFINED));
|
|
register_gc_root(&state->ctx, FALSE_VALUE);
|
|
register_gc_root(&state->k, FALSE_VALUE);
|
|
register_gc_root(&state->in1, FALSE_VALUE);
|
|
register_gc_root(&state->in2, FALSE_VALUE);
|
|
register_gc_root(&state->in3, FALSE_VALUE);
|
|
}
|
|
|
|
static void unregister_state(interp_state_t *state)
|
|
{
|
|
unregister_gc_root(&state->lambda);
|
|
unregister_gc_root(&state->argv);
|
|
unregister_gc_root(&state->frame);
|
|
unregister_gc_root(&state->ctx);
|
|
unregister_gc_root(&state->k);
|
|
unregister_gc_root(&state->in1);
|
|
unregister_gc_root(&state->in2);
|
|
unregister_gc_root(&state->in3);
|
|
}
|
|
|
|
/* vim:set sw=2 expandtab: */
|