nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
rosella/interp.c

669 lines
22 KiB
C
Raw Blame History

#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)
/*
* Local helper routines
*/
static value_t vector_ref(value_t v, fixnum_t idx);
static uint8_t 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 int byte_string_cmp(value_t s1, value_t s2);
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 get_input(const interp_state_t *state, fixnum_t in);
static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2, uint8_t in3);
static value_t eval_binary_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 code, uint8_t in);
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)
{
}
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 we reach END_PROGRAM, "called" by "exit" builtin. */
while (state.lambda.value != END_PROGRAM)
{
state.ntransients = 0;
#if 0
fflush(stdout);
fputc('\n', stderr);
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);
fflush(stderr);
#endif
/* '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 (is_builtin_fn(state.lambda.value))
{
/* Builtin functions replace the byte-code and tail-call steps. */
_get_builtin_fn(state.lambda.value)(&state);
}
else
{
release_assert(get_struct(state.lambda.value)->immutable);
state.globals.value = _LAMBDA_SLOT(state.lambda.value, GLOBAL_VARS);
state.instances.value = _LAMBDA_SLOT(state.lambda.value, INSTANCE_VARS);
state.byte_code.value = _LAMBDA_SLOT(state.lambda.value, BYTE_CODE);
state.tail_call.value = _LAMBDA_SLOT(state.lambda.value, TAIL_CALL);
release_assert(get_vector(state.globals.value)->immutable);
release_assert(get_vector(state.instances.value)->immutable);
release_assert((state.byte_code.value == FALSE_VALUE) ||
get_byte_string(state.byte_code.value)->immutable);
release_assert(get_byte_string(state.tail_call.value)->immutable);
run_byte_code(&state);
perform_tail_call(&state);
}
/* Clear (used) transient slots so they can be GC'd. */
for (int i = 0; i < state.ntransients; ++i)
_get_vector(state.transients.value)->elements[i] = UNDEFINED;
/* Clear temporaries. */
state.globals.value = UNDEFINED;
state.instances.value = UNDEFINED;
state.byte_code.value = UNDEFINED;
state.tail_call.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);
/* Note that recursion is limited to a single level by the static variable. */
run_finalizers = false;
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);
if (!((idx >= 0) && (idx < vec->size)))
fprintf(stderr, "idx=%d, vec->size=%d\n", (int)idx, (int)vec->size);
release_assert((idx >= 0) && (idx < vec->size));
return vec->elements[idx];
}
static uint8_t 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);
if (!((idx >= 0) && (idx < s->nslots)))
{
fprintf(stderr, "idx=%d; nslots=%d;\n",
(int)idx, (int)s->nslots);
fprint_value(stderr, v);
fputc('\n', stderr);
}
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(!vec->immutable);
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(!str->immutable);
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(!s->immutable);
release_assert((idx >= 0) && (idx < s->nslots));
s->slots[idx] = newval;
WRITE_BARRIER(v);
}
static int byte_string_cmp(value_t s1, value_t s2)
{
byte_string_t *str1 = get_byte_string(s1);
byte_string_t *str2 = get_byte_string(s2);
if (str1->size < str2->size) return -1;
else if (str1->size > str2->size) return 1;
else return memcmp(str1->bytes, str2->bytes, str1->size);
}
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, get_template_type()))
return templ;
register_gc_root(&templ_root, templ);
register_gc_root(&lambda_root, make_struct(get_lambda_type()));
/* 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_BYTE_CODE] = ts->slots[TEMPLATE_SLOT_BYTE_CODE];
ls->slots[LAMBDA_SLOT_TAIL_CALL] = ts->slots[TEMPLATE_SLOT_TAIL_CALL];
ls->immutable = true;
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]);
}
l_inst->immutable = true;
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, get_lambda_type()))
{
/* Prepend structure instance to argument list, per proxy protocol. */
state->argv.value = cons(state->lambda.value, state->argv.value);
/* Follow link to next callable. Must be a structure! */
state->lambda.value = _SLOT_VALUE(STRUCTURE, get_struct(state->lambda.value)->type, CALLABLE);
}
}
static void run_byte_code(interp_state_t *state)
{
if (state->byte_code.value != FALSE_VALUE)
{
uint8_t byte_code[4*128];
int nwords;
{
byte_string_t *s = get_byte_string(state->byte_code.value);
release_assert(s->immutable);
release_assert(s->size <= sizeof byte_code);
release_assert((s->size % 4) == 0);
/* Copy byte code to temporary buffer for faster access. */
nwords = s->size / 4;
memcpy(byte_code, s->bytes, s->size);
}
for (int word = 0; word < nwords; ++word)
{
const uint8_t *bytes = &byte_code[4 * word];
value_t result;
if (bytes[0] == 0x00 && bytes[1] == 0x70) /* (tail-call-if cond tail-call) */
{
/* Must handle this here, as it may end the loop. */
if (_get_boolean(get_input(state, bytes[2])))
{
value_t tc = get_input(state, bytes[3]);
if (tc != FALSE_VALUE) state->tail_call.value = tc;
nwords = word + 1;
}
result = UNDEFINED;
}
else
{
result = eval_expression(state, bytes[0], bytes[1], bytes[2], bytes[3]);
}
#if 0
fflush(stdout);
fprintf(stderr, "t%02d: (%02d) \\x%02x\\x%02x\\x%02x\\x%02x => ",
state->ntransients, word, bytes[0], bytes[1], bytes[2], bytes[3]);
fprint_value(stderr, result);
fputc('\n', stderr);
fflush(stderr);
#endif
_get_vector(state->transients.value)->elements[state->ntransients++] = result;
WRITE_BARRIER(state->transients.value);
}
}
}
static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2, uint8_t in3)
{
if (code == 0x00)
{
return eval_binary_expression(state, in1, in2, in3);
}
else if (code == 0xff)
{
/* vector-ref-immed; in1 is vector, in2:in3 is index */
value_t v1 = get_input(state, in1);
return vector_ref(v1, ((uint16_t)in2 << 8) | in3);
}
else
{
value_t v1 = get_input(state, in1);
value_t v2 = get_input(state, in2);
value_t v3 = get_input(state, in3);
switch (code)
{
case 0x10:
return _get_boolean(v1) ? v2 : v3;
case 0x20:
vector_set(v1, get_fixnum(v2), v3);
return UNDEFINED;
case 0x21:
byte_string_set(v1, get_fixnum(v2), (char)get_fixnum(v3));
return UNDEFINED;
case 0x22:
struct_set(v1, get_fixnum(v2), v3);
return UNDEFINED;
default:
release_assert(NOTREACHED("Invalid ternary byte-code!"));
return UNDEFINED;
}
}
}
static void perform_tail_call(interp_state_t *state)
{
uint8_t bytes[6];
gc_root_t root;
value_t new_lambda, new_argv, new_kw_args, new_kw_vals, new_ctx, new_k;
release_assert(get_byte_string(state->tail_call.value)->immutable);
release_assert(_get_byte_string(state->tail_call.value)->size == 6);
memcpy(bytes, _get_byte_string(state->tail_call.value)->bytes, 6);
register_gc_root(&root, make_lambda(state, get_input(state, bytes[0])));
new_k = make_lambda(state, get_input(state, bytes[5]));
new_lambda = root.value;
unregister_gc_root(&root);
new_argv = get_input(state, bytes[1]);
new_kw_args = get_input(state, bytes[2]);
new_kw_vals = get_input(state, bytes[3]);
new_ctx = get_input(state, bytes[4]);
/* Transfer control to new function; must be after last get_input() */
state->lambda.value = new_lambda;
state->argv.value = new_argv;
state->kw_args.value = new_kw_args;
state->kw_vals.value = new_kw_vals;
state->ctx.value = new_ctx;
state->k.value = new_k;
}
static value_t eval_binary_expression(interp_state_t *state, uint8_t code, uint8_t in1, uint8_t in2)
{
if (code == 0x00)
{
return eval_unary_expression(state, in1, in2);
}
else
{
value_t v1 = get_input(state, in1);
value_t v2 = get_input(state, in2);
switch (code)
{
case 0x01: return boolean_value(v1 == v2);
case 0x02: return cons(v1, v2);
case 0x03: return make_vector(get_fixnum(v1), v2);
case 0x04: return make_byte_string(get_fixnum(v1), (char)get_fixnum(v2));
case 0x05: return vector_ref(v1, get_fixnum(v2));
case 0x06: return fixnum_value(byte_string_ref(v1, get_fixnum(v2)));
case 0x07: return struct_ref(v1, get_fixnum(v2));
case 0x08: return fixnum_value(get_fixnum(v1) + get_fixnum(v2));
case 0x09: return fixnum_value(get_fixnum(v1) - get_fixnum(v2));
case 0x0a: return fixnum_value(get_fixnum(v1) * get_fixnum(v2));
case 0x0b: return fixnum_value(get_fixnum(v1) / get_fixnum(v2));
case 0x0c: return fixnum_value(get_fixnum(v1) % get_fixnum(v2));
case 0x0d: return boolean_value(get_fixnum(v1) < get_fixnum(v2));
case 0x0e: return boolean_value(get_fixnum(v1) >= get_fixnum(v2));
case 0x10: return fixnum_value(get_fixnum(v1) & get_fixnum(v2));
case 0x11: return fixnum_value(get_fixnum(v1) | get_fixnum(v2));
case 0x12: return fixnum_value(get_fixnum(v1) ^ get_fixnum(v2));
case 0x14: return fixnum_value(get_fixnum(v1) << get_fixnum(v2));
case 0x15: return fixnum_value(get_fixnum(v1) >> get_fixnum(v2));
case 0x16: return fixnum_value((unsigned long)get_fixnum(v1) >> get_fixnum(v2));
case 0x18: return make_float(get_float(v1) + get_float(v2));
case 0x19: return make_float(get_float(v1) - get_float(v2));
case 0x1a: return make_float(get_float(v1) * get_float(v2));
case 0x1b: return make_float(get_float(v1) / get_float(v2));
case 0x1c: return boolean_value(get_float(v1) == get_float(v2));
case 0x1d: return boolean_value(get_float(v1) < get_float(v2));
case 0x1e: return boolean_value(get_float(v1) >= get_float(v2));
case 0x20: return make_float(atan2(get_float(v1), get_float(v2)));
case 0x21: return make_float(pow(get_float(v1), get_float(v2)));
case 0x22: return make_float(ldexp(get_float(v1), get_fixnum(v2)));
case 0x23: return make_float(fmod(get_float(v1), get_float(v2)));
case 0x24: return make_float(hypot(get_float(v1), get_float(v2)));
case 0x25: return make_float(jn(get_fixnum(v1), get_float(v2)));
case 0x26: return make_float(yn(get_fixnum(v1), get_float(v2)));
case 0x27: return make_float(nextafter(get_float(v1), get_float(v2)));
case 0x28: return make_float(remainder(get_float(v1), get_float(v2)));
case 0x29: return make_float(scalb(get_float(v1), get_float(v2)));
case 0x30: return boolean_value(struct_is_a(v1, v2));
case 0x31: return boolean_value(byte_string_cmp(v1, v2) == 0);
case 0x32: return boolean_value(byte_string_cmp(v1, v2) < 0);
case 0x33: return boolean_value(byte_string_cmp(v1, v2) >= 0);
case 0x50:
get_box(v1)->value = v2;
WRITE_BARRIER(v1);
return UNDEFINED;
case 0x51:
get_pair(v1)->car = v2;
WRITE_BARRIER(v1);
return UNDEFINED;
case 0x52:
get_pair(v1)->cdr = v2;
WRITE_BARRIER(v1);
return UNDEFINED;
case 0xff:
if (_get_boolean(v1))
{
if (_get_boolean(v2))
{
fprint_value(stderr, v2);
fputc('\n', stderr);
}
release_assert(NOTREACHED("Fatal error detected."));
}
return UNDEFINED;
default:
release_assert(NOTREACHED("Invalid binary byte-code!"));
return UNDEFINED;
}
}
}
static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_t in)
{
value_t v1 = get_input(state, in);
switch (code)
{
case 0x01: return get_box(v1)->value;
case 0x02: return get_weak_box(v1)->value;
case 0x03: return get_pair(v1)->car;
case 0x04: return get_pair(v1)->cdr;
case 0x08: return boolean_value(is_boolean(v1));
case 0x09: return boolean_value(is_fixnum(v1));
case 0x0a: return boolean_value(is_box(v1));
case 0x0b: return boolean_value(is_pair(v1));
case 0x0c: return boolean_value(is_vector(v1));
case 0x0d: return boolean_value(is_byte_string(v1));
case 0x0e: return boolean_value(is_struct(v1));
case 0x0f: return boolean_value(is_float(v1));
case 0x10: return boolean_value(is_builtin_fn(v1));
case 0x11: return boolean_value(is_weak_box(v1));
case 0x18: return make_box(v1);
case 0x19: return make_struct(v1);
case 0x1a: return make_float((native_float_t)get_fixnum(v1));
case 0x1b: return make_lambda(state, v1);
case 0x1c: return make_weak_box(v1);
case 0x20: return boolean_value(!_get_boolean(v1));
case 0x21: return fixnum_value(~get_fixnum(v1));
case 0x22: return fixnum_value(-get_fixnum(v1));
case 0x23: return make_float(-get_float(v1));
case 0x28: return fixnum_value(get_vector(v1)->size);
case 0x29: return fixnum_value(get_byte_string(v1)->size);
case 0x2a: return fixnum_value(get_struct(v1)->nslots);
case 0x2b: return get_struct(v1)->type;
case 0x2c: return get_hash_value(v1);
case 0x30: return make_float(acos(get_float(v1)));
case 0x31: return make_float(asin(get_float(v1)));
case 0x32: return make_float(atan(get_float(v1)));
case 0x33: return make_float(cos(get_float(v1)));
case 0x34: return make_float(sin(get_float(v1)));
case 0x35: return make_float(tan(get_float(v1)));
case 0x36: return make_float(cosh(get_float(v1)));
case 0x37: return make_float(sinh(get_float(v1)));
case 0x38: return make_float(tanh(get_float(v1)));
case 0x39: return make_float(exp(get_float(v1)));
case 0x3a: {
int exp;
value_t v2 = make_float(frexp(get_float(v1), &exp));
return cons(v2, fixnum_value(exp));
}
case 0x3b: return make_float(log(get_float(v1)));
case 0x3c: return make_float(log10(get_float(v1)));
case 0x3d: {
double integral_part;
gc_root_t rv2;
value_t v3;
register_gc_root(&rv2, make_float(modf(get_float(v1), &integral_part)));
v3 = make_float(integral_part);
unregister_gc_root(&rv2);
return cons(rv2.value, v3);
}
case 0x3e: return make_float(sqrt(get_float(v1)));
case 0x3f: return make_float(ceil(get_float(v1)));
case 0x40: return make_float(fabs(get_float(v1)));
case 0x41: return make_float(floor(get_float(v1)));
case 0x50: return make_float(erf(get_float(v1)));
case 0x51: return make_float(erfc(get_float(v1)));
case 0x52: return make_float(j0(get_float(v1)));
case 0x53: return make_float(j1(get_float(v1)));
case 0x54: {
int signgamp;
value_t v2 = make_float(lgamma_r(get_float(v1), &signgamp));
return cons(v2, fixnum_value(signgamp));
}
case 0x55: return make_float(y0(get_float(v1)));
case 0x56: return make_float(y1(get_float(v1)));
case 0x57: return make_float(asinh(get_float(v1)));
case 0x58: return make_float(acosh(get_float(v1)));
case 0x59: return make_float(atanh(get_float(v1)));
case 0x5a: return make_float(cbrt(get_float(v1)));
case 0x5b: return make_float(logb(get_float(v1)));
case 0x5c: return make_float(expm1(get_float(v1)));
case 0x5d: return make_float(ilogb(get_float(v1)));
case 0x5e: return make_float(log1p(get_float(v1)));
case 0x70: return boolean_value(isnormal(get_float(v1)));
case 0x71: return boolean_value(isfinite(get_float(v1)));
case 0x72: return boolean_value(fpclassify(get_float(v1)) == FP_SUBNORMAL);
case 0x73: return boolean_value(isinf(get_float(v1)));
case 0x74: return boolean_value(isnan(get_float(v1)));
default:
release_assert(NOTREACHED("Invalid unary bytecode."));
return UNDEFINED;
}
}
/*
* 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)
{
switch (var)
{
case 0x00 ... 0x7f:
{
vector_t *vec = _get_vector(state->transients.value);
release_assert(var < state->ntransients);
return vec->elements[var];
}
case 0x80 ... 0xbf:
{
vector_t *vec = _get_vector(state->globals.value);
var -= 0x80;
release_assert(var < vec->size);
return vec->elements[var];
}
case 0xc0 ... 0xef:
{
vector_t *vec = _get_vector(state->instances.value);
var -= 0xc0;
release_assert(var < vec->size);
return vec->elements[var];
}
case 0xf0: return FALSE_VALUE;
case 0xf1: return NIL;
case 0xf2: return UNDEFINED;
/* 0xf3 through 0xf7 are reserved */
case 0xf8: return state->lambda.value;
case 0xf9: return state->globals.value;
case 0xfa: return state->instances.value;
case 0xfb: return state->argv.value;
case 0xfc: return state->kw_args.value;
case 0xfd: return state->kw_vals.value;
case 0xfe: return state->ctx.value;
case 0xff: return state->k.value;
default:
release_assert(NOTREACHED("Invalid input code."));
return UNDEFINED;
}
}
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->kw_args, NIL);
register_gc_root(&state->kw_vals, NIL);
register_gc_root(&state->ctx, FALSE_VALUE);
register_gc_root(&state->k, lookup_builtin(BI_EXIT));
register_gc_root(&state->globals, UNDEFINED);
register_gc_root(&state->instances, UNDEFINED);
register_gc_root(&state->byte_code, UNDEFINED);
register_gc_root(&state->tail_call, UNDEFINED);
register_gc_root(&state->transients, make_vector(128, UNDEFINED));
}
static void unregister_state(interp_state_t *state)
{
unregister_gc_root(&state->lambda);
unregister_gc_root(&state->argv);
unregister_gc_root(&state->kw_args);
unregister_gc_root(&state->kw_vals);
unregister_gc_root(&state->ctx);
unregister_gc_root(&state->k);
unregister_gc_root(&state->globals);
unregister_gc_root(&state->instances);
unregister_gc_root(&state->byte_code);
unregister_gc_root(&state->tail_call);
unregister_gc_root(&state->transients);
}
/* vim:set sw=2 expandtab: */
Reference in New Issue View Git Blame Copy Permalink