msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

now (+) in the abstract syntax works, i.e. it knows how to deal with partial sums

Browse Source
This commit is contained in:
kr.angelov
2014-10-31 14:16:11 +00:00
parent 9b0f354c7c
commit b1e6a21c56
7 changed files with 322 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

45
src/compiler/GF/Compile/GenerateBC.hs
View File

@@ -86,7 +86,7 @@ mkFail arity st1 (Just (st0,l))
| otherwise = [JUMP l]
compileBody gr arity st vs e bs =
let eval fun args
let eval st fun args
| arity == 0 = let (st1,is) = pushArgs (st+2) (reverse args)
fun' = shiftIVal st1 fun
in [PUSH_FRAME]++is++[EVAL fun' UpdateCall]
@@ -97,7 +97,7 @@ compileBody gr arity st vs e bs =
compileFun gr eval st vs (Abs _ x e) h0 bs args =
let (h1,bs1,arg,is1) = compileLambda gr st vs [x] e h0 bs
in (h1,bs1,is1++eval arg args)
in (h1,bs1,is1++eval st arg args)
compileFun gr eval st vs (App e1 e2) h0 bs args =
let (h1,bs1,arg,is1) = compileArg gr st vs e2 h0 bs
(h2,bs2,is2) = compileFun gr eval st vs e1 h1 bs1 (arg:args)
@@ -105,7 +105,7 @@ compileFun gr eval st vs (App e1 e2) h0 bs args =
compileFun gr eval st vs (Q (m,id)) h0 bs args =
case lookupAbsDef gr m id of
Ok (_,Just _)
-> (h0,bs,eval (GLOBAL (i2i id)) args)
-> (h0,bs,eval st (GLOBAL (i2i id)) args)
_ -> let Ok ty = lookupFunType gr m id
(ctxt,_,_) = typeForm ty
c_arity = length ctxt
@@ -114,9 +114,9 @@ compileFun gr eval st vs (Q (m,id)) h0 bs args =
diff = c_arity-n_args
in if diff <= 0
then if n_args == 0
then (h0,bs,eval (GLOBAL (i2i id)) [])
then (h0,bs,eval st (GLOBAL (i2i id)) [])
else let h1 = h0 + 2 + n_args
in (h1,bs,PUT_CONSTR (i2i id):is1++eval (HEAP h0) [])
in (h1,bs,PUT_CONSTR (i2i id):is1++eval st (HEAP h0) [])
else let h1 = h0 + 1 + n_args
is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
b = CHECK_ARGS diff :
@@ -126,34 +126,43 @@ compileFun gr eval st vs (Q (m,id)) h0 bs args =
TUCK (ARG_VAR 0) diff :
EVAL (HEAP h0) (TailCall diff) :
[]
in (h1,b:bs,PUT_CLOSURE (length bs):is1++eval (HEAP h0) [])
in (h1,b:bs,PUT_CLOSURE (length bs):is1++eval st (HEAP h0) [])
compileFun gr eval st vs (QC qid) h0 bs args =
compileFun gr eval st vs (Q qid) h0 bs args
compileFun gr eval st vs (Vr x) h0 bs args =
(h0,bs,eval (getVar vs x) args)
(h0,bs,eval st (getVar vs x) args)
compileFun gr eval st vs (EInt n) h0 bs _ =
let h1 = h0 + 2
in (h1,bs,PUT_LIT (LInt n) : eval (HEAP h0) [])
in (h1,bs,PUT_LIT (LInt n) : eval st (HEAP h0) [])
compileFun gr eval st vs (K s) h0 bs _ =
let h1 = h0 + 2
in (h1,bs,PUT_LIT (LStr s) : eval (HEAP h0) [])
in (h1,bs,PUT_LIT (LStr s) : eval st (HEAP h0) [])
compileFun gr eval st vs (EFloat d) h0 bs _ =
let h1 = h0 + 2
in (h1,bs,PUT_LIT (LFlt d) : eval (HEAP h0) [])
in (h1,bs,PUT_LIT (LFlt d) : eval st (HEAP h0) [])
compileFun gr eval st vs (Typed e _) h0 bs args =
compileFun gr eval st vs e h0 bs args
compileFun gr eval st vs (Let (x, (_, e1)) e2) h0 bs args =
let (h1,bs1,arg,is1) = compileLambda gr st vs [] e1 h0 bs
(h2,bs2,is2) = compileFun gr eval st ((x,arg):vs) e2 h1 bs1 args
in (h2,bs2,is1++is2)
compileFun gr eval st vs (Glue e1 e2) h0 bs args =
let eval' fun args = [PUSH_FRAME]++is++[EVAL fun' RecCall]
where
(st1,is) = pushArgs (st+2) (reverse args)
fun' = shiftIVal st fun
(h1,bs1,is1) = compileFun gr eval' st vs e1 h0 bs args
(h2,bs2,is2) = compileFun gr eval' st vs e2 h1 bs1 args
in (h2,bs2,is1++is2++[ADD])
compileFun gr eval st vs e@(Glue e1 e2) h0 bs args =
let eval' st fun args = [PUSH_FRAME]++is++[EVAL fun' RecCall]
where
(st1,is) = pushArgs (st+2) (reverse args)
fun' = shiftIVal st fun
flatten (Glue e1 e2) h0 bs =
let (h1,bs1,is1) = flatten e1 h0 bs
(h2,bs2,is2) = flatten e2 h1 bs1
in (h2,bs2,is1++is2)
flatten e h0 bs =
let (h1,bs1,is1) = compileFun gr eval' (st+3) vs e h0 bs args
in (h1,bs1,is1++[ADD])
(h1,bs1,is) = flatten e h0 bs
in (h1,bs1,[PUSH_ACCUM (LFlt 0)]++is++[POP_ACCUM]++eval (st+1) (ARG_VAR st) [])
compileFun gr eval st vs e _ _ _ = error (show e)
compileArg gr st vs (Q(m,id)) h0 bs =

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

