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

Implement the remaining bytecodes. Adjust some of the numbering. 

Also, use #<undefined> for "not yet initialized" and #f for "no value".
This commit is contained in:
Jesse D. McDonald 2009-11-13 01:10:51 -06:00
parent 61e0583932
commit 10fbc269c5
3 changed files with 309 additions and 284 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

180
doc/bytecode.txt
View File

@ -7,78 +7,85 @@ expression: up to 64, 1 out, 2 in
00xxxxxx out in in: binary-expr, x > 1 00xxxxxx out in in: binary-expr, x > 1
unary-expr: up to 255, 1 out, 1 in unary-expr: up to 255, 1 out, 1 in
00 invalid / permanently reserved 00 invalid / permanently reserved
01 (set! out in) 01 (set! out in)
02 (set! out (car in)) 02 (set! out (unbox in))
03 (set! out (cdr in)) 03 (set! out (car in))
04 (set! out (unbox in)) 04 (set! out (cdr in))
05 (set! out (not in)) ; if in == #f then #t else #f
06 (set! out (nil? in)) ; value => bool 08 (set! out (boolean? in)) ; value => bool
07 (set! out (pair? in)) ; value => bool 09 (set! out (fixnum? in)) ; value => bool
08 (set! out (box? in)) ; value => bool 0a (set! out (box? in)) ; value => bool
09 (set! out (vector? in)) ; value => bool 0b (set! out (pair? in)) ; value => bool
0a (set! out (byte-string? in)) ; value => bool 0c (set! out (vector? in)) ; value => bool
0b (set! out (struct? in)) ; value => bool 0d (set! out (byte-string? in)) ; value => bool
0c (set! out (fixnum? in)) ; value => bool 0e (set! out (struct? in)) ; value => bool
0d (set! out (float? in)) ; value => bool 0f (set! out (float? in)) ; value => bool
0e (set! out (make-box in)) ; value => box 10 (set! out (builtin? in)) ; value => bool
0f (set! out (make-struct in)) ; metastruct => struct
10 (set! out (make-float in)) ; fixnum => float 18 (set! out (make-box in)) ; value => box
11 (set! out (lambda in)) ; template-or-lambda => lambda 19 (set! out (make-struct in)) ; metastruct => struct
12 (set! out (bit-not in)) ; one's complement / bitwise negation 1a (set! out (make-float in)) ; fixnum => float
13 (set! out (fix- in)) ; two's complement / arithmetic negation 1b (set! out (lambda in)) ; template-or-lambda => lambda
14 (set! out (float- in)) ; floating-point negation
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 ; ISO C floating-point
20 (set! out (acos in)) 30 (set! out (acos in))
21 (set! out (asin in)) 31 (set! out (asin in))
22 (set! out (atan in)) 32 (set! out (atan in))
23 (set! out (cos in)) 33 (set! out (cos in))
24 (set! out (sin in)) 34 (set! out (sin in))
25 (set! out (tan in)) 35 (set! out (tan in))
26 (set! out (cosh in)) 36 (set! out (cosh in))
27 (set! out (sinh in)) 37 (set! out (sinh in))
28 (set! out (tanh in)) 38 (set! out (tanh in))
29 (set! out (exp in)) 39 (set! out (exp in))
2a (set! out (frexp in)) ; float => (float . fixnum) 3a (set! out (frexp in)) ; float => (float . fixnum)
2b (set! out (log in)) ; base e 3b (set! out (log in)) ; base e
2c (set! out (log10 in)) 3c (set! out (log10 in))
2d (set! out (modf in)) ; float => (float . float) 3d (set! out (modf in)) ; float => (float . float)
2e (set! out (sqrt in)) 3e (set! out (sqrt in))
2f (set! out (ceil in)) 3f (set! out (ceil in))
30 (set! out (fabs in)) 40 (set! out (fabs in))
31 (set! out (floor in)) 41 (set! out (floor in))
; SVID & X/Open ; SVID & X/Open
40 (set! out (erf in)) 50 (set! out (erf in))
41 (set! out (erfc in)) 51 (set! out (erfc in))
; (set! out (gamma in)) ; obsolete ; (set! out (gamma in)) ; obsolete
42 (set! out (j0 in)) 52 (set! out (j0 in))
43 (set! out (j1 in)) 53 (set! out (j1 in))
44 (set! out (lgamma in)) ; float => (float . fixnum), actually lgamma_r 54 (set! out (lgamma in)) ; float => (float . fixnum), actually lgamma_r
45 (set! out (y0 in)) 55 (set! out (y0 in))
46 (set! out (y1 in)) 56 (set! out (y1 in))
; SVID & XPG 4.2/5 ; SVID & XPG 4.2/5
47 (set! out (asinh in)) 57 (set! out (asinh in))
48 (set! out (acosh in)) 58 (set! out (acosh in))
49 (set! out (atanh in)) 59 (set! out (atanh in))
4a (set! out (cbrt in)) 5a (set! out (cbrt in))
4b (set! out (logb in)) 5b (set! out (logb in))
; XPG 4.2/5 ; XPG 4.2/5
4c (set! out (expm1 in)) 5c (set! out (expm1 in))
4d (set! out (ilogb in)) 5d (set! out (ilogb in))
4e (set! out (log1p in)) 5e (set! out (log1p in))
; (set! out (rint in)) ; implies changing rounding mode; use floor or ceil ; (set! out (rint in)) ; implies changing rounding mode; use floor or ceil
binary-expr: up to 63 (01..3f), 1 out, 2 in binary-expr: up to 63 (01..3f), 1 out, 2 in
00 unary-expr 00 unary-expr
01 (set! out (cons in1 in2)) ; car cdr
02 (set! out (make-vector in1 in2)) ; nelem iv, nelem >= 0 01 (set! out (eq? in1 in2)) ; any values; superset of fix=
03 (set! out (make-byte-string in1 in2)) ; nbytes iv, nbytes >= 0 02 (set! out (cons in1 in2)) ; car cdr
04 (set! out (vector-ref in1 in2)) ; vector n, 0 <= n < nelem 03 (set! out (make-vector in1 in2)) ; nelem iv, nelem >= 0
05 (set! out (byte-string-ref in1 in2)) ; string n, 0 <= n < nbytes 04 (set! out (make-byte-string in1 in2)) ; nbytes iv, nbytes >= 0
06 (set! out (struct-ref in1 in2)) ; struct n, 0 <= n < nslots 05 (set! out (vector-ref in1 in2)) ; vector n, 0 <= n < nelem
07 (set! out (eq? in1 in2)) ; any values; superset of (fix= in2 in1) 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)) 08 (set! out (fix+ in1 in2))
09 (set! out (fix- in1 in2)) 09 (set! out (fix- in1 in2))
0a (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)) 0c (set! out (fix% in1 in2))
0d (set! out (fix< in1 in2)) ; == (fix> in2 in1) 0d (set! out (fix< in1 in2)) ; == (fix> in2 in1)
0e (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)) 10 (set! out (bit-and in1 in2))
11 (set! out (bit-xor in1 in2)) 11 (set! out (bit-or in1 in2))
12 (set! out (fix<< in1 in2)) ; arithmetic left-shift (2*x) w/ overflow into sign 12 (set! out (bit-xor in1 in2))
13 (set! out (fix>> in1 in2)) ; arithmetic right-shift (x/2)
14 (set! out (fix>>> in1 in2)) ; logical right-shift; sign becomes zero (+) 14 (set! out (fix<< in1 in2)) ; arithmetic left-shift (2*x) w/ overflow into sign
15 (set! out (float+ in1 in2)) 15 (set! out (fix>> in1 in2)) ; arithmetic right-shift (x/2)
16 (set! out (float- in1 in2)) 16 (set! out (fix>>> in1 in2)) ; logical right-shift; sign becomes zero (+)
17 (set! out (float* in1 in2))
18 (set! out (float/ in1 in2)) 18 (set! out (float+ in1 in2))
19 (set! out (float< in1 in2)) ; == (float> in2 in1) 19 (set! out (float- in1 in2))
1a (set! out (float>= in1 in2)) ; == (float<= in2 in1) 1a (set! out (float* in1 in2))
1b (set! out (atan2 in1 in2)) ; float float 1b (set! out (float/ in1 in2))
1c (set! out (pow in1 in2)) ; float float 1c (set! out (float= in1 in2))
1d (set! out (ldexp in1 in2)) ; float fixnum 1d (set! out (float< in1 in2)) ; == (float> in2 in1)
1e (set! out (fmod in1 in2)) ; float float 1e (set! out (float>= in1 in2)) ; == (float<= in2 in1)
1f (set! out (hypot in1 in2)) ; float float
20 (set! out (jn in1 in2)) ; fixnum float 20 (set! out (atan2 in1 in2)) ; float float
21 (set! out (yn in1 in2)) ; fixnum float 21 (set! out (pow in1 in2)) ; float float
22 (set! out (nextafter in1 in2)) ; float float 22 (set! out (ldexp in1 in2)) ; float fixnum
23 (set! out (remainder in1 in2)) ; float float 23 (set! out (fmod in1 in2)) ; float float
24 (set! out (scalb 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 conditional: 1AAAAAAA; 1 out, 2 in + fA
AA (set! out (if fA in1 in2)) ; in2 if fA == #f, in1 otherwise AA (set! out (if fA in1 in2)) ; in2 if fA == #f, in1 otherwise
statement: up to 64 (40..7f), 3 in statement: up to 64 (40..7f), 3 in
; binary statements
40 (set-box! in in) ; box value 40 (set-box! in in) ; box value
41 (set-car! in in) ; pair value 41 (set-car! in in) ; pair value
42 (set-cdr! 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 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 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 62 (struct-set! in in in) ; struct n value, 0 <= n < nslots
@ -135,7 +149,7 @@ out:
lambda:[ lambda:[
global: vector of immutable values (g1..gN); shared between instances (lambdas) global: vector of immutable values (g1..gN); shared between instances (lambdas)
instance: vector of immutable values (i0..iN); shared between frames (calls) instance: vector of immutable values (i0..iN); shared between frames (calls)
frame: number of frame variables; initially NIL frame: number of frame variables; initially #<undefined>
code: byte-string containing sequence of 4-byte instruction words code: byte-string containing sequence of 4-byte instruction words
tail-call: in-ref of lambda to tail-call tail-call: in-ref of lambda to tail-call
arguments: in-ref of argument list to pass 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): Normal function calls (return to caller, or caller's continuation if tail-call):
Call: Tail-call function with valid 'k' and original 'ctx'. 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): Coroutines (cooperating, interleaved tail-call chains in CPS):
Call: Tail-call function with valid 'k' and original 'ctx'. Call: Tail-call function with valid 'k' and original 'ctx'.

392
interp.c
View File

@ -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 <inttypes.h> #include <inttypes.h>
#include <math.h>
#include <stdbool.h> #include <stdbool.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
#include "builtin.h"
#include "gc.h" #include "gc.h"
#include "builtin.h"
#include "interp.h"
/* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */ /* Ex: _SLOT_VALUE(STRUCTURE, v, NAME) */
#define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s]) #define _SLOT_VALUE(t,v,s) (_get_struct(v)->slots[t ## _SLOT_ ## s])
@ -15,18 +24,6 @@
#define ST2 (state->in2.value) #define ST2 (state->in2.value)
#define ST3 (state->in3.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 */ /* Quick references to main builtins */
static gc_root_t structure_type_root; static gc_root_t structure_type_root;
static gc_root_t template_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); register_state(&state, lambda, argv);
/* Keep going until something attempt to tail-call NIL, the original 'k', indicating completion. */ /* Keep going until something attempts to tail-call FALSE_VALUE, the original 'k', indicating completion. */
while (!is_nil(state.lambda.value)) while (state.lambda.value != FALSE_VALUE)
{ {
/* 'lambda' may be a callable structure; if so, follow the 'callable' proxies and update argv. */ /* 'lambda' may be a callable structure; if so, follow the 'callable' proxies and update argv. */
translate_callable(&state); translate_callable(&state);
/* /*
* Now 'lambda' really is a lambda structure instance. * Now 'lambda' really is a lambda structure instance (or builtin).
*/ */
/* Allocate frame variables */ if (is_builtin_fn(state.lambda.value))
state.frame.value = make_vector(get_fixnum(_LAMBDA_SLOT(state.lambda.value, FRAME_VARS)), NIL); {
/* 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); run_byte_code(&state);
perform_tail_call(&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) if (run_finalizers)
{ {
@ -118,11 +130,11 @@ value_t run_interpreter(value_t lambda, value_t argv)
unregister_state(&state); 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; 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) static bool struct_is_a(value_t s, value_t type)
{ {
/* Detect unbounded loops w/ cyclic 'parent' links. */ /* 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) 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; return false;
if (get_struct(t)->type != structure_type_root.value) release_assert(get_struct(t)->type == structure_type_root.value);
abort(); release_assert(ttl > 0);
if (ttl <= 0)
abort();
} }
return true; 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) static value_t vector_ref(value_t v, fixnum_t idx)
{ {
vector_t *vec = get_vector(v); vector_t *vec = get_vector(v);
release_assert((idx >= 0) && (idx < vec->size));
if (idx < 0 || idx >= vec->size)
abort();
return vec->elements[idx]; return vec->elements[idx];
} }
static char byte_string_ref(value_t v, fixnum_t idx) static char byte_string_ref(value_t v, fixnum_t idx)
{ {
byte_string_t *str = get_byte_string(v); byte_string_t *str = get_byte_string(v);
release_assert((idx >= 0) && (idx < str->size));
if (idx < 0 || idx >= str->size)
abort();
return str->bytes[idx]; return str->bytes[idx];
} }
static value_t struct_ref(value_t v, fixnum_t idx) static value_t struct_ref(value_t v, fixnum_t idx)
{ {
struct_t *s = get_struct(v); struct_t *s = get_struct(v);
release_assert((idx >= 0) && (idx < s->nslots));
if (idx < 0 || idx >= s->nslots)
abort();
return s->slots[idx]; return s->slots[idx];
} }
static void vector_set(value_t v, fixnum_t idx, value_t newval) static void vector_set(value_t v, fixnum_t idx, value_t newval)
{ {
vector_t *vec = get_vector(v); vector_t *vec = get_vector(v);
release_assert((idx >= 0) && (idx < vec->size));
if (idx < 0 || idx >= vec->size)
abort();
vec->elements[idx] = newval; vec->elements[idx] = newval;
} }
static void byte_string_set(value_t v, fixnum_t idx, char newval) static void byte_string_set(value_t v, fixnum_t idx, char newval)
{ {
byte_string_t *str = get_byte_string(v); byte_string_t *str = get_byte_string(v);
release_assert((idx >= 0) && (idx < str->size));
if (idx < 0 || idx >= str->size)
abort();
str->bytes[idx] = newval; 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); struct_t *s = get_struct(v);
if (idx < 0 || idx >= s->nslots) release_assert(struct_is_a(s->type, structure_type_root.value));
abort(); release_assert(_get_boolean(_SLOT_VALUE(STRUCTURE, s->type, MUTABLE)));
release_assert((idx >= 0) && (idx < s->nslots));
s->slots[idx] = newval; 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) static value_t make_lambda(interp_state_t *state, value_t templ)
{ {
gc_root_t templ_root, lambda_root; gc_root_t templ_root, lambda_root;
value_t lval;
struct_t *ls; struct_t *ls;
struct_t *ts; struct_t *ts;
vector_t *l_inst; 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)); 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. */ /* 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) make_vector(get_vector(get_struct(templ_root.value)
->slots[TEMPLATE_SLOT_INSTANCE_VARS]) ->slots[TEMPLATE_SLOT_INSTANCE_VARS])
->size, ->size,
NIL); UNDEFINED);
ls = _get_struct(lambda_root.value); ls = _get_struct(lambda_root.value);
ts = _get_struct(templ_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. */ /* 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_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_CONTINUATION] = ts->slots[TEMPLATE_SLOT_CONTINUATION];
ls->slots[LAMBDA_SLOT_CONTEXT] = ts->slots[TEMPLATE_SLOT_CONTEXT]; 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) for (size_t i = 0; i < t_inst->size; ++i)
{ {
l_inst->elements[i] = get_input(state, t_inst->bytes[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) 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)) /* If it's not a lambda, built-in function, or typed structure, then
abort(); * 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. */ /* Prepend structure instance to argument list, per proxy protocol. */
state->argv.value = cons(state->lambda.value, state->argv.value); state->argv.value = cons(state->lambda.value, state->argv.value);
@ -287,8 +284,9 @@ static void run_byte_code(interp_state_t *state)
break; break;
case 128 ... 255: /* conditional */ case 128 ... 255: /* conditional */
set_output(state, bytes[0], set_output(state, bytes[0],
get_input(state, get_input(state, _get_boolean(get_input(state, bytes[1]))
is_true(get_input(state, bytes[1])) ? bytes[2] : bytes[3])); ? bytes[2]
: bytes[3]));
break; 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) 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); ST1 = get_input(state, in1);
ST2 = get_input(state, in2); ST2 = get_input(state, in2);
}
switch (code) switch (code)
{ {
case 0x01: case 0x00: return eval_unary_expression(state, in1, in2);
return cons(ST1, ST2); case 0x01: return boolean_value(ST1 == ST2);
case 0x02: case 0x02: return cons(ST1, ST2);
return make_vector(get_fixnum(ST1), ST2); case 0x03: return make_vector(get_fixnum(ST1), ST2);
case 0x03: case 0x04: return make_byte_string(get_fixnum(ST1), (char)get_fixnum(ST2));
return make_byte_string(get_fixnum(ST1), (char)get_fixnum(ST2)); case 0x05: return vector_ref(ST1, get_fixnum(ST2));
case 0x04: case 0x06: return fixnum_value(byte_string_ref(ST1, get_fixnum(ST2)));
return vector_ref(ST1, get_fixnum(ST2)); case 0x07: return struct_ref(ST1, get_fixnum(ST2));
case 0x05: case 0x08: return fixnum_value(get_fixnum(ST1) + get_fixnum(ST2));
return make_fixnum(byte_string_ref(ST1, get_fixnum(ST2))); case 0x09: return fixnum_value(get_fixnum(ST1) - get_fixnum(ST2));
case 0x06: case 0x0a: return fixnum_value(get_fixnum(ST1) * get_fixnum(ST2));
return struct_ref(ST1, get_fixnum(ST2)); case 0x0b: return fixnum_value(get_fixnum(ST1) / get_fixnum(ST2));
case 0x07: case 0x0c: return fixnum_value(get_fixnum(ST1) % get_fixnum(ST2));
return ST1 == ST2; case 0x0d: return boolean_value(get_fixnum(ST1) < get_fixnum(ST2));
case 0x08: case 0x0e: return boolean_value(get_fixnum(ST1) >= get_fixnum(ST2));
return make_fixnum(get_fixnum(ST1) + get_fixnum(ST2)); case 0x10: return fixnum_value(get_fixnum(ST1) & get_fixnum(ST2));
case 0x09: case 0x11: return fixnum_value(get_fixnum(ST1) | get_fixnum(ST2));
return make_fixnum(get_fixnum(ST1) - get_fixnum(ST2)); case 0x12: return fixnum_value(get_fixnum(ST1) ^ get_fixnum(ST2));
case 0x0a: case 0x14: return fixnum_value(get_fixnum(ST1) << get_fixnum(ST2));
return make_fixnum(get_fixnum(ST1) * get_fixnum(ST2)); case 0x15: return fixnum_value(get_fixnum(ST1) >> get_fixnum(ST2));
case 0x0b: case 0x16: return fixnum_value((unsigned long)get_fixnum(ST1) >> get_fixnum(ST2));
return make_fixnum(get_fixnum(ST1) / get_fixnum(ST2)); case 0x18: return make_float(get_float(ST1) + get_float(ST2));
case 0x0c: case 0x19: return make_float(get_float(ST1) - get_float(ST2));
return make_fixnum(get_fixnum(ST1) % get_fixnum(ST2)); case 0x1a: return make_float(get_float(ST1) * get_float(ST2));
case 0x0d: case 0x1b: return make_float(get_float(ST1) / get_float(ST2));
return make_fixnum(get_fixnum(ST1) < get_fixnum(ST2)); case 0x1c: return boolean_value(get_float(ST1) == get_float(ST2));
case 0x0e: case 0x1d: return boolean_value(get_float(ST1) < get_float(ST2));
return make_fixnum(get_fixnum(ST1) >= get_fixnum(ST2)); case 0x1e: return boolean_value(get_float(ST1) >= get_float(ST2));
case 0x0f: case 0x20: return make_float(atan2(get_float(ST1), get_float(ST2)));
return make_fixnum(get_fixnum(ST1) & get_fixnum(ST2)); case 0x21: return make_float(pow(get_float(ST1), get_float(ST2)));
case 0x10: case 0x22: return make_float(ldexp(get_float(ST1), get_fixnum(ST2)));
return make_fixnum(get_fixnum(ST1) | get_fixnum(ST2)); case 0x23: return make_float(fmod(get_float(ST1), get_float(ST2)));
case 0x11: case 0x24: return make_float(hypot(get_float(ST1), get_float(ST2)));
return make_fixnum(get_fixnum(ST1) ^ get_fixnum(ST2)); case 0x25: return make_float(jn(get_fixnum(ST1), get_float(ST2)));
case 0x12: case 0x26: return make_float(yn(get_fixnum(ST1), get_float(ST2)));
return make_fixnum(get_fixnum(ST1) << get_fixnum(ST2)); case 0x27: return make_float(nextafter(get_float(ST1), get_float(ST2)));
case 0x13: case 0x28: return make_float(remainder(get_float(ST1), get_float(ST2)));
return make_fixnum(get_fixnum(ST1) >> get_fixnum(ST2)); case 0x29: return make_float(scalb(get_float(ST1), get_float(ST2)));
case 0x14: default: release_assert(NOTREACHED("Invalid byte-code!"));
return make_fixnum((unsigned long)get_fixnum(ST1) >> get_fixnum(ST2));
case 0x15 ... 0x24:
return UNDEFINED;
default:
abort();
} }
return UNDEFINED; 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) static value_t eval_unary_expression(interp_state_t *state, uint8_t subcode, uint8_t in)
{ {
if (subcode == 0) release_assert(subcode != 0);
{
abort();
}
ST1 = get_input(state, in); ST1 = get_input(state, in);
switch (subcode) switch (subcode)
{ {
case 0x01: case 0x01: return ST1;
return ST1; case 0x02: return get_box(ST1)->value;
case 0x02: case 0x03: return get_pair(ST1)->car;
return get_pair(ST1)->car; case 0x04: return get_pair(ST1)->cdr;
case 0x03: case 0x08: return boolean_value(is_boolean(ST1));
return get_pair(ST1)->cdr; case 0x09: return boolean_value(is_fixnum(ST1));
case 0x04: case 0x0a: return boolean_value(is_box(ST1));
return get_box(ST1)->value; case 0x0b: return boolean_value(is_pair(ST1));
case 0x05: case 0x0c: return boolean_value(is_vector(ST1));
return make_boolean(is_false(ST1)); case 0x0d: return boolean_value(is_byte_string(ST1));
case 0x06: case 0x0e: return boolean_value(is_struct(ST1));
return make_boolean(is_nil(ST1)); case 0x0f: return boolean_value(is_float(ST1));
case 0x07: case 0x10: return boolean_value(is_builtin_fn(ST1));
return make_boolean(is_pair(ST1)); case 0x18: return make_box(ST1);
case 0x08: case 0x19: {
return make_boolean(is_box(ST1)); vector_t *vec;
case 0x09: release_assert(struct_is_a(ST1, structure_type_root.value));
return make_boolean(is_vector(ST1)); vec = get_vector(_SLOT_VALUE(STRUCTURE, ST1, SLOTS));
case 0x0a: return make_struct(ST1, vec->size);
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 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) 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) switch (code)
{ {
case 0x40: case 0x40: get_box(ST1)->value = ST2; break;
get_box(ST1)->value = ST2; case 0x41: get_pair(ST1)->car = ST2; break;
break; case 0x42: get_pair(ST1)->cdr = ST2; break;
case 0x41: case 0x60: vector_set(ST1, get_fixnum(ST2), ST3); break;
get_pair(ST1)->car = ST2; case 0x61: byte_string_set(ST1, get_fixnum(ST2), (char)get_fixnum(ST3)); break;
break; case 0x62: struct_set(ST1, get_fixnum(ST2), ST3); 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);
} }
} }
static value_t get_input(const interp_state_t *state, fixnum_t var) static value_t get_input(const interp_state_t *state, fixnum_t var)
{ {
release_assert((var >= 0) && (var <= 255));
switch (var) switch (var)
{ {
case 0: 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)); vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, GLOBAL_VARS));
var -= 1; var -= 1;
if (var >= vec->size) release_assert(var < vec->size);
abort();
return vec->elements[var]; return vec->elements[var];
} }
case 64 ... 127: 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)); vector_t *vec = get_vector(_LAMBDA_SLOT(state->lambda.value, INSTANCE_VARS));
var -= 64; var -= 64;
if (var >= vec->size) release_assert(var < vec->size);
abort();
return vec->elements[var]; return vec->elements[var];
} }
case 128 ... 247: 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); vector_t *vec = _get_vector(state->frame.value);
var -= 128; var -= 128;
if (var >= vec->size) release_assert(var < vec->size);
abort();
return vec->elements[var]; return vec->elements[var];
} }
/* 248 ... 252 are reserved */ /* 248 ... 252 are reserved */
@ -513,7 +510,7 @@ static value_t get_input(const interp_state_t *state, fixnum_t var)
case 255: case 255:
return state->ctx.value; return state->ctx.value;
default: 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); vector_t *vec = _get_vector(state->frame.value);
/* Only frame variables can be output targets for bytecode instructions. */ /* Only frame variables can be output targets for bytecode instructions. */
if (var < 128 || var >= (128 + vec->size)) release_assert((var >= 128) && (var <= 255));
abort();
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) static void register_state(interp_state_t *state, value_t lambda, value_t argv)
{ {
register_gc_root(&state->lambda, lambda); 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->argv, argv);
register_gc_root(&state->k, NIL); register_gc_root(&state->k, FALSE_VALUE);
register_gc_root(&state->ctx, NIL); register_gc_root(&state->ctx, FALSE_VALUE);
register_gc_root(&state->in1, NIL); register_gc_root(&state->in1, FALSE_VALUE);
register_gc_root(&state->in2, NIL); register_gc_root(&state->in2, FALSE_VALUE);
register_gc_root(&state->in3, NIL); register_gc_root(&state->in3, FALSE_VALUE);
} }
static void unregister_state(interp_state_t *state) static void unregister_state(interp_state_t *state)

15
interp.h
View File

@ -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 #ifndef INTERP_H_9c7eea5c5cd0f7a32b79a8ca0ab2969f
#define 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); void interpreter_init(void);
value_t run_interpreter(value_t lambda, value_t argv); value_t run_interpreter(value_t lambda, value_t argv);