GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-21 18:59:32 -06:00
Code Issues Packages Projects Releases Wiki Activity

a major revision of the bytecode generator and JIT compiler. the effect is that now we can compute with lambda functions and with true tail recursion

Browse Source
This commit is contained in:
kr.angelov
2014-09-11 15:39:39 +00:00
parent a0d75d0ea8
commit 923ad6b3c0
10 changed files with 433 additions and 276 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
src/runtime/c/pgf/data.h
View File

@@ -105,27 +105,18 @@ typedef struct {
typedef enum {
PGF_INSTR_ENTER,
PGF_INSTR_EVAL_ARG_VAR,
PGF_INSTR_EVAL_FREE_VAR,
PGF_INSTR_CASE,
PGF_INSTR_CASE_INT,
PGF_INSTR_CASE_STR,
PGF_INSTR_CASE_FLT,
PGF_INSTR_CASE_LIT,
PGF_INSTR_ALLOC,
PGF_INSTR_PUT_CONSTR,
PGF_INSTR_PUT_FUN,
PGF_INSTR_PUT_CLOSURE,
PGF_INSTR_PUT_INT,
PGF_INSTR_PUT_STR,
PGF_INSTR_PUT_FLT,
PGF_INSTR_SET_VALUE,
PGF_INSTR_SET_ARG_VAR,
PGF_INSTR_SET_FREE_VAR,
PGF_INSTR_PUT_LIT,
PGF_INSTR_SET,
PGF_INSTR_SET_PAD,
PGF_INSTR_PUSH_VALUE,
PGF_INSTR_PUSH_ARG_VAR,
PGF_INSTR_PUSH_FREE_VAR,
PGF_INSTR_TAIL_CALL,
PGF_INSTR_PUSH,
PGF_INSTR_EVAL,
PGF_INSTR_CALL,
PGF_INSTR_FAIL,
PGF_INSTR_UPDATE,
PGF_INSTR_RET

11
src/runtime/c/pgf/evaluator.c
View File

@@ -268,6 +268,17 @@ pgf_evaluate_save_variables(PgfEvalState* state, PgfValue* val)
}
}
void
pgf_evaluate_slide(PgfEvalState* state, size_t a, size_t b)
{
size_t len = gu_buf_length(state->stack);
for (size_t i = 0; i < b-a; i++) {
PgfClosure* c = gu_buf_get(state->stack, PgfClosure*, len-(b-a)+i);
gu_buf_set(state->stack, PgfClosure*, len-b+i, c);
}
gu_buf_trim_n(state->stack, a);
}
static PgfExpr
pgf_value2expr(PgfEvalState* state, int level, PgfClosure* clos, GuPool* pool)
{

3
src/runtime/c/pgf/evaluator.h
View File

@@ -32,4 +32,7 @@ pgf_evaluate_value(PgfEvalState* state, PgfClosure* closure);
void
pgf_evaluate_save_variables(PgfEvalState* state, PgfValue* val);
void
pgf_evaluate_slide(PgfEvalState* state, size_t a, size_t b);
#endif

403
src/runtime/c/pgf/jit.c
View File

@@ -317,6 +317,29 @@ pgf_jit_predicate(PgfReader* rdr, PgfAbstr* abstr,
#endif
}
static void
pgf_jit_compile_slide(PgfReader* rdr, int es_arg, size_t a, size_t b)
{
if (a == b) {
jit_prepare(2);
jit_movi_i(JIT_V1, a);
jit_pusharg_p(JIT_V1);
jit_getarg_p(JIT_V1, es_arg);
jit_ldxi_p(JIT_V1, JIT_V1, offsetof(PgfEvalState,stack));
jit_pusharg_p(JIT_V1);
jit_finish(gu_buf_trim_n);
} else {
jit_prepare(3);
jit_movi_i(JIT_V1, b);
jit_pusharg_p(JIT_V1);
jit_movi_i(JIT_V1, a);
jit_pusharg_p(JIT_V1);
jit_getarg_p(JIT_V1, es_arg);
jit_pusharg_p(JIT_V1);
jit_finish(pgf_evaluate_slide);
}
}
void
pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
PgfAbsFun* absfun)
@@ -371,7 +394,9 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
gu_printf(out, err, " ");
#endif
uint8_t opcode = pgf_read_tag(rdr);
uint8_t tag = pgf_read_tag(rdr);
uint8_t opcode = tag >> 3;
uint8_t mod = tag & 0x07;
switch (opcode) {
case PGF_INSTR_ENTER: {
#ifdef PGF_JIT_DEBUG
@@ -383,40 +408,11 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
closure_arg = jit_arg_p();
break;
}
case PGF_INSTR_EVAL_ARG_VAR: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "EVAL_ARG_VAR %d\n", index);
#endif
jit_getarg_p(JIT_V0, es_arg);
jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
jit_prepare(1);
jit_pusharg_p(JIT_V0);
jit_finish(gu_buf_last);
jit_ldxi_p(JIT_V0, JIT_RET, -index*sizeof(PgfClosure*));
jit_prepare(2);
jit_pusharg_p(JIT_V0);
jit_getarg_p(JIT_V2, es_arg);
jit_pusharg_p(JIT_V2);
jit_ldr_p(JIT_V0, JIT_V0);
jit_finishr(JIT_V0);
jit_retval_p(JIT_V1);
jit_ldxi_p(JIT_V0, JIT_V1, offsetof(PgfValue, absfun));
break;
}
case PGF_INSTR_EVAL_FREE_VAR: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "EVAL_FREE_VAR %d\n", index);
#endif
break;
}
case PGF_INSTR_CASE: {
PgfCId id = pgf_read_cid(rdr, rdr->opool);
int target = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "CASE %s %03d\n", id, target);
gu_printf(out, err, "CASE %s %03d\n", id, target);
#endif
jit_insn *jump=
jit_bnei_i(jit_forward(), JIT_V0, (int) jit_forward());
@@ -439,34 +435,41 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
jit_finish(pgf_evaluate_save_variables);
break;
}
case PGF_INSTR_CASE_INT: {
int n = pgf_read_int(rdr);
int target = pgf_read_int(rdr);
case PGF_INSTR_CASE_LIT: {
switch (mod) {
case 0: {
int n = pgf_read_int(rdr);
int target = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "CASE_INT %d %03d\n", n, target);
gu_printf(out, err, "CASE_LIT %d %03d\n", n, target);
#endif
break;
}
case PGF_INSTR_CASE_STR: {
GuString s = pgf_read_string(rdr);
int target = pgf_read_int(rdr);
break;
}
case 1: {
GuString s = pgf_read_string(rdr);
int target = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "CASE_STR %s %03d\n", s, target);
gu_printf(out, err, "CASE_LIT %s %03d\n", s, target);
#endif
break;
}
case PGF_INSTR_CASE_FLT: {
double d = pgf_read_double(rdr);
int target = pgf_read_int(rdr);
break;
}
case 2: {
double d = pgf_read_double(rdr);
int target = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "CASE_FLT %f %03d\n", d, target);
gu_printf(out, err, "CASE_LIT %f %03d\n", d, target);
#endif
break;
}
default:
gu_impossible();
}
break;
}
case PGF_INSTR_ALLOC: {
size_t size = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "ALLOC %d\n", size);
gu_printf(out, err, "ALLOC %d\n", size);
#endif
jit_prepare(2);
jit_movi_ui(JIT_V0, size*sizeof(void*));
@@ -483,7 +486,7 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
case PGF_INSTR_PUT_CONSTR: {
PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUT_CONSTR %s\n", id);
gu_printf(out, err, "PUT_CONSTR %s\n", id);
#endif
jit_movi_p(JIT_V0, pgf_evaluate_value);
@@ -502,7 +505,7 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
case PGF_INSTR_PUT_FUN: {
PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUT_FUN %s\n", id);
gu_printf(out, err, "PUT_FUN %s\n", id);
#endif
PgfCallPatch patch;
@@ -518,7 +521,7 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
case PGF_INSTR_PUT_CLOSURE: {
size_t target = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUT_CLOSURE %03d\n", target);
gu_printf(out, err, "PUT_CLOSURE %03d\n", target);
#endif
PgfSegmentPatch patch;
@@ -531,62 +534,72 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
gu_buf_push(rdr->jit_state->segment_patches, PgfSegmentPatch, patch);
break;
}
case PGF_INSTR_PUT_INT: {
size_t n = pgf_read_int(rdr);
case PGF_INSTR_PUT_LIT: {
switch (mod) {
case 0: {
size_t n = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUT_INT %d\n", n);
gu_printf(out, err, "PUT_LIT %d\n", n);
#endif
break;
}
case 1: {
GuString s = pgf_read_string(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUT_LIT \"%s\"\n", s);
#endif
break;
}
case 2: {
double d = pgf_read_double(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUT_LIT %f\n", d);
#endif
break;
}
default:
gu_impossible();
}
break;
}
case PGF_INSTR_PUT_STR: {
size_t addr = pgf_read_int(rdr);
case PGF_INSTR_SET: {
switch (mod) {
case 0: {
size_t offset = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUT_STR %d\n", addr);
gu_printf(out, err, "SET hp(%d)\n", offset);
#endif
break;
}
case PGF_INSTR_PUT_FLT: {
size_t addr = pgf_read_int(rdr);
jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*));
break;
}
case 1: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUT_FLT %d\n", addr);
gu_printf(out, err, "SET stk(%d)\n", index);
#endif
jit_getarg_p(JIT_V0, es_arg);
jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
jit_prepare(1);
jit_pusharg_p(JIT_V0);
jit_finish(gu_buf_last);
jit_ldxi_p(JIT_V0, JIT_RET, -index*sizeof(PgfClosure*));
break;
}
case 2: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "SET env(%d)\n", index);
#endif
jit_getarg_p(JIT_V0, closure_arg);
jit_ldxi_p(JIT_V0, JIT_V0, sizeof(PgfClosure)+index*sizeof(PgfClosure*));
break;
}
default:
gu_impossible();
}
break;
}
case PGF_INSTR_SET_VALUE: {
size_t offset = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "SET_VALUE %d\n", offset);
#endif
jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*));
jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0);
curr_offset++;
break;
}
case PGF_INSTR_SET_ARG_VAR: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "SET_ARG_VAR %d\n", index);
#endif
jit_getarg_p(JIT_V0, es_arg);
jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
jit_prepare(1);
jit_pusharg_p(JIT_V0);
jit_finish(gu_buf_last);
jit_ldxi_p(JIT_V0, JIT_RET, -index*sizeof(PgfClosure*));
jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0);
curr_offset++;
break;
}
case PGF_INSTR_SET_FREE_VAR: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "SET_FREE_VAR %d\n", index);
#endif
jit_getarg_p(JIT_V0, closure_arg);
jit_ldxi_p(JIT_V0, JIT_V0, sizeof(PgfClosure)+index*sizeof(PgfClosure*));
jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0);
curr_offset++;
break;
@@ -600,76 +613,174 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
curr_offset++;
break;
}
case PGF_INSTR_PUSH_VALUE: {
size_t offset = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUSH_VALUE %d\n", offset);
#endif
case PGF_INSTR_PUSH: {
jit_getarg_p(JIT_V0, es_arg);
jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
jit_prepare(1);
jit_pusharg_p(JIT_V0);
jit_finish(gu_buf_extend);
if (offset == 0) {
jit_str_p(JIT_RET, JIT_V1);
} else {
jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*));
switch (mod) {
case 0: {
size_t offset = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUSH hp(%d)\n", offset);
#endif
if (offset == 0) {
jit_str_p(JIT_RET, JIT_V1);
} else {
jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*));
jit_str_p(JIT_RET, JIT_V0);
}
break;
}
case 1: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUSH stk(%d)\n", index);
#endif
jit_ldxi_p(JIT_V0, JIT_RET, -(index+1)*sizeof(PgfClosure*));
jit_str_p(JIT_RET, JIT_V0);
break;
}
case 2: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUSH env(%d)\n", index);
#endif
jit_getarg_p(JIT_V0, closure_arg);
jit_ldxi_p(JIT_V0, JIT_V0, sizeof(PgfClosure)+index*sizeof(PgfClosure*));
jit_str_p(JIT_RET, JIT_V0);
break;
}
default:
gu_impossible();
}
break;
}
case PGF_INSTR_PUSH_ARG_VAR: {
size_t index = pgf_read_int(rdr);
case PGF_INSTR_EVAL: {
switch (mod & 0x3) {
case 0: {
size_t offset = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUSH_ARG_VAR %d\n", index);
gu_printf(out, err, "EVAL hp(%d)", offset);
#endif
jit_getarg_p(JIT_V0, es_arg);
jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
jit_prepare(1);
jit_pusharg_p(JIT_V0);
jit_finish(gu_buf_extend);
jit_ldxi_p(JIT_V0, JIT_RET, -(index+1)*sizeof(PgfClosure*));
jit_str_p(JIT_RET, JIT_V0);
break;
}
case PGF_INSTR_PUSH_FREE_VAR: {
size_t index = pgf_read_int(rdr);
jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*));
break;
}
case 1: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUSH_FREE_VAR %d\n", index);
gu_printf(out, err, "EVAL stk(%d)", index);
#endif
jit_getarg_p(JIT_V0, es_arg);
jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
jit_prepare(1);
jit_pusharg_p(JIT_V0);
jit_finish(gu_buf_extend);
jit_getarg_p(JIT_V0, closure_arg);
jit_ldxi_p(JIT_V0, JIT_V0, sizeof(PgfClosure)+index*sizeof(PgfClosure*));
jit_str_p(JIT_RET, JIT_V0);
jit_getarg_p(JIT_V0, es_arg);
jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
jit_prepare(1);
jit_pusharg_p(JIT_V0);
jit_finish(gu_buf_last);
jit_ldxi_p(JIT_V0, JIT_RET, -index*sizeof(PgfClosure*));
break;
}
case 2: {
size_t index = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "EVAL env(%d)", index);
#endif
break;
}
default:
gu_impossible();
}
switch (mod >> 2) {
case 0: {
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "\n");
#endif
jit_prepare(2);
jit_pusharg_p(JIT_V0);
jit_getarg_p(JIT_V2, es_arg);
jit_pusharg_p(JIT_V2);
jit_ldr_p(JIT_V0, JIT_V0);
jit_finishr(JIT_V0);
jit_retval_p(JIT_V1);
jit_ldxi_p(JIT_V0, JIT_V1, offsetof(PgfValue, absfun));
break;
}
case 1: {
size_t a = pgf_read_int(rdr);
size_t b = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, " tail(%d,%d)\n", a, b);
#endif
pgf_jit_compile_slide(rdr, es_arg, a, b);
jit_setarg_p(JIT_V0, closure_arg);
jit_ldr_p(JIT_RET, JIT_V0);
jit_tail_finishr(JIT_RET);
break;
}
default:
gu_impossible();
}
break;
}
case PGF_INSTR_TAIL_CALL: {
case PGF_INSTR_CALL: {
PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "TAIL_CALL %s\n", id);
gu_printf(out, err, "CALL %s", id);
#endif
jit_getarg_p(JIT_V0, es_arg);
jit_getarg_p(JIT_V1, closure_arg);
jit_prepare(2);
jit_pusharg_p(JIT_V1);
jit_pusharg_p(JIT_V0);
switch (mod >> 2) {
case 0: {
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "\n");
#endif
PgfCallPatch patch;
patch.cid = id;
patch.ref = jit_movi_p(JIT_V0, jit_forward());
gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, patch);
jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfAbsFun,function));
jit_getarg_p(JIT_V0, es_arg);
jit_getarg_p(JIT_V1, closure_arg);
jit_prepare(2);
jit_pusharg_p(JIT_V1);
jit_pusharg_p(JIT_V0);
jit_finishr(JIT_V0);
jit_retval_p(JIT_V1);
PgfCallPatch patch;
patch.cid = id;
patch.ref = jit_movi_p(JIT_V0, jit_forward());
gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, patch);
jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfAbsFun,function));
jit_finishr(JIT_V0);
jit_retval_p(JIT_V1);
break;
}
case 1: {
size_t a = pgf_read_int(rdr);
size_t b = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, " tail(%d,%d)\n", a, b);
#endif
pgf_jit_compile_slide(rdr, es_arg, a, b);
PgfCallPatch patch;
patch.cid = id;
patch.ref = jit_movi_p(JIT_V0, jit_forward());
gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, patch);
jit_ldxi_p(JIT_RET, JIT_V0, offsetof(PgfAbsFun,function));
jit_tail_finishr(JIT_RET);
break;
}
default:
gu_impossible();
}
break;
}
case PGF_INSTR_FAIL:
@@ -692,7 +803,7 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
size_t count = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "RET %d\n", count);
gu_printf(out, err, "RET %d\n", count);
#endif
if (count > 0) {

6
src/runtime/c/pgf/lightning/core-common.h
View File

@@ -474,6 +474,12 @@ typedef union jit_code {
#endif
#endif
#ifndef jit_setarg_p
#ifdef JIT_FP
#define jit_setarg_p(reg, ofs) jit_stxi_p((ofs), JIT_FP, (reg));
#endif
#endif
/* Common definitions when sizeof(long) = sizeof(int) */
#ifndef jit_addi_l

10
src/runtime/c/pgf/lightning/i386/core-32.h
View File

@@ -108,6 +108,16 @@ struct jit_local_state {
#define jit_finish(sub) (_jitl.finish_ref = jit_calli((sub)), ADDLir(sizeof(long) * _jitl.argssize, JIT_SP), _jitl.argssize = 0, _jitl.finish_ref)
#define jit_finishr(reg) (jit_callr((reg)), ADDLir(sizeof(long) * _jitl.argssize, JIT_SP), _jitl.argssize = 0)
#ifdef __APPLE__
#define jit_tail_finishr(reg) jit_base_tail_finishr(-12, reg)
#else
#define jit_tail_finishr(reg) jit_base_tail_finishr(_jitl.alloca_offset, reg)
#endif
#define jit_base_tail_finishr(ofs, reg) \
(((ofs) < 0 ? LEAVE_() : POPLr(_EBP)), \
POPLr(_EDI), POPLr(_ESI), POPLr(_EBX), jit_jmpr(reg))
#define jit_arg_c() ((_jitl.framesize += sizeof(int)) - sizeof(int))
#define jit_arg_uc() ((_jitl.framesize += sizeof(int)) - sizeof(int))
#define jit_arg_s() ((_jitl.framesize += sizeof(int)) - sizeof(int))

56
src/runtime/haskell/PGF/Binary.hs
View File

@@ -136,32 +136,36 @@ instance Binary Equation where
get = liftM2 Equ get get
instance Binary Instr where
put (ENTER ) = putWord8 0
put (EVAL_ARG_VAR n) = putWord8 1 >> put n
put (EVAL_FREE_VAR n)= putWord8 2 >> put n
put (CASE id l ) = putWord8 3 >> put (id,l)
put (CASE_INT n l ) = putWord8 4 >> put (n,l)
put (CASE_STR s l ) = putWord8 5 >> put (s,l)
put (CASE_FLT d l ) = putWord8 6 >> put (d,l)
put (ALLOC n) = putWord8 7 >> put n
put (PUT_CONSTR id) = putWord8 8 >> put id
put (PUT_FUN id) = putWord8 9 >> put id
put (PUT_CLOSURE l) = putWord8 10 >> put l
put (PUT_INT n) = putWord8 11 >> put n
put (PUT_STR s) = putWord8 12 >> put s
put (PUT_FLT d) = putWord8 13 >> put d
put (SET_VALUE n) = putWord8 14 >> put n
put (SET_ARG_VAR n) = putWord8 15 >> put n
put (SET_FREE_VAR n) = putWord8 16 >> put n
put (SET_PAD ) = putWord8 17
put (PUSH_VALUE n) = putWord8 18 >> put n
put (PUSH_ARG_VAR n) = putWord8 19 >> put n
put (PUSH_FREE_VAR n)= putWord8 20 >> put n
put (TAIL_CALL id) = putWord8 21 >> put id
put (FAIL ) = putWord8 22
put (UPDATE ) = putWord8 23
put (RET n) = putWord8 24 >> put n
put (ENTER ) = putWord8 0
put (CASE id l ) = putWord8 8 >> put (id,l)
put (CASE_LIT (LInt n) l) = putWord8 16 >> put (n,l)
put (CASE_LIT (LStr s) l) = putWord8 17 >> put (s,l)
put (CASE_LIT (LFlt d) l) = putWord8 18 >> put (d,l)
put (ALLOC n) = putWord8 24 >> put n
put (PUT_CONSTR id) = putWord8 32 >> put id
put (PUT_FUN id) = putWord8 40 >> put id
put (PUT_CLOSURE l) = putWord8 48 >> put l
put (PUT_LIT (LInt n)) = putWord8 56 >> put n
put (PUT_LIT (LStr s)) = putWord8 57 >> put s
put (PUT_LIT (LFlt d)) = putWord8 58 >> put d
put (SET (HEAP n)) = putWord8 64 >> put n
put (SET (ARG_VAR n)) = putWord8 65 >> put n
put (SET (FREE_VAR n)) = putWord8 66 >> put n
put (SET_PAD ) = putWord8 72
put (PUSH (HEAP n)) = putWord8 80 >> put n
put (PUSH (ARG_VAR n)) = putWord8 81 >> put n
put (PUSH (FREE_VAR n)) = putWord8 82 >> put n
put (EVAL (HEAP n) RecCall ) = putWord8 88 >> put n
put (EVAL (ARG_VAR n) RecCall ) = putWord8 89 >> put n
put (EVAL (FREE_VAR n) RecCall ) = putWord8 90 >> put n
put (EVAL (HEAP n) (TailCall a b)) = putWord8 92 >> put n >> put a >> put b
put (EVAL (ARG_VAR n) (TailCall a b)) = putWord8 93 >> put n >> put a >> put b
put (EVAL (FREE_VAR n) (TailCall a b)) = putWord8 94 >> put n >> put a >> put b
put (CALL id RecCall ) = putWord8 96 >> put id
put (CALL id (TailCall a b)) = putWord8 100 >> put id >> put a >> put b
put (FAIL ) = putWord8 104
put (UPDATE ) = putWord8 112
put (RET n) = putWord8 120 >> put n
instance Binary Type where
put (DTyp hypos cat exps) = put (hypos,cat,exps)

85
src/runtime/haskell/PGF/ByteCode.hs
View File

@@ -1,65 +1,76 @@
module PGF.ByteCode(CodeLabel, Instr(..), ppCode, ppInstr) where
module PGF.ByteCode(Literal(..),
CodeLabel, Instr(..), IVal(..), TailInfo(..),
ppLit, ppCode, ppInstr
) where
import PGF.CId
import Text.PrettyPrint
data Literal =
LStr String -- ^ string constant
| LInt Int -- ^ integer constant
| LFlt Double -- ^ floating point constant
deriving (Eq,Ord,Show)
type CodeLabel = Int
data Instr
= ENTER
| EVAL_ARG_VAR {-# UNPACK #-} !Int
| EVAL_FREE_VAR {-# UNPACK #-} !Int
| CASE CId {-# UNPACK #-} !CodeLabel
| CASE_INT Int {-# UNPACK #-} !CodeLabel
| CASE_STR String {-# UNPACK #-} !CodeLabel
| CASE_FLT Double {-# UNPACK #-} !CodeLabel
| CASE_LIT Literal {-# UNPACK #-} !CodeLabel
| ALLOC {-# UNPACK #-} !Int
| PUT_CONSTR CId
| PUT_FUN CId
| PUT_CLOSURE {-# UNPACK #-} !CodeLabel
| PUT_INT {-# UNPACK #-} !Int
| PUT_STR String
| PUT_FLT {-# UNPACK #-} !Double
| SET_VALUE {-# UNPACK #-} !Int
| SET_ARG_VAR {-# UNPACK #-} !Int
| SET_FREE_VAR {-# UNPACK #-} !Int
| PUT_LIT Literal
| SET IVal
| SET_PAD
| PUSH_VALUE {-# UNPACK #-} !Int
| PUSH_ARG_VAR {-# UNPACK #-} !Int
| PUSH_FREE_VAR {-# UNPACK #-} !Int
| TAIL_CALL CId
| PUSH IVal
| EVAL IVal TailInfo
| CALL CId TailInfo
| FAIL
| UPDATE
| RET {-# UNPACK #-} !Int
data IVal
= HEAP {-# UNPACK #-} !Int
| ARG_VAR {-# UNPACK #-} !Int
| FREE_VAR {-# UNPACK #-} !Int
data TailInfo
= RecCall
| TailCall {-# UNPACK #-} !Int {-# UNPACK #-} !Int
ppLit (LStr s) = text (show s)
ppLit (LInt n) = int n
ppLit (LFlt d) = double d
ppCode :: Int -> [[Instr]] -> Doc
ppCode l [] = empty
ppCode l (is:iss) = ppLabel l <+> vcat (map ppInstr is) $$ ppCode (l+1) iss
ppInstr (ENTER ) = text "ENTER"
ppInstr (EVAL_ARG_VAR n) = text "EVAL_ARG_VAR " <+> int n
ppInstr (EVAL_FREE_VAR n) = text "EVAL_FREE_VAR" <+> int n
ppInstr (CASE id l ) = text "CASE " <+> ppCId id <+> ppLabel l
ppInstr (CASE_INT n l ) = text "CASE_INT " <+> int n <+> ppLabel l
ppInstr (CASE_STR str l ) = text "CASE_STR " <+> text (show str) <+> ppLabel l
ppInstr (CASE_FLT d l ) = text "CASE_FLT " <+> double d <+> ppLabel l
ppInstr (ALLOC n) = text "ALLOC " <+> int n
ppInstr (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id
ppInstr (PUT_FUN id) = text "PUT_FUN " <+> ppCId id
ppInstr (PUT_CLOSURE l) = text "PUT_CLOSURE " <+> ppLabel l
ppInstr (PUT_INT n ) = text "PUT_INT " <+> int n
ppInstr (PUT_STR str ) = text "PUT_STR " <+> text (show str)
ppInstr (PUT_FLT d ) = text "PUT_FLT " <+> double d
ppInstr (SET_VALUE n) = text "SET_VALUE " <+> int n
ppInstr (SET_ARG_VAR n) = text "SET_ARG_VAR " <+> int n
ppInstr (SET_FREE_VAR n) = text "SET_FREE_VAR " <+> int n
ppInstr (CASE id l ) = text "CASE " <+> ppCId id <+> ppLabel l
ppInstr (CASE_LIT lit l ) = text "CASE_LIT " <+> ppLit lit <+> ppLabel l
ppInstr (ALLOC n) = text "ALLOC " <+> int n
ppInstr (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id
ppInstr (PUT_FUN id) = text "PUT_FUN " <+> ppCId id
ppInstr (PUT_CLOSURE l) = text "PUT_CLOSURE" <+> ppLabel l
ppInstr (PUT_LIT lit ) = text "PUT_LIT " <+> ppLit lit
ppInstr (SET v) = text "SET " <+> ppIVal v
ppInstr (SET_PAD ) = text "SET_PAD"
ppInstr (PUSH_VALUE n) = text "PUSH_VALUE " <+> int n
ppInstr (PUSH_ARG_VAR n) = text "PUSH_ARG_VAR " <+> int n
ppInstr (PUSH_FREE_VAR n) = text "PUSH_FREE_VAR" <+> int n
ppInstr (TAIL_CALL id) = text "TAIL_CALL " <+> ppCId id
ppInstr (PUSH v) = text "PUSH " <+> ppIVal v
ppInstr (EVAL v ti) = text "EVAL " <+> ppIVal v <+> ppTailInfo ti
ppInstr (CALL v ti) = text "CALL " <+> ppCId v <+> ppTailInfo ti
ppInstr (FAIL ) = text "FAIL"
ppInstr (UPDATE ) = text "UPDATE"
ppInstr (RET n) = text "RET " <+> int n
ppInstr (RET n) = text "RET " <+> int n
ppIVal (HEAP n) = text "hp" <> parens (int n)
ppIVal (ARG_VAR n) = text "stk" <> parens (int n)
ppIVal (FREE_VAR n) = text "env" <> parens (int n)
ppTailInfo RecCall = empty
ppTailInfo (TailCall a b) = text "tail" <> parens (int a <> comma <> int b)
ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s)

10
src/runtime/haskell/PGF/Expr.hs
View File

@@ -31,12 +31,6 @@ import Control.Monad
import qualified Text.PrettyPrint as PP
import qualified Text.ParserCombinators.ReadP as RP
data Literal =
LStr String -- ^ string constant
| LInt Int -- ^ integer constant
| LFlt Double -- ^ floating point constant
deriving (Eq,Ord,Show)
type MetaId = Int
data BindType =
@@ -274,10 +268,6 @@ pattScope scope (PTilde e) = scope
ppBind Explicit x = ppCId x
ppBind Implicit x = PP.braces (ppCId x)
ppLit (LStr s) = PP.text (show s)
ppLit (LInt n) = PP.int n
ppLit (LFlt d) = PP.double d
ppMeta :: MetaId -> PP.Doc
ppMeta n
| n == 0 = PP.char '?'