@@ -141,7 +141,9 @@ typedef enum {
PGF_INSTR_DROP = 16,
PGF_INSTR_JUMP = 17,
PGF_INSTR_FAIL = 18,
PGF_INSTR_ADD = 19,
PGF_INSTR_PUSH_ACCUM = 19,
PGF_INSTR_POP_ACCUM = 20,
PGF_INSTR_ADD = 21,
} PgfInstruction;
typedef GuSeq PgfConcrs;

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

@@ -313,6 +313,48 @@ pgf_value2expr(PgfEvalState* state, int level, PgfClosure* clos, GuPool* pool)
PgfExprVar,
&expr, pool);
evar->var = level - fun->level - 1;
} else if (val->fun->code == state->eval_gates->evaluate_sum) {
PgfValueSum* sum = (PgfValueSum*) val->fun;
PgfExpr e1,e2;
PgfExprFun *efun =
gu_new_flex_variant(PGF_EXPR_FUN,
PgfExprFun,
fun, 2,
&e1, pool);
strcpy(efun->fun, "+");
PgfExprLit *elit =
gu_new_variant(PGF_EXPR_LIT,
PgfExprLit,
&e2, pool);
elit->lit = sum->lit;
PgfExprApp* eapp =
gu_new_variant(PGF_EXPR_APP,
PgfExprApp,
&expr, pool);
eapp->fun = e1;
eapp->arg = e2;
size_t n_consts = gu_buf_length(sum->consts);
for (size_t i = 0; i < n_consts; i++) {
PgfClosure* con =
gu_buf_get(sum->consts, PgfClosure*, i);
PgfExpr fun = expr;
PgfExpr arg =
pgf_value2expr(state, level, con, pool);
if (gu_variant_is_null(arg))
return gu_null_variant;
PgfExprApp* e =
gu_new_variant(PGF_EXPR_APP,
PgfExprApp,
&expr, pool);
e->fun = fun;
e->arg = arg;
}
} else {
PgfAbsFun* absfun = gu_container(val->fun, PgfAbsFun, closure);
expr = absfun->ep.expr;
@@ -370,3 +412,118 @@ pgf_compute(PgfPGF* pgf, PgfExpr expr, GuExn* err, GuPool* pool, GuPool* out_poo
return pgf_value2expr(state, 0, &thunk->header, out_pool);
}
void
pgf_evaluate_accum_init_int(PgfEvalState* state,
PgfEvalAccum* accum, int val)
{
PgfLiteralInt *lit_int =
gu_new_variant(PGF_LITERAL_INT,
PgfLiteralInt,
&accum->lit,
state->pool);
lit_int->val = val;
accum->consts = NULL;
}
void
pgf_evaluate_accum_init_str(PgfEvalState* state,
PgfEvalAccum* accum, GuString val)
{
if (val == NULL)
val = "";
PgfLiteralStr *lit_str =
gu_new_flex_variant(PGF_LITERAL_STR,
PgfLiteralStr,
val, strlen(val)+1,
&accum->lit, state->pool);
strcpy((char*) lit_str->val, (char*) val);
accum->consts = NULL;
}
void
pgf_evaluate_accum_init_flt(PgfEvalState* state,
PgfEvalAccum* accum, float val)
{
PgfLiteralFlt *lit_flt =
gu_new_variant(PGF_LITERAL_FLT,
PgfLiteralFlt,
&accum->lit,
state->pool);
lit_flt->val = val;
accum->enter_stack_ptr = state->enter_stack_ptr;
state->enter_stack_ptr = ((void*)accum)-sizeof(void*)*2;
accum->consts = NULL;
}
static void
pgf_evaluate_accum_add_helper(PgfEvalAccum* accum, PgfLiteral lit)
{
GuVariantInfo ei = gu_variant_open(lit);
switch (ei.tag) {
case PGF_LITERAL_INT: {
PgfLiteralInt* lint = ei.data;
((PgfLiteralInt*)gu_variant_data(accum->lit))->val += lint->val;
break;
}
case PGF_LITERAL_STR: {
PgfLiteralStr* lstr = ei.data;
break;
}
case PGF_LITERAL_FLT: {
PgfLiteralFlt* lflt = ei.data;
((PgfLiteralFlt*)gu_variant_data(accum->lit))->val += lflt->val;
break;
}
}
}
void
pgf_evaluate_accum_add(PgfEvalState* state,
PgfEvalAccum* accum, PgfClosure* closure)
{
if (closure->code == state->eval_gates->evaluate_value_lit) {
PgfValueLit* val = (PgfValueLit*) closure;
pgf_evaluate_accum_add_helper(accum, val->lit);
} else if (closure->code == state->eval_gates->evaluate_value_const) {
if (accum->consts == NULL)
accum->consts = gu_new_buf(PgfClosure*, state->pool);
PgfValuePAP* pap = (PgfValuePAP*) closure;
if (pap->fun->code == state->eval_gates->evaluate_sum) {
PgfValueSum* val = (PgfValueSum*) ((PgfValuePAP*) closure)->fun;
pgf_evaluate_accum_add_helper(accum, val->lit);
size_t n_consts = gu_buf_length(val->consts);
for (size_t i = 0; i < n_consts; i++) {
PgfClosure* clos = gu_buf_get(val->consts, PgfClosure*, i);
gu_buf_push(accum->consts, PgfClosure*, clos);
}
} else {
gu_buf_push(accum->consts, PgfClosure*, closure);
}
} else {
gu_impossible();
}
}
PgfClosure*
pgf_evaluate_accum_done(PgfEvalState* state, PgfEvalAccum* accum)
{
state->enter_stack_ptr = accum->enter_stack_ptr;
if (accum->consts == NULL) {
PgfValueLit* val = gu_new(PgfValueLit, state->pool);
val->header.code = state->eval_gates->evaluate_value_lit;
val->lit = accum->lit;
return &val->header;
} else {
PgfValueSum* val = gu_new(PgfValueSum, state->pool);
val->header.code = state->eval_gates->evaluate_sum;
val->lit = accum->lit;
val->consts = accum->consts;
return &val->header;
}
}

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

@@ -15,9 +15,17 @@ typedef struct {
PgfEvalGates* eval_gates; // cached from pgf->abstr->eval_gates
GuPool* pool;
GuExn* err;
void* enter_stack_ptr;
void* tmp; // for temporary register spills
PgfIndirection cafs[]; // derived from gu_seq_data(pgf->abstr->eval_gates->cafs)
} PgfEvalState;
typedef struct {
PgfLiteral lit;
GuBuf* consts;
void* enter_stack_ptr;
} PgfEvalAccum;
typedef struct PgfEnv PgfEnv;
struct PgfEnv {
@@ -53,6 +61,12 @@ typedef struct {
PgfLiteral lit;
} PgfValueLit;
typedef struct {
PgfClosure header;
PgfLiteral lit;
GuBuf* consts;
} PgfValueSum;
typedef struct {
PgfClosure header;
PgfClosure* fun;
@@ -70,6 +84,7 @@ struct PgfEvalGates {
PgfFunction evaluate_value_const;
PgfFunction evaluate_meta;
PgfFunction evaluate_gen;
PgfFunction evaluate_sum;
PgfFunction evaluate_caf;
PgfFunction update_closure;
@@ -90,4 +105,23 @@ PgfClosure*
pgf_evaluate_lambda_application(PgfEvalState* state, PgfExprThunk* lambda,
PgfClosure* arg);
void
pgf_evaluate_accum_init_int(PgfEvalState* state,
PgfEvalAccum* accum, int val);
void
pgf_evaluate_accum_init_str(PgfEvalState* state,
PgfEvalAccum* accum, GuString val);
void
pgf_evaluate_accum_init_flt(PgfEvalState* state,
PgfEvalAccum* accum, float val);
void
pgf_evaluate_accum_add(PgfEvalState* state,
PgfEvalAccum* accum, PgfClosure* closure);
PgfClosure*
pgf_evaluate_accum_done(PgfEvalState* state, PgfEvalAccum* accum);
#endif

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

@@ -371,9 +371,9 @@ pgf_jit_gates(PgfReader* rdr)
int closure_arg = jit_arg_p();
jit_getarg_p(JIT_VSTATE, es_arg);
jit_getarg_p(JIT_VCLOS, closure_arg);
jit_stxi_p(offsetof(PgfEvalState, enter_stack_ptr), JIT_VSTATE, JIT_SP);
jit_ldr_p(JIT_R0, JIT_VCLOS);
jit_callr(JIT_R0);
jit_insn* enter_ret = (void*) jit_get_ip().ptr;
jit_movr_p(JIT_RET, JIT_VHEAP);
jit_ret();
@@ -547,7 +547,9 @@ pgf_jit_gates(PgfReader* rdr)
jit_pushr_p(JIT_R0);
jit_jmpi(gates->mk_const);
jit_patch(ref2);
ref2 = jit_bnei_i(jit_forward(), JIT_R0, (int)enter_ret);
jit_ldxi_p(JIT_R1, JIT_VSTATE, offsetof(PgfEvalState,enter_stack_ptr));
ref2 = jit_bner_p(jit_forward(), JIT_FP, JIT_R1);
jit_stxi_p(offsetof(PgfEvalState,tmp), JIT_VSTATE, JIT_R0);
jit_subr_p(JIT_R0, JIT_FP, JIT_SP);
jit_pushr_i(JIT_R0);
jit_prepare(2);
@@ -556,8 +558,8 @@ pgf_jit_gates(PgfReader* rdr)
jit_ldxi_p(JIT_R0, JIT_VSTATE, offsetof(PgfEvalState,pool));
jit_pusharg_p(JIT_R0);
jit_finish(gu_malloc);
jit_popr_i(JIT_R1);
jit_movr_p(JIT_VHEAP, JIT_RET);
jit_popr_i(JIT_R1);
jit_movi_p(JIT_R2, gates->evaluate_value_const);
jit_str_p(JIT_VHEAP, JIT_R2);
jit_stxi_p(offsetof(PgfValuePAP,fun), JIT_VHEAP, JIT_VCLOS);
@@ -570,7 +572,8 @@ pgf_jit_gates(PgfReader* rdr)
jit_subi_i(JIT_R1, JIT_R1, sizeof(void*));
jit_jmpi(next);
jit_patch(ref);
jit_jmpi(enter_ret);
jit_ldxi_p(JIT_R0, JIT_VSTATE, offsetof(PgfEvalState,tmp));
jit_jmpr(JIT_R0);
jit_patch(ref2);
jit_ldxi_p(JIT_VCLOS, JIT_FP, sizeof(void*));
jit_ldr_p(JIT_FP, JIT_FP);
@@ -581,16 +584,21 @@ pgf_jit_gates(PgfReader* rdr)
jit_movr_p(JIT_SP, JIT_R0);
jit_jmpi(gates->mk_const);
pgf_jit_make_space(rdr, JIT_CODE_WINDOW*2);
pgf_jit_make_space(rdr, JIT_CODE_WINDOW);
gates->evaluate_gen = jit_get_ip().ptr;
jit_jmpi(gates->mk_const);
pgf_jit_make_space(rdr, JIT_CODE_WINDOW*2);
pgf_jit_make_space(rdr, JIT_CODE_WINDOW);
gates->evaluate_meta = jit_get_ip().ptr;
jit_jmpi(gates->mk_const);
pgf_jit_make_space(rdr, JIT_CODE_WINDOW);
gates->evaluate_sum = jit_get_ip().ptr;
jit_jmpi(gates->mk_const);
gates->fin.fn = pgf_jit_finalize_cafs;
gates->cafs = NULL;
gu_pool_finally(rdr->opool, &gates->fin);
@@ -1167,10 +1175,88 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
#endif
jit_jmpi(abstr->eval_gates->mk_const);
break;
case PGF_INSTR_PUSH_ACCUM:
jit_subi_p(JIT_SP, JIT_SP, sizeof(PgfEvalAccum));
switch (mod) {
case 0: {
int val = pgf_read_int(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUSH_ACCUM %d\n", val);
#endif
jit_prepare(3);
jit_movi_i(JIT_R0, val);
jit_movr_p(JIT_R1, JIT_SP);
jit_pusharg_p(JIT_R0);
jit_pusharg_p(JIT_R1);
jit_pusharg_p(JIT_VSTATE);
jit_finish(pgf_evaluate_accum_init_int);
break;
}
case 1: {
size_t len = pgf_read_len(rdr);
uint8_t* buf = alloca(len*6+1);
uint8_t* p = buf;
for (size_t i = 0; i < len; i++) {
gu_in_utf8_buf(&p, rdr->in, rdr->err);
}
*p++ = 0;
GuString val =
*buf ? gu_string_copy((GuString) buf, rdr->opool)
: NULL;
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUSH_ACCUM \"%s\"\n", buf);
#endif
jit_prepare(3);
jit_movi_p(JIT_R0, val);
jit_movr_p(JIT_R1, JIT_SP);
jit_pusharg_p(JIT_R0);
jit_pusharg_p(JIT_R1);
jit_pusharg_p(JIT_VSTATE);
jit_finish(pgf_evaluate_accum_init_str);
break;
}
case 2: {
double val = pgf_read_double(rdr);
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "PUSH_ACCUM %f\n", val);
#endif
jit_prepare_d(1);
jit_prepare_i(2);
jit_movi_d(JIT_FPR0, val);
jit_movr_p(JIT_R1, JIT_SP);
jit_pusharg_d(JIT_FPR0);
jit_pusharg_p(JIT_R1);
jit_pusharg_p(JIT_VSTATE);
jit_finish(pgf_evaluate_accum_init_flt);
break;
}
default:
gu_impossible();
}
break;
case PGF_INSTR_POP_ACCUM:
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "POP_ACCUM\n");
#endif
jit_prepare(2);
jit_pusharg_p(JIT_SP);
jit_pusharg_p(JIT_VSTATE);
jit_finish(pgf_evaluate_accum_done);
jit_addi_p(JIT_SP, JIT_SP, sizeof(PgfEvalAccum));
jit_pushr_p(JIT_RET);
break;
case PGF_INSTR_ADD:
#ifdef PGF_JIT_DEBUG
gu_printf(out, err, "ADD\n");
#endif
jit_prepare(3);
jit_movr_p(JIT_R1, JIT_SP);
jit_pusharg_p(JIT_VHEAP);
jit_pusharg_p(JIT_R1);
jit_pusharg_p(JIT_VSTATE);
jit_finish(pgf_evaluate_accum_add);
break;
default:
gu_impossible();

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

@@ -177,7 +177,11 @@ instance Binary Instr where
put (DROP n ) = putWord8 64 >> put n
put (JUMP l ) = putWord8 68 >> put l
put (FAIL ) = putWord8 72
put (ADD ) = putWord8 76
put (PUSH_ACCUM (LInt n)) = putWord8 76 >> put n
put (PUSH_ACCUM (LStr s)) = putWord8 77 >> put s
put (PUSH_ACCUM (LFlt d)) = putWord8 78 >> put d
put (POP_ACCUM ) = putWord8 80
put (ADD ) = putWord8 84
instance Binary Type where
put (DTyp hypos cat exps) = put (hypos,cat,exps)

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

@@ -32,6 +32,8 @@ data Instr
| DROP {-# UNPACK #-} !Int
| JUMP {-# UNPACK #-} !CodeLabel
| FAIL
| PUSH_ACCUM Literal
| POP_ACCUM
| ADD
data IVal
@@ -71,6 +73,8 @@ ppInstr (TUCK v n ) = text "TUCK " <+> ppIVal v <+> int n
ppInstr (DROP n ) = text "DROP " <+> int n
ppInstr (JUMP l ) = text "JUMP " <+> ppLabel l
ppInstr (FAIL ) = text "FAIL"
ppInstr (PUSH_ACCUM lit) = text "PUSH_ACCUM " <+> ppLit lit
ppInstr (POP_ACCUM ) = text "POP_ACCUM"
ppInstr (ADD ) = text "ADD"
ppIVal (HEAP n) = text "hp" <> parens (int n)