From 584d589041f63fdd3ea777019679275657902c2d Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Mon, 11 Aug 2014 10:59:10 +0000 Subject: a partial support for def rules in the C runtime The def rules are now compiled to byte code by the compiler and then to native code by the JIT compiler in the runtime. Not all constructions are implemented yet. The partial implementation is now in the repository but it is not activated by default since this requires changes in the PGF format. I will enable it only after it is complete. --- src/runtime/c/Makefile.am | 1 - src/runtime/c/pgf/data.h | 20 ++ src/runtime/c/pgf/evaluator.c | 44 ++-- src/runtime/c/pgf/jit.c | 386 +++++++++++++++++++++++++------ src/runtime/c/pgf/jit.h | 16 -- src/runtime/c/pgf/pgf.h | 32 +-- src/runtime/c/pgf/reader.c | 72 +++--- src/runtime/c/pgf/reader.h | 51 +++- src/runtime/haskell/PGF.hs | 32 +-- src/runtime/haskell/PGF/Binary.hs | 32 ++- src/runtime/haskell/PGF/ByteCode.hs | 47 ++++ src/runtime/haskell/PGF/Data.hs | 19 +- src/runtime/haskell/PGF/Expr.hs | 30 +-- src/runtime/haskell/PGF/Forest.hs | 2 +- src/runtime/haskell/PGF/Internal.hs | 1 + src/runtime/haskell/PGF/Linearize.hs | 2 +- src/runtime/haskell/PGF/Macros.hs | 17 +- src/runtime/haskell/PGF/OldBinary.hs | 6 +- src/runtime/haskell/PGF/Paraphrase.hs | 2 +- src/runtime/haskell/PGF/Printer.hs | 25 +- src/runtime/haskell/PGF/Probabilistic.hs | 20 +- src/runtime/haskell/PGF/SortTop.hs | 6 +- src/runtime/haskell/PGF/TypeCheck.hs | 12 +- src/runtime/java/Test.java | 23 +- 24 files changed, 593 insertions(+), 305 deletions(-) delete mode 100644 src/runtime/c/pgf/jit.h create mode 100644 src/runtime/haskell/PGF/ByteCode.hs (limited to 'src/runtime') diff --git a/src/runtime/c/Makefile.am b/src/runtime/c/Makefile.am index 75bd0a253..c7abd96cb 100644 --- a/src/runtime/c/Makefile.am +++ b/src/runtime/c/Makefile.am @@ -33,7 +33,6 @@ guinclude_HEADERS = \ pgfincludedir=$(includedir)/pgf pgfinclude_HEADERS = \ pgf/expr.h \ - pgf/reader.h \ pgf/linearizer.h \ pgf/parser.h \ pgf/literals.h \ diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index d75b17f85..552856995 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -76,6 +76,7 @@ typedef struct { PgfEquations* defns; // maybe null PgfExprProb ep; void* predicate; + void* function; } PgfAbsFun; extern GU_DECLARE_TYPE(PgfAbsFun, abstract); @@ -102,6 +103,25 @@ typedef struct { PgfAbsFun* abs_lin_fun; } PgfAbstr; +typedef enum { + PGF_INSTR_EVAL, + PGF_INSTR_CASE, + PGF_INSTR_CASE_INT, + PGF_INSTR_CASE_STR, + PGF_INSTR_CASE_FLT, + PGF_INSTR_ALLOC, + PGF_INSTR_PUT_CONSTR, + PGF_INSTR_PUT_CLOSURE, + PGF_INSTR_PUT_INT, + PGF_INSTR_PUT_STR, + PGF_INSTR_PUT_FLT, + PGF_INSTR_SET_VALUE, + PGF_INSTR_SET_VARIABLE, + PGF_INSTR_TAIL_CALL, + PGF_INSTR_FAIL, + PGF_INSTR_RET +} PgfInstruction; + struct PgfPGF { uint16_t major_version; uint16_t minor_version; diff --git a/src/runtime/c/pgf/evaluator.c b/src/runtime/c/pgf/evaluator.c index 7c4598a86..ee2bd8511 100644 --- a/src/runtime/c/pgf/evaluator.c +++ b/src/runtime/c/pgf/evaluator.c @@ -1,17 +1,18 @@ #include "pgf/pgf.h" #include "pgf/data.h" +#include "pgf/evaluator.h" typedef struct PgfEnv PgfEnv; -typedef struct PgfClosure PgfClosure; -typedef struct PgfEvalState PgfEvalState; struct PgfEnv { PgfEnv* next; PgfClosure* closure; }; +typedef PgfClosure* (*PgfFunction)(PgfEvalState* state, PgfClosure* val); + struct PgfClosure { - PgfClosure* (*code)(PgfEvalState* state, PgfClosure* val); + PgfFunction code; }; typedef struct { @@ -28,7 +29,6 @@ typedef struct { typedef struct { PgfClosure header; PgfAbsFun* absfun; - size_t n_args; PgfClosure* args[]; } PgfValue; @@ -52,13 +52,6 @@ typedef struct { PgfLiteral lit; } PgfValueLit; -struct PgfEvalState { - PgfPGF* pgf; - GuPool* pool; - GuExn* err; - GuBuf* stack; -}; - static PgfClosure* pgf_evaluate_indirection(PgfEvalState* state, PgfClosure* closure) { @@ -66,20 +59,20 @@ pgf_evaluate_indirection(PgfEvalState* state, PgfClosure* closure) return indir->val; } -static PgfClosure* +PgfClosure* pgf_evaluate_value(PgfEvalState* state, PgfClosure* closure) { PgfValue* val = (PgfValue*) closure; - size_t n_args = val->n_args + gu_buf_length(state->stack); + size_t n_args = gu_seq_length(val->absfun->type->hypos) + + gu_buf_length(state->stack); PgfValue* new_val = gu_new_flex(state->pool, PgfValue, args, n_args); new_val->header.code = pgf_evaluate_value; new_val->absfun = val->absfun; - new_val->n_args = n_args; size_t i = 0; - while (i < val->n_args) { + while (i < gu_seq_length(val->absfun->type->hypos)) { new_val->args[i] = val->args[i]; i++; } @@ -236,15 +229,18 @@ pgf_evaluate_expr_thunk(PgfEvalState* state, PgfClosure* closure) return NULL; } - size_t n_args = gu_buf_length(state->stack); + PgfValue* val; + if (absfun->function != NULL) { + val = (PgfValue*) ((PgfFunction) absfun->function)(state, closure); + } else { + size_t n_args = gu_buf_length(state->stack); - PgfValue* val = - gu_new_flex(state->pool, PgfValue, args, n_args); - val->header.code = pgf_evaluate_value; - val->absfun = absfun; - val->n_args = n_args; - for (size_t i = 0; i < n_args; i++) { - val->args[i] = gu_buf_pop(state->stack, PgfClosure*); + val = gu_new_flex(state->pool, PgfValue, args, n_args); + val->header.code = pgf_evaluate_value; + val->absfun = absfun; + for (size_t i = 0; i < n_args; i++) { + val->args[i] = gu_buf_pop(state->stack, PgfClosure*); + } } PgfIndirection* indir = (PgfIndirection*) closure; @@ -309,7 +305,7 @@ pgf_value2expr(PgfEvalState* state, int level, PgfClosure* clos, GuPool* pool) PgfValue* val = (PgfValue*) clos; expr = val->absfun->ep.expr; - n_args = val->n_args; + n_args = gu_seq_length(val->absfun->type->hypos); args = val->args; } else if (clos->code == pgf_evaluate_value_gen) { PgfValueGen* val = (PgfValueGen*) clos; diff --git a/src/runtime/c/pgf/jit.c b/src/runtime/c/pgf/jit.c index 250b5a3a6..ba7788a1a 100644 --- a/src/runtime/c/pgf/jit.c +++ b/src/runtime/c/pgf/jit.c @@ -1,23 +1,22 @@ #include #include #include -#include #include +#include +#include #include "lightning.h" //#define PGF_JIT_DEBUG struct PgfJitState { - GuPool* tmp_pool; - GuPool* pool; jit_state jit; jit_insn *buf; char *save_ip_ptr; GuBuf* patches; }; -#define _jit (state->jit) +#define _jit (rdr->jit_state->jit) typedef struct { PgfCId cid; @@ -27,7 +26,7 @@ typedef struct { // Between two calls to pgf_jit_make_space we are not allowed // to emit more that JIT_CODE_WINDOW bytes. This is not quite // safe but this is how GNU lightning is designed. -#define JIT_CODE_WINDOW 128 +#define JIT_CODE_WINDOW 1280 typedef struct { GuFinalizer fin; @@ -42,7 +41,7 @@ pgf_jit_finalize_page(GuFinalizer* self) } static void -pgf_jit_alloc_page(PgfJitState* state) +pgf_jit_alloc_page(PgfReader* rdr) { void *page; @@ -58,46 +57,63 @@ pgf_jit_alloc_page(PgfJitState* state) gu_fatal("Memory allocation failed"); } - PgfPageFinalizer* fin = gu_new(PgfPageFinalizer, state->pool); + PgfPageFinalizer* fin = + gu_new(PgfPageFinalizer, rdr->opool); fin->fin.fn = pgf_jit_finalize_page; fin->page = page; - gu_pool_finally(state->pool, &fin->fin); + gu_pool_finally(rdr->opool, &fin->fin); - state->buf = page; - jit_set_ip(state->buf); + rdr->jit_state->buf = page; + jit_set_ip(rdr->jit_state->buf); } PgfJitState* -pgf_jit_init(GuPool* tmp_pool, GuPool* pool) +pgf_new_jit(PgfReader* rdr) { - PgfJitState* state = gu_new(PgfJitState, tmp_pool); - state->tmp_pool = tmp_pool; - state->pool = pool; - state->patches = gu_new_buf(PgfCallPatch, tmp_pool); - - pgf_jit_alloc_page(state); - state->save_ip_ptr = jit_get_ip().ptr; - + PgfJitState* state = gu_new(PgfJitState, rdr->tmp_pool); + state->patches = gu_new_buf(PgfCallPatch, rdr->tmp_pool); + state->buf = NULL; + state->save_ip_ptr = NULL; return state; } static void -pgf_jit_make_space(PgfJitState* state) +pgf_jit_make_space(PgfReader* rdr) { - assert (state->save_ip_ptr + JIT_CODE_WINDOW > jit_get_ip().ptr); - size_t page_size = getpagesize(); - if (jit_get_ip().ptr + JIT_CODE_WINDOW > ((char*) state->buf) + page_size) { - jit_flush_code(state->buf, jit_get_ip().ptr); - pgf_jit_alloc_page(state); + if (rdr->jit_state->buf == NULL) { + pgf_jit_alloc_page(rdr); + } else { + assert (rdr->jit_state->save_ip_ptr + JIT_CODE_WINDOW > jit_get_ip().ptr); + + if (jit_get_ip().ptr + JIT_CODE_WINDOW > ((char*) rdr->jit_state->buf) + page_size) { + jit_flush_code(rdr->jit_state->buf, jit_get_ip().ptr); + pgf_jit_alloc_page(rdr); + } } + + rdr->jit_state->save_ip_ptr = jit_get_ip().ptr; +} + +static PgfAbsFun* +pgf_jit_read_absfun(PgfReader* rdr, PgfAbstr* abstr) +{ + gu_in_f64be(rdr->in, rdr->err); // ignore + gu_return_on_exn(rdr->err, NULL); + + PgfCId name = pgf_read_cid(rdr, rdr->tmp_pool); + gu_return_on_exn(rdr->err, NULL); + + PgfAbsFun* absfun = + gu_map_get(abstr->funs, name, PgfAbsFun*); + assert(absfun != NULL); - state->save_ip_ptr = jit_get_ip().ptr; + return absfun; } void -pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, - PgfAbsCat* abscat, GuBuf* functions) +pgf_jit_predicate(PgfReader* rdr, PgfAbstr* abstr, + PgfAbsCat* abscat) { #ifdef PGF_JIT_DEBUG GuPool* tmp_pool = gu_new_pool(); @@ -110,21 +126,24 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, int label = 0; #endif - size_t n_funs = gu_buf_length(functions); - - pgf_jit_make_space(state); + size_t n_funs = pgf_read_len(rdr); + gu_return_on_exn(rdr->err, ); + + pgf_jit_make_space(rdr); abscat->predicate = (PgfPredicate) jit_get_ip().ptr; jit_prolog(2); + PgfAbsFun* absfun = NULL; + PgfAbsFun* next_absfun = NULL; + if (n_funs > 0) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, 0); + next_absfun = pgf_jit_read_absfun(rdr, abstr); #ifdef PGF_JIT_DEBUG gu_puts(" TRY_FIRST ", out, err); - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts("\n", out, err); #endif @@ -135,7 +154,7 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, // compile TRY_FIRST jit_prepare(3); - jit_movi_p(JIT_V0,absfun); + jit_movi_p(JIT_V0,next_absfun); jit_pusharg_p(JIT_V0); jit_pusharg_p(JIT_V2); jit_pusharg_p(JIT_V1); @@ -150,20 +169,15 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, #ifdef PGF_JIT_DEBUG if (n_funs > 0) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, 0); - - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts(":\n", out, err); } #endif for (size_t i = 0; i < n_funs; i++) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, i); - - pgf_jit_make_space(state); + pgf_jit_make_space(rdr); + absfun = next_absfun; absfun->predicate = (PgfPredicate) jit_get_ip().ptr; jit_prolog(2); @@ -176,18 +190,17 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, if (n_hypos > 0) { if (i+1 < n_funs) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, i+1); + next_absfun = pgf_jit_read_absfun(rdr, abstr); // i+1 #ifdef PGF_JIT_DEBUG gu_puts(" TRY_ELSE ", out, err); - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts("\n", out, err); #endif // compile TRY_ELSE jit_prepare(3); - jit_movi_p(JIT_V0, absfun); + jit_movi_p(JIT_V0, next_absfun); jit_pusharg_p(JIT_V0); jit_pusharg_p(JIT_V2); jit_pusharg_p(JIT_V1); @@ -200,9 +213,6 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, jit_insn *ref; // call the predicate for the category in hypo->type->cid - PgfAbsCat* arg = - gu_map_get(abscats, hypo->type->cid, PgfAbsCat*); - #ifdef PGF_JIT_DEBUG gu_puts(" CALL ", out, err); gu_string_write(hypo->type->cid, out, err); @@ -219,14 +229,11 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, jit_prepare(2); jit_pusharg_p(JIT_V2); jit_pusharg_p(JIT_V1); - if (arg != NULL) { - jit_finish(arg->predicate); - } else { - PgfCallPatch patch; - patch.cid = hypo->type->cid; - patch.ref = jit_finish(jit_forward()); - gu_buf_push(state->patches, PgfCallPatch, patch); - } + + PgfCallPatch patch; + patch.cid = hypo->type->cid; + patch.ref = jit_finish(jit_forward()); + gu_buf_push(rdr->jit_state->patches, PgfCallPatch, patch); #ifdef PGF_JIT_DEBUG gu_puts(" RET\n", out, err); @@ -239,7 +246,7 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, jit_ret(); if (i+1 < n_hypos) { - pgf_jit_make_space(state); + pgf_jit_make_space(rdr); jit_patch_movi(ref,jit_get_label()); @@ -254,18 +261,17 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, } } else { if (i+1 < n_funs) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, i+1); + next_absfun = pgf_jit_read_absfun(rdr, abstr); // i+1 #ifdef PGF_JIT_DEBUG gu_puts(" TRY_CONSTANT ", out, err); - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts("\n", out, err); #endif // compile TRY_CONSTANT jit_prepare(3); - jit_movi_p(JIT_V0, absfun); + jit_movi_p(JIT_V0, next_absfun); jit_pusharg_p(JIT_V0); jit_pusharg_p(JIT_V2); jit_pusharg_p(JIT_V1); @@ -289,13 +295,10 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, // compile RET jit_ret(); } - + #ifdef PGF_JIT_DEBUG if (i+1 < n_funs) { - PgfAbsFun* absfun = - gu_buf_get(functions, PgfAbsFun*, i+1); - - gu_string_write(absfun->name, out, err); + gu_string_write(next_absfun->name, out, err); gu_puts(":\n", out, err); } #endif @@ -307,18 +310,251 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, } void -pgf_jit_done(PgfJitState* state, PgfAbstr* abstr) +pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr, + PgfAbsFun* absfun) { - size_t n_patches = gu_buf_length(state->patches); +#ifdef PGF_JIT_DEBUG + GuPool* tmp_pool = gu_new_pool(); + GuOut* out = gu_file_out(stderr, tmp_pool); + GuExn* err = gu_exn(NULL, type, tmp_pool); + + gu_string_write(absfun->name, out, err); + gu_puts(":\n", out, err); +#endif + + pgf_jit_make_space(rdr); + + absfun->function = jit_get_ip().ptr; + + jit_prolog(2); + + int es_arg = jit_arg_p(); + int closure_arg = jit_arg_p(); + + size_t n_instrs = pgf_read_len(rdr); + gu_return_on_exn(rdr->err, ); + + size_t curr_offset = 0; + size_t curr_label = 0; + + for (size_t i = 0; i < n_instrs; i++) { +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "%04d ", curr_label++); +#endif + + uint8_t opcode = pgf_read_tag(rdr); + switch (opcode) { + case PGF_INSTR_EVAL: { + size_t index = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "EVAL %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_length); + jit_subi_i(JIT_V2, JIT_RET, index+1); + jit_lshi_i(JIT_V2, JIT_V2, 2); + jit_prepare(1); + jit_pusharg_p(JIT_V0); + jit_finish(gu_buf_data); + jit_ldxr_p(JIT_V0, JIT_RET, JIT_V2); + 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_callr(JIT_V0); + break; + } + case PGF_INSTR_CASE: { + PgfCId id = pgf_read_cid(rdr, rdr->opool); + int offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE %s %04d\n", id, curr_label+offset); +#endif + break; + } + case PGF_INSTR_CASE_INT: { + int n = pgf_read_int(rdr); + int offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE_INT %d %04d\n", n, curr_label+offset); +#endif + break; + } + case PGF_INSTR_CASE_STR: { + GuString s = pgf_read_string(rdr); + int offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE_STR %s %04d\n", s, curr_label+offset); +#endif + break; + } + case PGF_INSTR_CASE_FLT: { + double d = pgf_read_double(rdr); + int offset = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "CASE_FLT %f %04d\n", d, curr_label+offset); +#endif + break; + } + case PGF_INSTR_ALLOC: { + size_t size = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "ALLOC %d\n", size); +#endif + jit_prepare(2); + jit_movi_ui(JIT_V0, size*sizeof(void*)); + jit_pusharg_ui(JIT_V0); + jit_getarg_p(JIT_V0, es_arg); + jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,pool)); + jit_pusharg_p(JIT_V0); + jit_finish(gu_malloc); + jit_retval_p(JIT_V1); + + curr_offset = 0; + break; + } + 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); +#endif + + jit_movi_p(JIT_V0, pgf_evaluate_value); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + + PgfCallPatch patch; + patch.cid = id; + patch.ref = jit_movi_p(JIT_V0, jit_forward()); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + curr_offset++; + + gu_buf_push(rdr->jit_state->patches, PgfCallPatch, patch); + break; + } + case PGF_INSTR_PUT_CLOSURE: { + size_t addr = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_CLOSURE %d\n", addr); +#endif + break; + } + case PGF_INSTR_PUT_INT: { + size_t n = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_INT %d\n", n); +#endif + break; + } + case PGF_INSTR_PUT_STR: { + size_t addr = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_STR %d\n", addr); +#endif + break; + } + case PGF_INSTR_PUT_FLT: { + size_t addr = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUT_FLT %d\n", addr); +#endif + + 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_VARIABLE: { + size_t index = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "SET_VARIABLE %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_length); + jit_subi_i(JIT_V2, JIT_RET, index+1); + jit_lshi_i(JIT_V2, JIT_V2, 2); + jit_prepare(1); + jit_pusharg_p(JIT_V0); + jit_finish(gu_buf_data); + jit_ldxr_p(JIT_V0, JIT_RET, JIT_V2); + jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0); + break; + } + case PGF_INSTR_TAIL_CALL: { + PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "TAIL_CALL %s\n", id); +#endif + break; + } + case PGF_INSTR_FAIL: +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "FAIL\n"); +#endif + break; + case PGF_INSTR_RET: { + size_t count = pgf_read_int(rdr); + +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "RET %d\n", count); +#endif + + jit_prepare(2); + jit_movi_ui(JIT_V0, count); + jit_pusharg_p(JIT_V0); + jit_getarg_p(JIT_V0, es_arg); + jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack)); + jit_pusharg_p(JIT_V0); + jit_finish(gu_buf_trim_n); + + jit_movr_p(JIT_RET, JIT_V1); + jit_ret(); + break; + } + default: + gu_impossible(); + } + } +} + +void +pgf_jit_done(PgfReader* rdr, PgfAbstr* abstr) +{ + size_t n_patches = gu_buf_length(rdr->jit_state->patches); for (size_t i = 0; i < n_patches; i++) { PgfCallPatch* patch = - gu_buf_index(state->patches, PgfCallPatch, i); + gu_buf_index(rdr->jit_state->patches, PgfCallPatch, i); + PgfAbsCat* arg = gu_map_get(abstr->cats, patch->cid, PgfAbsCat*); - gu_assert(arg != NULL); - - jit_patch_calli(patch->ref,(jit_insn*) arg->predicate); + if (arg != NULL) + jit_patch_calli(patch->ref,(jit_insn*) arg->predicate); + else { + PgfAbsFun* con = + gu_map_get(abstr->funs, patch->cid, PgfAbsFun*); + if (con != NULL) + jit_patch_movi(patch->ref,con); + else { + gu_impossible(); + } + } } - jit_flush_code(state->buf, jit_get_ip().ptr); + jit_flush_code(rdr->jit_state->buf, jit_get_ip().ptr); } diff --git a/src/runtime/c/pgf/jit.h b/src/runtime/c/pgf/jit.h deleted file mode 100644 index 04265547a..000000000 --- a/src/runtime/c/pgf/jit.h +++ /dev/null @@ -1,16 +0,0 @@ -#ifndef PGF_JIT_H_ -#define PGF_JIT_H_ - -typedef struct PgfJitState PgfJitState; - -PgfJitState* -pgf_jit_init(GuPool* tmp_pool, GuPool* pool); - -void -pgf_jit_done(PgfJitState* state, PgfAbstr* abstr); - -void -pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, - PgfAbsCat* abscat, GuBuf* functions); - -#endif diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index bc9fb7d99..16444985f 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -17,44 +17,24 @@ extern GU_DECLARE_TYPE(PgfExn, abstract); extern GU_DECLARE_TYPE(PgfParseError, abstract); extern GU_DECLARE_TYPE(PgfTypeError, abstract); -/// @name PGF Grammar objects -/// @{ - typedef struct PgfPGF PgfPGF; typedef struct PgfConcr PgfConcr; - -/**< A representation of a PGF grammar. - */ - #include #include -/// An enumeration of #PgfExpr elements. typedef GuEnum PgfExprEnum; PgfPGF* pgf_read(const char* fpath, GuPool* pool, GuExn* err); -/**< Read a grammar from a PGF file. - * - * @param from PGF input stream. - * The stream must be positioned in the beginning of a binary - * PGF representation. After a succesful invocation, the stream is - * still open and positioned at the end of the representation. - * - * @param[out] err_out Raised error. - * If non-\c NULL, \c *err_out should be \c NULL. Then, upon - * failure, \c *err_out is set to point to a newly allocated - * error object, which the caller must free with #g_exn_free - * or #g_exn_propagate. - * - * @return A new PGF object, or \c NULL upon failure. The returned - * object must later be freed with #pgf_free. - * - */ +void +pgf_concrete_load(PgfConcr* concr, GuIn* in, GuExn* err); + +void +pgf_concrete_unload(PgfConcr* concr); GuString pgf_abstract_name(PgfPGF*); @@ -176,8 +156,6 @@ pgf_concr_add_literal(PgfConcr *concr, PgfCId cat, PgfLiteralCallback* callback, GuExn* err); -/// @} - void pgf_print(PgfPGF* pgf, GuOut* out, GuExn* err); diff --git a/src/runtime/c/pgf/reader.c b/src/runtime/c/pgf/reader.c index afbd42242..20dfd6e6c 100644 --- a/src/runtime/c/pgf/reader.c +++ b/src/runtime/c/pgf/reader.c @@ -2,7 +2,6 @@ #include "expr.h" #include "literals.h" #include "reader.h" -#include "jit.h" #include #include @@ -22,14 +21,6 @@ // PgfReader // -struct PgfReader { - GuIn* in; - GuExn* err; - GuPool* opool; - GuPool* tmp_pool; - PgfJitState* jit_state; -}; - typedef struct PgfReadTagExn PgfReadTagExn; struct PgfReadTagExn { @@ -41,13 +32,13 @@ static GU_DEFINE_TYPE(PgfReadTagExn, abstract, _); static GU_DEFINE_TYPE(PgfReadExn, abstract, _); -static uint8_t +uint8_t pgf_read_tag(PgfReader* rdr) { return gu_in_u8(rdr->in, rdr->err); } -static uint32_t +uint32_t pgf_read_uint(PgfReader* rdr) { uint32_t u = 0; @@ -62,14 +53,14 @@ pgf_read_uint(PgfReader* rdr) return u; } -static int32_t +int32_t pgf_read_int(PgfReader* rdr) { uint32_t u = pgf_read_uint(rdr); return gu_decode_2c32(u, rdr->err); } -static GuLength +size_t pgf_read_len(PgfReader* rdr) { int32_t len = pgf_read_int(rdr); @@ -88,23 +79,29 @@ pgf_read_len(PgfReader* rdr) return 0; } - return (GuLength) len; + return len; } -static PgfCId +PgfCId pgf_read_cid(PgfReader* rdr, GuPool* pool) { size_t len = pgf_read_len(rdr); return gu_string_read_latin1(len, pool, rdr->in, rdr->err); } -static GuString +GuString pgf_read_string(PgfReader* rdr) { GuLength len = pgf_read_len(rdr); return gu_string_read(len, rdr->opool, rdr->in, rdr->err); } +double +pgf_read_double(PgfReader* rdr) +{ + return gu_in_f64be(rdr->in, rdr->err); +} + static void pgf_read_tag_error(PgfReader* rdr) { @@ -149,7 +146,7 @@ pgf_read_literal(PgfReader* rdr) gu_new_variant(PGF_LITERAL_FLT, PgfLiteralFlt, &lit, rdr->opool); - lit_flt->val = gu_in_f64be(rdr->in, rdr->err); + lit_flt->val = pgf_read_double(rdr); break; } default: @@ -417,7 +414,7 @@ pgf_read_patt(PgfReader* rdr) } static PgfAbsFun* -pgf_read_absfun(PgfReader* rdr) +pgf_read_absfun(PgfReader* rdr, PgfAbstr* abstr) { PgfAbsFun* absfun = gu_new(PgfAbsFun, rdr->opool); @@ -444,6 +441,7 @@ pgf_read_absfun(PgfReader* rdr) switch (tag) { case 0: absfun->defns = NULL; + absfun->function = NULL; break; case 1: { GuLength length = pgf_read_len(rdr); @@ -468,6 +466,8 @@ pgf_read_absfun(PgfReader* rdr) data[i] = equ; } + + // pgf_jit_function(rdr, abstr, absfun); break; } default: @@ -475,13 +475,13 @@ pgf_read_absfun(PgfReader* rdr) break; } - absfun->ep.prob = - log(gu_in_f64be(rdr->in, rdr->err)); + absfun->ep.prob = - log(pgf_read_double(rdr)); return absfun; } static PgfCIdMap* -pgf_read_absfuns(PgfReader* rdr) +pgf_read_absfuns(PgfReader* rdr, PgfAbstr* abstr) { GuMapType* map_type = (GuMapType*) GU_TYPE_LIT(GuStringMap, _, @@ -493,7 +493,7 @@ pgf_read_absfuns(PgfReader* rdr) gu_return_on_exn(rdr->err, NULL); for (size_t i = 0; i < len; i++) { - PgfAbsFun* absfun = pgf_read_absfun(rdr); + PgfAbsFun* absfun = pgf_read_absfun(rdr, abstr); gu_return_on_exn(rdr->err, NULL); gu_map_put(absfuns, absfun->name, PgfAbsFun*, absfun); @@ -519,27 +519,9 @@ pgf_read_abscat(PgfReader* rdr, PgfAbstr* abstr, PgfCIdMap* abscats) gu_return_on_exn(rdr->err, NULL); } - GuBuf* functions = gu_new_buf(PgfAbsFun*, rdr->tmp_pool); - - size_t n_functions = pgf_read_len(rdr); - gu_return_on_exn(rdr->err, NULL); - - for (size_t i = 0; i < n_functions; i++) { - gu_in_f64be(rdr->in, rdr->err); // ignore - gu_return_on_exn(rdr->err, NULL); - - PgfCId name = pgf_read_cid(rdr, rdr->tmp_pool); - gu_return_on_exn(rdr->err, NULL); - - PgfAbsFun* absfun = - gu_map_get(abstr->funs, name, PgfAbsFun*); - assert(absfun != NULL); - gu_buf_push(functions, PgfAbsFun*, absfun); - } - - abscat->prob = - log(gu_in_f64be(rdr->in, rdr->err)); + pgf_jit_predicate(rdr, abstr, abscat); - pgf_jit_predicate(rdr->jit_state, abscats, abscat, functions); + abscat->prob = - log(pgf_read_double(rdr)); return abscat; } @@ -552,7 +534,7 @@ pgf_read_abscats(PgfReader* rdr, PgfAbstr* abstr) gu_ptr_type(PgfAbsCat), &gu_null_struct); PgfCIdMap* abscats = gu_map_type_make(map_type, rdr->opool); - + size_t len = pgf_read_len(rdr); gu_return_on_exn(rdr->err, NULL); @@ -575,7 +557,7 @@ pgf_read_abstract(PgfReader* rdr, PgfAbstr* abstract) abstract->aflags = pgf_read_flags(rdr); gu_return_on_exn(rdr->err, ); - abstract->funs = pgf_read_absfuns(rdr); + abstract->funs = pgf_read_absfuns(rdr, abstract); gu_return_on_exn(rdr->err, ); abstract->cats = pgf_read_abscats(rdr, abstract); @@ -1350,7 +1332,7 @@ pgf_new_reader(GuIn* in, GuPool* opool, GuPool* tmp_pool, GuExn* err) rdr->tmp_pool = tmp_pool; rdr->err = err; rdr->in = in; - rdr->jit_state = pgf_jit_init(tmp_pool, rdr->opool); + rdr->jit_state = pgf_new_jit(rdr); return rdr; } @@ -1360,5 +1342,5 @@ pgf_reader_done(PgfReader* rdr, PgfPGF* pgf) if (pgf == NULL) return; - pgf_jit_done(rdr->jit_state, &pgf->abstract); + pgf_jit_done(rdr, &pgf->abstract); } diff --git a/src/runtime/c/pgf/reader.h b/src/runtime/c/pgf/reader.h index 7011eea17..98042c330 100644 --- a/src/runtime/c/pgf/reader.h +++ b/src/runtime/c/pgf/reader.h @@ -5,21 +5,64 @@ #include #include -typedef struct PgfReader PgfReader; +// general reader interface + +typedef struct { + GuIn* in; + GuExn* err; + GuPool* opool; + GuPool* tmp_pool; + struct PgfJitState* jit_state; +} PgfReader; PgfReader* pgf_new_reader(GuIn* in, GuPool* opool, GuPool* tmp_pool, GuExn* err); +uint8_t +pgf_read_tag(PgfReader* rdr); + +uint32_t +pgf_read_uint(PgfReader* rdr); + +int32_t +pgf_read_int(PgfReader* rdr); + +GuString +pgf_read_string(PgfReader* rdr); + +double +pgf_read_double(PgfReader* rdr); + +size_t +pgf_read_len(PgfReader* rdr); + +PgfCId +pgf_read_cid(PgfReader* rdr, GuPool* pool); + PgfPGF* pgf_read_pgf(PgfReader* rdr); void -pgf_concrete_load(PgfConcr* concr, GuIn* in, GuExn* err); +pgf_reader_done(PgfReader* rdr, PgfPGF* pgf); + + +// JIT specific interface + +typedef struct PgfJitState PgfJitState; + +PgfJitState* +pgf_new_jit(PgfReader* rdr); void -pgf_concrete_unload(PgfConcr* concr); +pgf_jit_predicate(PgfReader* rdr, PgfAbstr* abstr, + PgfAbsCat* abscat); void -pgf_reader_done(PgfReader* rdr, PgfPGF* pgf); +pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr, + PgfAbsFun* absfun); + +void +pgf_jit_done(PgfReader* state, PgfAbstr* abstr); + #endif // READER_H_ diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 77eac1ada..8c901c7a9 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -293,8 +293,8 @@ categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))] categoryContext pgf cat = case Map.lookup cat (cats (abstract pgf)) of - Just (hypos,_,_,_) -> Just hypos - Nothing -> Nothing + Just (hypos,_,_) -> Just hypos + Nothing -> Nothing startCat pgf = DTyp [] (lookStartCat pgf) [] @@ -302,13 +302,13 @@ functions pgf = Map.keys (funs (abstract pgf)) functionsByCat pgf cat = case Map.lookup cat (cats (abstract pgf)) of - Just (_,fns,_,_) -> map snd fns - Nothing -> [] + Just (_,fns,_) -> map snd fns + Nothing -> [] functionType pgf fun = case Map.lookup fun (funs (abstract pgf)) of - Just (ty,_,_,_,_) -> Just ty - Nothing -> Nothing + Just (ty,_,_,_) -> Just ty + Nothing -> Nothing -- | Converts an expression to normal form compute :: PGF -> Expr -> Expr @@ -318,20 +318,20 @@ browse :: PGF -> CId -> Maybe (String,[CId],[CId]) browse pgf id = fmap (\def -> (def,producers,consumers)) definition where definition = case Map.lookup id (funs (abstract pgf)) of - Just (ty,_,Just eqs,_,_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ - if null eqs - then empty - else text "def" <+> vcat [let scope = foldl pattScope [] patts - ds = map (ppPatt 9 scope) patts - in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) - Just (ty,_,Nothing, _,_) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty) + Just (ty,_,Just (eqs,_),_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$ + if null eqs + then empty + else text "def" <+> vcat [let scope = foldl pattScope [] patts + ds = map (ppPatt 9 scope) patts + in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) + Just (ty,_,Nothing,_) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty) Nothing -> case Map.lookup id (cats (abstract pgf)) of - Just (hyps,_,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))) - Nothing -> Nothing + Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))) + Nothing -> Nothing (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf)) where - accum f (ty,_,_,_,_) (plist,clist) = + accum f (ty,_,_,_) (plist,clist) = let !plist' = if id `elem` ps then f : plist else plist !clist' = if id `elem` cs then f : clist else clist in (plist',clist') diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index 4d4c53102..b2bfda069 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -3,12 +3,12 @@ module PGF.Binary(putSplitAbs) where import PGF.CId import PGF.Data import PGF.Optimize +import PGF.ByteCode import qualified PGF.OldBinary as Old import Data.Binary import Data.Binary.Put import Data.Binary.Get import Data.Array.IArray -import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.IntMap as IntMap --import qualified Data.Set as Set @@ -43,16 +43,15 @@ instance Binary CId where get = liftM CId get instance Binary Abstr where - put abs = put (aflags abs, - fmap (\(w,x,y,z,_) -> (w,x,y,z)) (funs abs), - fmap (\(x,y,z,_) -> (x,y,z)) (cats abs)) + put abs = do put (aflags abs) + put (Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap fst mb_eq,prob)) (funs abs)) + put (cats abs) get = do aflags <- get funs <- get cats <- get return (Abstr{ aflags=aflags - , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs - , cats=fmap (\(x,y,z) -> (x,y,z,0)) cats - , code=BS.empty + , funs=Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs + , cats=cats }) putSplitAbs :: PGF -> Put @@ -136,6 +135,25 @@ instance Binary Equation where put (Equ ps e) = put (ps,e) get = liftM2 Equ get get +instance Binary Instr where + put (EVAL n) = putWord8 0 >> put n + put (CASE id l ) = putWord8 1 >> put (id,l) + put (CASE_INT n l ) = putWord8 2 >> put (n,l) + put (CASE_STR s l ) = putWord8 3 >> put (s,l) + put (CASE_FLT d l ) = putWord8 4 >> put (d,l) + put (ALLOC n) = putWord8 5 >> put n + put (PUT_CONSTR id) = putWord8 6 >> put id + put (PUT_CLOSURE l) = putWord8 7 >> put l + put (PUT_INT n) = putWord8 8 >> put n + put (PUT_STR s) = putWord8 9 >> put s + put (PUT_FLT d) = putWord8 10 >> put d + put (SET_VALUE n) = putWord8 11 >> put n + put (SET_VARIABLE n) = putWord8 12 >> put n + put (TAIL_CALL id) = putWord8 13 >> put id + put (FAIL ) = putWord8 14 + put (RET n) = putWord8 15 >> put n + + instance Binary Type where put (DTyp hypos cat exps) = put (hypos,cat,exps) get = liftM3 DTyp get get get diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs new file mode 100644 index 000000000..b8e7d889d --- /dev/null +++ b/src/runtime/haskell/PGF/ByteCode.hs @@ -0,0 +1,47 @@ +module PGF.ByteCode(CodeLabel, Instr(..), ppCode, ppInstr) where + +import PGF.CId +import Text.PrettyPrint + +type CodeLabel = Int + +data Instr + = EVAL {-# UNPACK #-} !Int + | CASE CId {-# UNPACK #-} !CodeLabel + | CASE_INT Int {-# UNPACK #-} !CodeLabel + | CASE_STR String {-# UNPACK #-} !CodeLabel + | CASE_FLT Double {-# UNPACK #-} !CodeLabel + | ALLOC {-# UNPACK #-} !Int + | PUT_CONSTR CId + | PUT_CLOSURE {-# UNPACK #-} !CodeLabel + | PUT_INT {-# UNPACK #-} !Int + | PUT_STR String + | PUT_FLT {-# UNPACK #-} !Double + | SET_VALUE {-# UNPACK #-} !Int + | SET_VARIABLE {-# UNPACK #-} !Int + | TAIL_CALL CId + | FAIL + | RET {-# UNPACK #-} !Int + +ppCode :: CodeLabel -> [Instr] -> Doc +ppCode l [] = empty +ppCode l (i:is) = ppLabel l <+> ppInstr l i $$ ppCode (l+1) is + +ppInstr l (EVAL n) = text "EVAL " <+> int n +ppInstr l (CASE id o ) = text "CASE " <+> ppCId id <+> ppLabel (l+o+1) +ppInstr l (CASE_INT n o ) = text "CASE_INT " <+> int n <+> ppLabel (l+o+1) +ppInstr l (CASE_STR s o ) = text "CASE_STR " <+> text (show s) <+> ppLabel (l+o+1) +ppInstr l (CASE_FLT d o ) = text "CASE_FLT " <+> double d <+> ppLabel (l+o+1) +ppInstr l (ALLOC n) = text "ALLOC " <+> int n +ppInstr l (SET_VALUE n) = text "SET_VALUE " <+> int n +ppInstr l (PUT_CONSTR id) = text "PUT_CONSTR " <+> ppCId id +ppInstr l (PUT_CLOSURE c) = text "PUT_CLOSURE " <+> ppLabel c +ppInstr l (PUT_INT n ) = text "PUT_INT " <+> int n +ppInstr l (PUT_STR s ) = text "PUT_STR " <+> text (show s) +ppInstr l (PUT_FLT d ) = text "PUT_FLT " <+> double d +ppInstr l (SET_VARIABLE n) = text "SET_VARIABLE" <+> int n +ppInstr l (TAIL_CALL id) = text "TAIL_CALL " <+> ppCId id +ppInstr l (FAIL ) = text "FAIL" +ppInstr l (RET n) = text "RET " <+> int n + +ppLabel l = text (let s = show l in replicate (4-length s) '0' ++ s) diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index 3222867d2..76dbc616a 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -2,6 +2,7 @@ module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type) where import PGF.CId import PGF.Expr hiding (Value, Sig, Env, Tree, eval, apply, applyValue, value2expr) +import PGF.ByteCode import PGF.Type import qualified Data.Map as Map @@ -9,7 +10,6 @@ import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified PGF.TrieMap as TMap -import qualified Data.ByteString as BS import Data.Array.IArray import Data.Array.Unboxed --import Data.List @@ -28,12 +28,11 @@ data PGF = PGF { data Abstr = Abstr { aflags :: Map.Map CId Literal, -- ^ value of a flag - funs :: Map.Map CId (Type,Int,Maybe [Equation],Double,BCAddr), -- ^ type, arrity and definition of function + probability - cats :: Map.Map CId ([Hypo],[(Double, CId)],Double,BCAddr), -- ^ 1. context of a category - -- 2. functions of a category. The functions are stored - -- in decreasing probability order. - -- 3. probability - code :: BS.ByteString + funs :: Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double),-- ^ type, arrity and definition of function + probability + cats :: Map.Map CId ([Hypo],[(Double, CId)],Double) -- ^ 1. context of a category + -- 2. functions of a category. The functions are stored + -- in decreasing probability order. + -- 3. probability } data Concr = Concr { @@ -76,8 +75,6 @@ data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord, type Sequence = Array DotPos Symbol type FunId = Int type SeqId = Int -type BCAddr = Int - -- merge two PGFs; fails is differens absnames; priority to second arg @@ -105,8 +102,8 @@ emptyPGF = PGF { haveSameFunsPGF :: PGF -> PGF -> Bool haveSameFunsPGF one two = let - fsone = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract one))] - fstwo = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract two))] + fsone = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract one))] + fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))] in fsone == fstwo -- | This is just a 'CId' with the language name. diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index 264be4aaa..0b4ccc554 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -21,6 +21,7 @@ module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(.. import PGF.CId import PGF.Type +import PGF.ByteCode import Data.Char --import Data.Maybe @@ -324,21 +325,22 @@ data Value | VClosure Env Expr | VImplArg Value -type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double,Int) -- type and def of a fun - , Int -> Maybe Expr -- lookup for metavariables +type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double) -- type and def of a fun + , Int -> Maybe Expr -- lookup for metavariables ) type Env = [Value] eval :: Sig -> Env -> Expr -> Value eval sig env (EVar i) = env !! i eval sig env (EFun f) = case Map.lookup f (fst sig) of - Just (_,a,meqs,_,_) -> case meqs of - Just eqs -> if a == 0 - then case eqs of - Equ [] e : _ -> eval sig [] e - _ -> VConst f [] - else VApp f [] - Nothing -> VApp f [] + Just (_,a,meqs,_) -> case meqs of + Just (eqs,_) + -> if a == 0 + then case eqs of + Equ [] e : _ -> eval sig [] e + _ -> VConst f [] + else VApp f [] + Nothing -> VApp f [] Nothing -> error ("unknown function "++showCId f) eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2] eval sig env (EAbs b x e) = VClosure env (EAbs b x e) @@ -353,11 +355,11 @@ apply :: Sig -> Env -> Expr -> [Value] -> Value apply sig env e [] = eval sig env e apply sig env (EVar i) vs = applyValue sig (env !! i) vs apply sig env (EFun f) vs = case Map.lookup f (fst sig) of - Just (_,a,meqs,_,_) -> case meqs of - Just eqs -> if a <= length vs - then match sig f eqs vs - else VApp f vs - Nothing -> VApp f vs + Just (_,a,meqs,_) -> case meqs of + Just (eqs,_) -> if a <= length vs + then match sig f eqs vs + else VApp f vs + Nothing -> VApp f vs Nothing -> error ("unknown function "++showCId f) apply sig env (EApp e1 e2) vs = apply sig env e1 (eval sig env e2 : vs) apply sig env (EAbs b x e) (v:vs) = case (b,v) of diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs index 8a38948be..bb4ba29af 100644 --- a/src/runtime/haskell/PGF/Forest.hs +++ b/src/runtime/haskell/PGF/Forest.hs @@ -75,7 +75,7 @@ bracketedTokn dp f@(Forest abs cnc forest root) = cat = case isLindefCId fun of Just cat -> cat Nothing -> case Map.lookup fun (funs abs) of - Just (DTyp _ cat _,_,_,_,_) -> cat + Just (DTyp _ cat _,_,_,_) -> cat largs = map (render forest) args ltable = mkLinTable cnc isTrusted [] funid largs in ((cat,fid),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable) diff --git a/src/runtime/haskell/PGF/Internal.hs b/src/runtime/haskell/PGF/Internal.hs index f2c79596c..3b252a36b 100644 --- a/src/runtime/haskell/PGF/Internal.hs +++ b/src/runtime/haskell/PGF/Internal.hs @@ -11,6 +11,7 @@ import PGF.Macros as Internal import PGF.Optimize as Internal import PGF.Printer as Internal import PGF.Utilities as Internal +import PGF.ByteCode as Internal import Data.Binary as Internal import Data.Binary.Get as Internal diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs index ea560165d..3f11f93d1 100644 --- a/src/runtime/haskell/PGF/Linearize.hs +++ b/src/runtime/haskell/PGF/Linearize.hs @@ -101,7 +101,7 @@ linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e [])) Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set] where toApp fid (PApply funid pargs) = - let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf)) + let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf)) (args,res) = catSkeleton ty in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])] toApp _ (PCoerce fid) = diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index 0e73180d5..7cf2661cc 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -21,18 +21,13 @@ mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) } lookType :: Abstr -> CId -> Type lookType abs f = case lookMap (error $ "lookType " ++ show f) f (funs abs) of - (ty,_,_,_,_) -> ty - -lookDef :: Abstr -> CId -> Maybe [Equation] -lookDef abs f = - case lookMap (error $ "lookDef " ++ show f) f (funs abs) of - (_,a,eqs,_,_) -> eqs + (ty,_,_,_) -> ty isData :: Abstr -> CId -> Bool isData abs f = case Map.lookup f (funs abs) of - Just (_,_,Nothing,_,_) -> True -- the encoding of data constrs - _ -> False + Just (_,_,Nothing,_) -> True -- the encoding of data constrs + _ -> False lookValCat :: Abstr -> CId -> CId lookValCat abs = valCat . lookType abs @@ -65,9 +60,9 @@ lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang functionsToCat :: PGF -> CId -> [(CId,Type)] functionsToCat pgf cat = - [(f,ty) | (_,f) <- fs, Just (ty,_,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]] + [(f,ty) | (_,f) <- fs, Just (ty,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]] where - (_,fs,_,_) = lookMap ([],[],0,0) cat $ cats $ abstract pgf + (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf -- | List of functions that lack linearizations in the given language. missingLins :: PGF -> Language -> [CId] @@ -82,7 +77,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF restrictPGF cond pgf = pgf { abstract = abstr { funs = Map.filterWithKey (\c _ -> cond c) (funs abstr), - cats = Map.map (\(hyps,fs,p,addr) -> (hyps,filter (cond . snd) fs,p,addr)) (cats abstr) + cats = Map.map (\(hyps,fs,p) -> (hyps,filter (cond . snd) fs,p)) (cats abstr) } } ---- restrict concrs also, might be needed where diff --git a/src/runtime/haskell/PGF/OldBinary.hs b/src/runtime/haskell/PGF/OldBinary.hs index 55a1f1a5c..9a65b0fa6 100644 --- a/src/runtime/haskell/PGF/OldBinary.hs +++ b/src/runtime/haskell/PGF/OldBinary.hs @@ -7,7 +7,6 @@ import PGF.Optimize import Data.Binary import Data.Binary.Get import Data.Array.IArray -import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified Data.Set as Set @@ -40,9 +39,8 @@ getAbstract = funs <- getMap getCId getFun cats <- getMap getCId getCat return (Abstr{ aflags=aflags - , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs - , cats=fmap (\(x,y) -> (x,y,0,0)) cats - , code=BS.empty + , funs=fmap (\(w,x,y,z) -> (w,x,fmap (flip (,) []) y,z)) funs + , cats=fmap (\(x,y) -> (x,y,0)) cats }) getFun :: Get (Type,Int,Maybe [Equation],Double) getFun = (,,,) `fmap` getType `ap` get `ap` getMaybe (getList getEquation) `ap` get diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs index 57697b8d2..8bee81f43 100644 --- a/src/runtime/haskell/PGF/Paraphrase.hs +++ b/src/runtime/haskell/PGF/Paraphrase.hs @@ -53,7 +53,7 @@ fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where isClosed d || (length equs == 1 && isLinear d)] equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | - (f,(_,_,Just eqs,_,_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)] + (f,(_,_,Just (eqs,_),_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)] ---- AR 14/12/2010: (expr2tree d) fails unless we send the variable list from ps in eqs; ---- cf. PGF.Tree.expr2tree trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index 4945667f4..1aabce09d 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -2,7 +2,7 @@ module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where import PGF.CId import PGF.Data ---import PGF.Macros +import PGF.ByteCode import qualified Data.Map as Map import qualified Data.Set as Set @@ -26,17 +26,18 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$ ppFlag :: CId -> Literal -> Doc ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';' -ppCat :: CId -> ([Hypo],[(Double,CId)],Double,BCAddr) -> Doc -ppCat c (hyps,_,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';' - -ppFun :: CId -> (Type,Int,Maybe [Equation],Double,BCAddr) -> Doc -ppFun f (t,_,Just eqs,_,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ - if null eqs - then empty - else text "def" <+> vcat [let scope = foldl pattScope [] patts - ds = map (ppPatt 9 scope) patts - in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] -ppFun f (t,_,Nothing,_,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' +ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> Doc +ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';' + +ppFun :: CId -> (Type,Int,Maybe ([Equation],[Instr]),Double) -> Doc +ppFun f (t,_,Just (eqs,code),_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ + if null eqs + then empty + else text "def" <+> vcat [let scope = foldl pattScope [] patts + ds = map (ppPatt 9 scope) patts + in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] $$ + ppCode 0 code +ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' ppCnc :: Language -> Concr -> Doc ppCnc name cnc = diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs index 7d8d58134..555ae0ce9 100644 --- a/src/runtime/haskell/PGF/Probabilistic.hs +++ b/src/runtime/haskell/PGF/Probabilistic.hs @@ -52,7 +52,7 @@ readProbabilitiesFromFile file pgf = do mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities mkProbabilities pgf probs = let funs1 = Map.fromList [(f,p) | (_,(_,fns)) <- Map.toList cats1, (p,f) <- fns] - cats1 = Map.mapWithKey (\c (_,fns,_,_) -> + cats1 = Map.mapWithKey (\c (_,fns,_) -> let p' = fromMaybe 0 (Map.lookup c probs) fns' = sortBy cmpProb (fill fns) in (p', fns')) @@ -76,15 +76,15 @@ defaultProbabilities pgf = mkProbabilities pgf Map.empty getProbabilities :: PGF -> Probabilities getProbabilities pgf = Probs { - funProbs = Map.map (\(_,_,_,p,_) -> p ) (funs (abstract pgf)), - catProbs = Map.map (\(_,fns,p,_) -> (p,fns)) (cats (abstract pgf)) + funProbs = Map.map (\(_,_,_,p) -> p ) (funs (abstract pgf)), + catProbs = Map.map (\(_,fns,p) -> (p,fns)) (cats (abstract pgf)) } setProbabilities :: Probabilities -> PGF -> PGF setProbabilities probs pgf = pgf { abstract = (abstract pgf) { - funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df, p,addr)) (funs (abstract pgf)) (funProbs probs), - cats = mapUnionWith (\(hypos,_,_,addr) (p,fns) -> (hypos,fns,p,addr)) (cats (abstract pgf)) (catProbs probs) + funs = mapUnionWith (\(ty,a,df,_) p -> (ty,a,df, p)) (funs (abstract pgf)) (funProbs probs), + cats = mapUnionWith (\(hypos,_,_) (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs probs) }} where mapUnionWith f map1 map2 = @@ -95,8 +95,8 @@ probTree :: PGF -> Expr -> Double probTree pgf t = case t of EApp f e -> probTree pgf f * probTree pgf e EFun f -> case Map.lookup f (funs (abstract pgf)) of - Just (_,_,_,p,_) -> p - Nothing -> 1 + Just (_,_,_,p) -> p + Nothing -> 1 _ -> 1 -- | rank from highest to lowest probability @@ -107,13 +107,13 @@ rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p) mkProbDefs :: PGF -> ([[CId]],[(CId,Type,[Equation])]) mkProbDefs pgf = - let cs = [(c,hyps,fns) | (c,(hyps0,fs,_,_)) <- Map.toList (cats (abstract pgf)), + let cs = [(c,hyps,fns) | (c,(hyps0,fs,_)) <- Map.toList (cats (abstract pgf)), not (elem c [cidString,cidInt,cidFloat]), let hyps = zipWith (\(bt,_,ty) n -> (bt,mkCId ('v':show n),ty)) hyps0 [1..] fns = [(f,ty) | (_,f) <- fs, - let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))] + let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))] ] ((_,css),eqss) = mapAccumL (\(ngen,css) (c,hyps,fns) -> let st0 = (1,Map.empty) @@ -263,7 +263,7 @@ computeConstrs pgf st fns = where addArgs (cn,fns) = addArg (length args) cn [] fns where - Just (ty@(DTyp args _ es),_,_,_,_) = Map.lookup cn (funs (abstract pgf)) + Just (ty@(DTyp args _ es),_,_,_) = Map.lookup cn (funs (abstract pgf)) addArg 0 cn ps fns = [(PApp cn (reverse ps),fns)] addArg n cn ps fns = concat [addArg (n-1) cn (arg:ps) fns' | (arg,fns') <- computeConstr fns] diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs index 5bebd89d6..f3747b805 100644 --- a/src/runtime/haskell/PGF/SortTop.hs +++ b/src/runtime/haskell/PGF/SortTop.hs @@ -38,7 +38,7 @@ showInOrder abs fset remset avset = isArg :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId] isArg abs mtypes scid cid = let p = Map.lookup cid $ funs abs - (ty,_,_,_,_) = fromJust p + (ty,_,_,_) = fromJust p args = arguments ty setargs = Set.fromList args cond = Set.null $ Set.difference setargs scid @@ -51,7 +51,7 @@ typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId typesInterm abs fset = let fs = funs abs fsetTypes = Set.map (\x -> - let (DTyp _ c _,_,_,_,_)=fromJust $ Map.lookup x fs + let (DTyp _ c _,_,_,_)=fromJust $ Map.lookup x fs in (x,c)) fset in Map.fromList $ Set.toList fsetTypes @@ -67,7 +67,7 @@ doesReturnCat (DTyp _ c _) cat = c == cat returnCat :: Abstr -> CId -> CId returnCat abs cid = let p = Map.lookup cid $ funs abs - (DTyp _ c _,_,_,_,_) = fromJust p + (DTyp _ c _,_,_,_) = fromJust p in if isNothing p then error $ "not found "++ show cid ++ " in abstract " else c diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index e582f97af..0818aeb4a 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -121,13 +121,13 @@ runTcM abstr f ms s = unTcM f abstr (\x ms s cp b -> let (es,xs) = cp b lookupCatHyps :: CId -> TcM s [Hypo] lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of - Just (hyps,_,_,_) -> k hyps ms - Nothing -> h (UnknownCat cat)) + Just (hyps,_,_) -> k hyps ms + Nothing -> h (UnknownCat cat)) lookupFunType :: CId -> TcM s Type lookupFunType fun = TcM (\abstr k h ms -> case Map.lookup fun (funs abstr) of - Just (ty,_,_,_,_) -> k ty ms - Nothing -> h (UnknownFun fun)) + Just (ty,_,_,_) -> k ty ms + Nothing -> h (UnknownFun fun)) typeGenerators :: Scope -> CId -> TcM s [(Double,Expr,TType)] typeGenerators scope cat = fmap normalize (liftM2 (++) x y) @@ -143,8 +143,8 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y) | cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))] | otherwise = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of - Just (_,fns,_,_) -> unTcM (mapM helper fns) abstr k h ms - Nothing -> h (UnknownCat cat)) + Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms + Nothing -> h (UnknownCat cat)) helper (p,fn) = do ty <- lookupFunType fn diff --git a/src/runtime/java/Test.java b/src/runtime/java/Test.java index 7ac11d8a3..08d6445cb 100644 --- a/src/runtime/java/Test.java +++ b/src/runtime/java/Test.java @@ -3,10 +3,10 @@ import java.util.*; import org.grammaticalframework.pgf.*; public class Test { - public static void main(String[] args) { + public static void main(String[] args) throws IOException { PGF gr = null; try { - gr = PGF.readPGF("Phrasebook.pgf"); + gr = PGF.readPGF("/home/krasimir/www.grammaticalframework.org/examples/phrasebook/Phrasebook.pgf"); } catch (FileNotFoundException e) { e.printStackTrace(); return; @@ -14,28 +14,19 @@ public class Test { e.printStackTrace(); return; } - + + Type typ = gr.getFunctionType("Bulgarian"); + System.out.println(typ.getCategory()); System.out.println(gr.getAbstractName()); for (Map.Entry entry : gr.getLanguages().entrySet()) { System.out.println(entry.getKey()+" "+entry.getValue()+" "+entry.getValue().getName()); entry.getValue().addLiteral("PN", new NercLiteralCallback(gr,entry.getValue())); } - - int count = 10; - for (ExprProb ep : gr.generateAll("Phrase")) { - System.out.println(ep.getExpr()); - - if (count-- <= 0) - break; - } - - Concr eng = gr.getLanguages().get("PhrasebookEng"); - Concr ger = gr.getLanguages().get("PhrasebookGer"); + Concr eng = gr.getLanguages().get("SimpleEng"); try { - for (ExprProb ep : eng.parse(gr.getStartCat(), "where is the hotel")) { + for (ExprProb ep : eng.parse(gr.getStartCat(), "persons who work with Malmö")) { System.out.println("["+ep.getProb()+"] "+ep.getExpr()); - System.out.println(ger.linearize(ep.getExpr())); } } catch (ParseError e) { System.out.println("Parsing failed at token \""+e.getToken()+"\""); -- cgit v1.2.3