GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-19 09:49:33 -06:00
Code Issues Packages Projects Releases Wiki Activity

a partial support for def rules in the C runtime

Browse Source 
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.
This commit is contained in:
kr.angelov
2014-08-11 10:59:10 +00:00
parent 1ce3569c82
commit 03b067782c
37 changed files with 707 additions and 455 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
src/runtime/c/Makefile.am
View File

@@ -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 \

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

@@ -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;

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

@@ -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;

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

@@ -1,23 +1,22 @@
#include <gu/seq.h>
#include <gu/file.h>
#include <pgf/data.h>
#include <pgf/jit.h>
#include <pgf/reasoner.h>
#include <pgf/evaluator.h>
#include <pgf/reader.h>
#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);
state->save_ip_ptr = jit_get_ip().ptr;
PgfAbsFun* absfun =
gu_map_get(abstr->funs, name, PgfAbsFun*);
assert(absfun != NULL);
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);
}

16
src/runtime/c/pgf/jit.h
View File

@@ -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

32
src/runtime/c/pgf/pgf.h
View File

@@ -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 <pgf/expr.h>
#include <pgf/graphviz.h>
/// 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);

72
src/runtime/c/pgf/reader.c
View File

@@ -2,7 +2,6 @@
#include "expr.h"
#include "literals.h"
#include "reader.h"
#include "jit.h"
#include <gu/defs.h>
#include <gu/map.h>
@@ -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);
pgf_jit_predicate(rdr, abstr, abscat);
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->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);
}

57
src/runtime/c/pgf/reader.h
View File

@@ -5,21 +5,64 @@
#include <gu/mem.h>
#include <gu/in.h>
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);
void
pgf_concrete_unload(PgfConcr* concr);
void
pgf_reader_done(PgfReader* rdr, PgfPGF* pgf);
// JIT specific interface
typedef struct PgfJitState PgfJitState;
PgfJitState*
pgf_new_jit(PgfReader* rdr);
void
pgf_jit_predicate(PgfReader* rdr, PgfAbstr* abstr,
PgfAbsCat* abscat);
void
pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
PgfAbsFun* absfun);
void
pgf_jit_done(PgfReader* state, PgfAbstr* abstr);
#endif // READER_H_

32
src/runtime/haskell/PGF.hs
View File

@@ -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')

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

@@ -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

47
src/runtime/haskell/PGF/ByteCode.hs Normal file
View File

@@ -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)

19
src/runtime/haskell/PGF/Data.hs
View File

@@ -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.

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

@@ -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

2
src/runtime/haskell/PGF/Forest.hs
View File

@@ -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)

1
src/runtime/haskell/PGF/Internal.hs
View File

@@ -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

2
src/runtime/haskell/PGF/Linearize.hs
View File

@@ -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) =

17
src/runtime/haskell/PGF/Macros.hs
View File

@@ -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

6
src/runtime/haskell/PGF/OldBinary.hs
View File

@@ -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

2
src/runtime/haskell/PGF/Paraphrase.hs
View File

@@ -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

23
src/runtime/haskell/PGF/Printer.hs
View File

@@ -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 ';'
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],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 ';'
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 =

20
src/runtime/haskell/PGF/Probabilistic.hs
View File

@@ -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]

6
src/runtime/haskell/PGF/SortTop.hs
View File

@@ -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

12
src/runtime/haskell/PGF/TypeCheck.hs
View File

@@ -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

23
src/runtime/java/Test.java
View File

@@ -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<String,Concr> 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()+"\"");