From 10fbc269c5cabd3318222e0dd11a9593cb5a96eb Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Fri, 13 Nov 2009 01:10:51 -0600 Subject: [PATCH] Implement the remaining bytecodes. Adjust some of the numbering. Also, use # for "not yet initialized" and #f for "no value". --- doc/bytecode.txt | 180 +++++++++++---------- interp.c | 398 +++++++++++++++++++++++------------------------ interp.h | 15 +- 3 files changed, 309 insertions(+), 284 deletions(-) diff --git a/doc/bytecode.txt b/doc/bytecode.txt index d741604..5272146 100644 --- a/doc/bytecode.txt +++ b/doc/bytecode.txt @@ -7,78 +7,85 @@ expression: up to 64, 1 out, 2 in 00xxxxxx out in in: binary-expr, x > 1 unary-expr: up to 255, 1 out, 1 in 00 invalid / permanently reserved + 01 (set! out in) - 02 (set! out (car in)) - 03 (set! out (cdr in)) - 04 (set! out (unbox in)) - 05 (set! out (not in)) ; if in == #f then #t else #f - 06 (set! out (nil? in)) ; value => bool - 07 (set! out (pair? in)) ; value => bool - 08 (set! out (box? in)) ; value => bool - 09 (set! out (vector? in)) ; value => bool - 0a (set! out (byte-string? in)) ; value => bool - 0b (set! out (struct? in)) ; value => bool - 0c (set! out (fixnum? in)) ; value => bool - 0d (set! out (float? in)) ; value => bool - 0e (set! out (make-box in)) ; value => box - 0f (set! out (make-struct in)) ; metastruct => struct - 10 (set! out (make-float in)) ; fixnum => float - 11 (set! out (lambda in)) ; template-or-lambda => lambda - 12 (set! out (bit-not in)) ; one's complement / bitwise negation - 13 (set! out (fix- in)) ; two's complement / arithmetic negation - 14 (set! out (float- in)) ; floating-point negation + 02 (set! out (unbox in)) + 03 (set! out (car in)) + 04 (set! out (cdr in)) + + 08 (set! out (boolean? in)) ; value => bool + 09 (set! out (fixnum? in)) ; value => bool + 0a (set! out (box? in)) ; value => bool + 0b (set! out (pair? in)) ; value => bool + 0c (set! out (vector? in)) ; value => bool + 0d (set! out (byte-string? in)) ; value => bool + 0e (set! out (struct? in)) ; value => bool + 0f (set! out (float? in)) ; value => bool + 10 (set! out (builtin? in)) ; value => bool + + 18 (set! out (make-box in)) ; value => box + 19 (set! out (make-struct in)) ; metastruct => struct + 1a (set! out (make-float in)) ; fixnum => float + 1b (set! out (lambda in)) ; template-or-lambda => lambda + + 20 (set! out (not in)) ; if in == #f then #t else #f + 21 (set! out (bit-not in)) ; one's complement / bitwise negation + 22 (set! out (fix- in)) ; two's complement / arithmetic negation + 23 (set! out (float- in)) ; floating-point negation ; ISO C floating-point - 20 (set! out (acos in)) - 21 (set! out (asin in)) - 22 (set! out (atan in)) - 23 (set! out (cos in)) - 24 (set! out (sin in)) - 25 (set! out (tan in)) - 26 (set! out (cosh in)) - 27 (set! out (sinh in)) - 28 (set! out (tanh in)) - 29 (set! out (exp in)) - 2a (set! out (frexp in)) ; float => (float . fixnum) - 2b (set! out (log in)) ; base e - 2c (set! out (log10 in)) - 2d (set! out (modf in)) ; float => (float . float) - 2e (set! out (sqrt in)) - 2f (set! out (ceil in)) - 30 (set! out (fabs in)) - 31 (set! out (floor in)) + 30 (set! out (acos in)) + 31 (set! out (asin in)) + 32 (set! out (atan in)) + 33 (set! out (cos in)) + 34 (set! out (sin in)) + 35 (set! out (tan in)) + 36 (set! out (cosh in)) + 37 (set! out (sinh in)) + 38 (set! out (tanh in)) + 39 (set! out (exp in)) + 3a (set! out (frexp in)) ; float => (float . fixnum) + 3b (set! out (log in)) ; base e + 3c (set! out (log10 in)) + 3d (set! out (modf in)) ; float => (float . float) + 3e (set! out (sqrt in)) + 3f (set! out (ceil in)) + 40 (set! out (fabs in)) + 41 (set! out (floor in)) ; SVID & X/Open - 40 (set! out (erf in)) - 41 (set! out (erfc in)) + 50 (set! out (erf in)) + 51 (set! out (erfc in)) ; (set! out (gamma in)) ; obsolete - 42 (set! out (j0 in)) - 43 (set! out (j1 in)) - 44 (set! out (lgamma in)) ; float => (float . fixnum), actually lgamma_r - 45 (set! out (y0 in)) - 46 (set! out (y1 in)) + 52 (set! out (j0 in)) + 53 (set! out (j1 in)) + 54 (set! out (lgamma in)) ; float => (float . fixnum), actually lgamma_r + 55 (set! out (y0 in)) + 56 (set! out (y1 in)) ; SVID & XPG 4.2/5 - 47 (set! out (asinh in)) - 48 (set! out (acosh in)) - 49 (set! out (atanh in)) - 4a (set! out (cbrt in)) - 4b (set! out (logb in)) + 57 (set! out (asinh in)) + 58 (set! out (acosh in)) + 59 (set! out (atanh in)) + 5a (set! out (cbrt in)) + 5b (set! out (logb in)) ; XPG 4.2/5 - 4c (set! out (expm1 in)) - 4d (set! out (ilogb in)) - 4e (set! out (log1p in)) + 5c (set! out (expm1 in)) + 5d (set! out (ilogb in)) + 5e (set! out (log1p in)) ; (set! out (rint in)) ; implies changing rounding mode; use floor or ceil binary-expr: up to 63 (01..3f), 1 out, 2 in 00 unary-expr - 01 (set! out (cons in1 in2)) ; car cdr - 02 (set! out (make-vector in1 in2)) ; nelem iv, nelem >= 0 - 03 (set! out (make-byte-string in1 in2)) ; nbytes iv, nbytes >= 0 - 04 (set! out (vector-ref in1 in2)) ; vector n, 0 <= n < nelem - 05 (set! out (byte-string-ref in1 in2)) ; string n, 0 <= n < nbytes - 06 (set! out (struct-ref in1 in2)) ; struct n, 0 <= n < nslots - 07 (set! out (eq? in1 in2)) ; any values; superset of (fix= in2 in1) + + 01 (set! out (eq? in1 in2)) ; any values; superset of fix= + 02 (set! out (cons in1 in2)) ; car cdr + 03 (set! out (make-vector in1 in2)) ; nelem iv, nelem >= 0 + 04 (set! out (make-byte-string in1 in2)) ; nbytes iv, nbytes >= 0 + 05 (set! out (vector-ref in1 in2)) ; vector n, 0 <= n < nelem + 06 (set! out (byte-string-ref in1 in2)) ; string n, 0 <= n < nbytes + 07 (set! out (struct-ref in1 in2)) ; struct n, 0 <= n < nslots + 08 (set! out (fix+ in1 in2)) 09 (set! out (fix- in1 in2)) 0a (set! out (fix* in1 in2)) @@ -86,35 +93,42 @@ binary-expr: up to 63 (01..3f), 1 out, 2 in 0c (set! out (fix% in1 in2)) 0d (set! out (fix< in1 in2)) ; == (fix> in2 in1) 0e (set! out (fix>= in1 in2)) ; == (fix<= in2 in1) - 0f (set! out (bit-and in1 in2)) - 10 (set! out (bit-or in1 in2)) - 11 (set! out (bit-xor in1 in2)) - 12 (set! out (fix<< in1 in2)) ; arithmetic left-shift (2*x) w/ overflow into sign - 13 (set! out (fix>> in1 in2)) ; arithmetic right-shift (x/2) - 14 (set! out (fix>>> in1 in2)) ; logical right-shift; sign becomes zero (+) - 15 (set! out (float+ in1 in2)) - 16 (set! out (float- in1 in2)) - 17 (set! out (float* in1 in2)) - 18 (set! out (float/ in1 in2)) - 19 (set! out (float< in1 in2)) ; == (float> in2 in1) - 1a (set! out (float>= in1 in2)) ; == (float<= in2 in1) - 1b (set! out (atan2 in1 in2)) ; float float - 1c (set! out (pow in1 in2)) ; float float - 1d (set! out (ldexp in1 in2)) ; float fixnum - 1e (set! out (fmod in1 in2)) ; float float - 1f (set! out (hypot in1 in2)) ; float float - 20 (set! out (jn in1 in2)) ; fixnum float - 21 (set! out (yn in1 in2)) ; fixnum float - 22 (set! out (nextafter in1 in2)) ; float float - 23 (set! out (remainder in1 in2)) ; float float - 24 (set! out (scalb in1 in2)) ; float float + + 10 (set! out (bit-and in1 in2)) + 11 (set! out (bit-or in1 in2)) + 12 (set! out (bit-xor in1 in2)) + + 14 (set! out (fix<< in1 in2)) ; arithmetic left-shift (2*x) w/ overflow into sign + 15 (set! out (fix>> in1 in2)) ; arithmetic right-shift (x/2) + 16 (set! out (fix>>> in1 in2)) ; logical right-shift; sign becomes zero (+) + + 18 (set! out (float+ in1 in2)) + 19 (set! out (float- in1 in2)) + 1a (set! out (float* in1 in2)) + 1b (set! out (float/ in1 in2)) + 1c (set! out (float= in1 in2)) + 1d (set! out (float< in1 in2)) ; == (float> in2 in1) + 1e (set! out (float>= in1 in2)) ; == (float<= in2 in1) + + 20 (set! out (atan2 in1 in2)) ; float float + 21 (set! out (pow in1 in2)) ; float float + 22 (set! out (ldexp in1 in2)) ; float fixnum + 23 (set! out (fmod in1 in2)) ; float float + 24 (set! out (hypot in1 in2)) ; float float + 25 (set! out (jn in1 in2)) ; fixnum float + 26 (set! out (yn in1 in2)) ; fixnum float + 27 (set! out (nextafter in1 in2)) ; float float + 28 (set! out (remainder in1 in2)) ; float float + 29 (set! out (scalb in1 in2)) ; float float conditional: 1AAAAAAA; 1 out, 2 in + fA AA (set! out (if fA in1 in2)) ; in2 if fA == #f, in1 otherwise statement: up to 64 (40..7f), 3 in + ; binary statements 40 (set-box! in in) ; box value 41 (set-car! in in) ; pair value 42 (set-cdr! in in) ; pair value + ; ternary statements 60 (vector-set! in in in) ; vector n value, 0 <= n < nelem 61 (byte-string-set! in in in) ; string n value, 0 <= n < nbytes 62 (struct-set! in in in) ; struct n value, 0 <= n < nslots @@ -135,7 +149,7 @@ out: lambda:[ global: vector of immutable values (g1..gN); shared between instances (lambdas) instance: vector of immutable values (i0..iN); shared between frames (calls) - frame: number of frame variables; initially NIL + frame: number of frame variables; initially # code: byte-string containing sequence of 4-byte instruction words tail-call: in-ref of lambda to tail-call arguments: in-ref of argument list to pass to tail-call @@ -158,7 +172,7 @@ Protocol: Normal function calls (return to caller, or caller's continuation if tail-call): Call: Tail-call function with valid 'k' and original 'ctx'. - Return: Tail-call 'k' with 'nil' continuation and context (ignored). + Return: Tail-call 'k' with #f continuation and context (ignored). Coroutines (cooperating, interleaved tail-call chains in CPS): Call: Tail-call function with valid 'k' and original 'ctx'. diff --git a/interp.c b/interp.c index 8b6f042..a2d5991 100644 --- a/interp.c +++ b/interp.c @@ -1,10 +1,19 @@ +#define _XOPEN_SOURCE 500 +#define _REENTRANT 1 +#define _SVID_SOURCE 1 + +/* Required for lgamma_r on Solaris */ +#define __EXTENSIONS__ 1 + #include +#include #include #include #include -#include "builtin.h" #include "gc.h" +#include "builtin.h" +#include "interp.h" /* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */ #define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s]) @@ -15,18 +24,6 @@ #define ST2 (state->in2.value) #define ST3 (state->in3.value) -typedef struct interp_state -{ - gc_root_t lambda; - gc_root_t frame; - gc_root_t argv; - gc_root_t k; - gc_root_t ctx; - gc_root_t in1; - gc_root_t in2; - gc_root_t in3; -} interp_state_t; - /* Quick references to main builtins */ static gc_root_t structure_type_root; static gc_root_t template_type_root; @@ -79,21 +76,36 @@ value_t run_interpreter(value_t lambda, value_t argv) 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)) + /* 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. + * Now 'lambda' really is a lambda structure instance (or builtin). */ - /* Allocate frame variables */ - state.frame.value = make_vector(get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS)), NIL); + if (is_builtin_fn(state.lambda.value)) + { + /* Builtin functions replace the byte-code and tail-call + * steps; they also do not require frame variables. */ + _get_builtin_fn(state.lambda.value)(&state); + } + else + { + /* Allocate frame variables, initially undefined */ + state.frame.value = make_vector(get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS)), UNDEFINED); - run_byte_code(&state); - perform_tail_call(&state); + run_byte_code(&state); + perform_tail_call(&state); + } + + /* Clear temporaries so they can be GC'd. */ + state.frame.value = UNDEFINED; + state.in1.value = UNDEFINED; + state.in2.value = UNDEFINED; + state.in3.value = UNDEFINED; if (run_finalizers) { @@ -118,11 +130,11 @@ value_t run_interpreter(value_t lambda, value_t argv) unregister_state(&state); - /* The arguments passed to NIL continuation are the final return value. */ + /* The arguments passed to continuation are the final return value. */ return state.argv.value; } -/* TODO: Permit derivatives of 'structure'. */ +/* TODO: Permit derivatives of 'structure', and improve detection of cycles. */ static bool struct_is_a(value_t s, value_t type) { /* Detect unbounded loops w/ cyclic 'parent' links. */ @@ -133,14 +145,11 @@ static bool struct_is_a(value_t s, value_t type) for (value_t t = _get_struct(s)->type; t != type; t = _SLOT_VALUE(STRUCTURE, t, SUPER), --ttl) { - if (is_nil(t)) + if (t == FALSE_VALUE) return false; - if (get_struct(t)->type != structure_type_root.value) - abort(); - - if (ttl <= 0) - abort(); + release_assert(get_struct(t)->type == structure_type_root.value); + release_assert(ttl > 0); } return true; @@ -149,50 +158,35 @@ static bool struct_is_a(value_t s, value_t type) static value_t vector_ref(value_t v, fixnum_t idx) { vector_t *vec = get_vector(v); - - if (idx < 0 || idx >= vec->size) - abort(); - + 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); - - if (idx < 0 || idx >= str->size) - abort(); - + 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) - abort(); - + 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); - - if (idx < 0 || idx >= vec->size) - abort(); - + release_assert((idx >= 0) && (idx < vec->size)); vec->elements[idx] = newval; } static void byte_string_set(value_t v, fixnum_t idx, char newval) { byte_string_t *str = get_byte_string(v); - - if (idx < 0 || idx >= str->size) - abort(); - + release_assert((idx >= 0) && (idx < str->size)); str->bytes[idx] = newval; } @@ -200,8 +194,9 @@ static void struct_set(value_t v, fixnum_t idx, value_t newval) { struct_t *s = get_struct(v); - if (idx < 0 || idx >= s->nslots) - abort(); + 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; } @@ -209,7 +204,6 @@ 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) { gc_root_t templ_root, lambda_root; - value_t lval; struct_t *ls; struct_t *ts; vector_t *l_inst; @@ -219,16 +213,14 @@ static value_t make_lambda(interp_state_t *state, value_t 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. */ - _get_struct(lambda_root.value)->slots[LAMBDA_SLOT_INSTANCE_VARS] = + _LAMBDA_SLOT(lambda_root.value, INSTANCE_VARS) = make_vector(get_vector(get_struct(templ_root.value) ->slots[TEMPLATE_SLOT_INSTANCE_VARS]) ->size, - NIL); + UNDEFINED); ls = _get_struct(lambda_root.value); ts = _get_struct(templ_root.value); - l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]); - t_inst = get_byte_string(ts->slots[TEMPLATE_SLOT_INSTANCE_VARS]); /* All but the instance variables are just shallow-copied. */ ls->slots[LAMBDA_SLOT_GLOBAL_VARS] = ts->slots[TEMPLATE_SLOT_GLOBAL_VARS]; @@ -239,6 +231,9 @@ static value_t make_lambda(interp_state_t *state, value_t templ) ls->slots[LAMBDA_SLOT_CONTINUATION] = ts->slots[TEMPLATE_SLOT_CONTINUATION]; ls->slots[LAMBDA_SLOT_CONTEXT] = ts->slots[TEMPLATE_SLOT_CONTEXT]; + 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]); @@ -252,10 +247,12 @@ static value_t make_lambda(interp_state_t *state, value_t templ) static void translate_callable(interp_state_t *state) { - while (!struct_is_a(state->lambda.value, lambda_type_root.value)) + while (!is_builtin_fn(state->lambda.value) && + !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(); + /* 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); @@ -287,8 +284,9 @@ static void run_byte_code(interp_state_t *state) break; case 128 ... 255: /* conditional */ set_output(state, bytes[0], - get_input(state, - is_true(get_input(state, bytes[1])) ? bytes[2] : bytes[3])); + get_input(state, _get_boolean(get_input(state, bytes[1])) + ? bytes[2] + : bytes[3])); break; } } @@ -313,60 +311,53 @@ 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) { - if (code == 0) + if (code != 0x00) { - return eval_unary_expression(state, in1, in2); + ST1 = get_input(state, in1); + ST2 = get_input(state, in2); } - ST1 = get_input(state, in1); - ST2 = get_input(state, in2); - switch (code) { - case 0x01: - return cons(ST1, ST2); - case 0x02: - return make_vector(get_fixnum(ST1), ST2); - case 0x03: - return make_byte_string(get_fixnum(ST1), (char)get_fixnum(ST2)); - case 0x04: - return vector_ref(ST1, get_fixnum(ST2)); - case 0x05: - return make_fixnum(byte_string_ref(ST1, get_fixnum(ST2))); - case 0x06: - return struct_ref(ST1, get_fixnum(ST2)); - case 0x07: - return ST1 == ST2; - case 0x08: - return make_fixnum(get_fixnum(ST1) + get_fixnum(ST2)); - case 0x09: - return make_fixnum(get_fixnum(ST1) - get_fixnum(ST2)); - case 0x0a: - return make_fixnum(get_fixnum(ST1) * get_fixnum(ST2)); - case 0x0b: - return make_fixnum(get_fixnum(ST1) / get_fixnum(ST2)); - case 0x0c: - return make_fixnum(get_fixnum(ST1) % get_fixnum(ST2)); - case 0x0d: - return make_fixnum(get_fixnum(ST1) < get_fixnum(ST2)); - case 0x0e: - return make_fixnum(get_fixnum(ST1) >= get_fixnum(ST2)); - case 0x0f: - return make_fixnum(get_fixnum(ST1) & get_fixnum(ST2)); - case 0x10: - return make_fixnum(get_fixnum(ST1) | get_fixnum(ST2)); - case 0x11: - return make_fixnum(get_fixnum(ST1) ^ get_fixnum(ST2)); - case 0x12: - return make_fixnum(get_fixnum(ST1) << get_fixnum(ST2)); - case 0x13: - return make_fixnum(get_fixnum(ST1) >> get_fixnum(ST2)); - case 0x14: - return make_fixnum((unsigned long)get_fixnum(ST1) >> get_fixnum(ST2)); - case 0x15 ... 0x24: - return UNDEFINED; - default: - abort(); + 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))); + default: release_assert(NOTREACHED("Invalid byte-code!")); } return UNDEFINED; @@ -374,66 +365,87 @@ static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uint8_t in) { - if (subcode == 0) - { - abort(); - } - + release_assert(subcode != 0); ST1 = get_input(state, in); switch (subcode) { - case 0x01: - return ST1; - case 0x02: - return get_pair(ST1)->car; - case 0x03: - return get_pair(ST1)->cdr; - case 0x04: - return get_box(ST1)->value; - case 0x05: - return make_boolean(is_false(ST1)); - case 0x06: - return make_boolean(is_nil(ST1)); - case 0x07: - return make_boolean(is_pair(ST1)); - case 0x08: - return make_boolean(is_box(ST1)); - case 0x09: - return make_boolean(is_vector(ST1)); - case 0x0a: - return make_boolean(is_byte_string(ST1)); - case 0x0b: - return make_boolean(is_struct(ST1)); - case 0x0c: - return make_boolean(is_fixnum(ST1)); - case 0x0d: - //return make_boolean(is_float(ST1)); - return FALSE_VALUE; - case 0x0e: - return make_box(ST1); - case 0x0f: - if (!struct_is_a(ST1, structure_type_root.value)) - abort(); - return make_struct(ST1, get_vector(_get_struct(ST1)->slots[STRUCTURE_SLOT_SLOTS])->size); - case 0x10: - //return make_float((float_t)get_fixnum(ST1)); - return UNDEFINED; - case 0x11: - return make_lambda(state, ST1); - case 0x12: - return make_fixnum(~get_fixnum(ST1)); - case 0x13: - return make_fixnum(-get_fixnum(ST1)); - case 0x14: - //return make_float(-from_float(ST1)); - return UNDEFINED; - case 0x20 ... 0x31: - case 0x40 ... 0x4e: - return UNDEFINED; - default: - abort(); + 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 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))); + 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) @@ -448,28 +460,19 @@ static void run_statement(interp_state_t *state, uint8_t code, uint8_t in1, uint switch (code) { - case 0x40: - get_box(ST1)->value = ST2; - break; - case 0x41: - get_pair(ST1)->car = ST2; - break; - case 0x42: - get_pair(ST1)->cdr = ST2; - 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); + case 0x40: get_box(ST1)->value = ST2; break; + case 0x41: get_pair(ST1)->car = ST2; break; + case 0x42: get_pair(ST1)->cdr = ST2; 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; } } static value_t get_input(const interp_state_t *state, fixnum_t var) { + release_assert((var >= 0) && (var <= 255)); + switch (var) { case 0: @@ -479,9 +482,7 @@ static value_t get_input(const interp_state_t *state, fixnum_t var) vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, GLOBAL_VARS)); var -= 1; - if (var >= vec->size) - abort(); - + release_assert(var < vec->size); return vec->elements[var]; } case 64 ... 127: @@ -489,9 +490,7 @@ static value_t get_input(const interp_state_t *state, fixnum_t var) vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, INSTANCE_VARS)); var -= 64; - if (var >= vec->size) - abort(); - + release_assert(var < vec->size); return vec->elements[var]; } case 128 ... 247: @@ -500,9 +499,7 @@ static value_t get_input(const interp_state_t *state, fixnum_t var) vector_t *vec = _get_vector(state->frame.value); var -= 128; - if (var >= vec->size) - abort(); - + release_assert(var < vec->size); return vec->elements[var]; } /* 248 ... 252 are reserved */ @@ -513,7 +510,7 @@ static value_t get_input(const interp_state_t *state, fixnum_t var) case 255: return state->ctx.value; default: - abort(); + return UNDEFINED; } } @@ -522,22 +519,23 @@ 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. */ - if (var < 128 || var >= (128 + vec->size)) - abort(); + release_assert((var >= 128) && (var <= 255)); - vec->elements[var-128] = val; + var -= 128; + release_assert(var < vec->size); + 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->frame, UNDEFINED); register_gc_root(&state->argv, argv); - register_gc_root(&state->k, NIL); - register_gc_root(&state->ctx, NIL); - register_gc_root(&state->in1, NIL); - register_gc_root(&state->in2, NIL); - register_gc_root(&state->in3, NIL); + register_gc_root(&state->k, FALSE_VALUE); + register_gc_root(&state->ctx, 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) diff --git a/interp.h b/interp.h index e29bd35..5cf6bd2 100644 --- a/interp.h +++ b/interp.h @@ -1,7 +1,20 @@ +/* Need to ensure gc.h is included first, because it depends on interp.h. */ +#include "gc.h" + #ifndef INTERP_H_9c7eea5c5cd0f7a32b79a8ca0ab2969f #define INTERP_H_9c7eea5c5cd0f7a32b79a8ca0ab2969f -#include "gc.h" +typedef struct interp_state +{ + gc_root_t lambda; + gc_root_t frame; + gc_root_t argv; + gc_root_t k; + gc_root_t ctx; + gc_root_t in1; + gc_root_t in2; + gc_root_t in3; +} interp_state_t; void interpreter_init(void); value_t run_interpreter(value_t lambda, value_t argv);