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

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

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

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

@@ -4,7 +4,7 @@ import GF.Grammar
import GF.Grammar.Lookup(lookupAbsDef)
import GF.Data.Operations
import PGF(CId,utf8CId)
import PGF.Internal(Instr(..))
import PGF.Internal(Instr(..),IVal(..),TailInfo(..),Literal(..))
import qualified Data.Map as Map
import Data.List(nub)
@@ -46,108 +46,128 @@ compileEquations gr st (i:is) eqs bs = whilePP eqs Map.empty
let case_instr =
case t of
(Q (_,id)) -> CASE (i2i id)
(EInt n) -> CASE_INT n
(K s) -> CASE_STR s
(EFloat d) -> CASE_FLT d
(EInt n) -> CASE_LIT (LInt n)
(K s) -> CASE_LIT (LStr s)
(EFloat d) -> CASE_LIT (LFlt d)
(bs1,instrs) = compileEquations gr (st+n) (push_is st n is) eqs bs
in (bs1, EVAL_ARG_VAR (st-i-1) : case_instr (length bs1) : instrs)
in (bs1, EVAL (ARG_VAR (st-i-1)) RecCall : case_instr (length bs1) : instrs)
compileBranch ((t,n),eqs) bs =
let case_instr =
case t of
(Q (_,id)) -> CASE (i2i id)
(EInt n) -> CASE_INT n
(K s) -> CASE_STR s
(EFloat d) -> CASE_FLT d
(EInt n) -> CASE_LIT (LInt n)
(K s) -> CASE_LIT (LStr s)
(EFloat d) -> CASE_LIT (LFlt d)
(bs1,instrs) = compileEquations gr (st+n) (push_is st n is) eqs ((case_instr (length bs1) : instrs) : bs)
in bs1
compileBody gr st avs fvs e bs es =
let (heap,bs1,instrs) = compileFun gr st avs fvs e 0 bs es
in (bs1,((if heap > 0 then (ALLOC heap :) else id) .
(instrs ++) .
(if st == 0 then (UPDATE :) else id))
[RET st])
in (bs1,if heap > 0 then (ALLOC heap : instrs) else instrs)
compileFun gr st avs fvs (Abs _ x e) h0 bs es =
let (h1,bs1,_,_,is) = compileLambda gr st st avs fvs [x] e h0 bs
(st1,h2,bs2,is1,is2,is3) = compileArgs gr st st avs fvs h1 bs1 (reverse es)
in (h2,bs2,is++is3++is2++(if st == 0 then [EVAL (HEAP h0) RecCall,UPDATE,RET st] else [EVAL (HEAP h0) (TailCall st st1)]))
compileFun gr st avs fvs (App e1 e2) h0 bs es =
compileFun gr st avs fvs e1 h0 bs (e2:es)
compileFun gr st avs fvs (Q (m,id)) h0 bs es =
case lookupAbsDef gr m id of
Ok (_,Just _)
-> let (h1,bs1,is1,is2,is3) = compileArgs gr st st avs fvs h0 bs (reverse es)
in (h1,bs1,is3 ++ is2 ++ [TAIL_CALL (i2i id)])
-> let (st1,h1,bs1,is1,is2,is3) = compileArgs gr st st avs fvs h0 bs (reverse es)
in (h1,bs1,is3 ++ is2 ++ []++(if st == 0 then [CALL (i2i id) RecCall,UPDATE,RET st] else [CALL (i2i id) (TailCall st st1)]))
_ -> let h1 = h0 + 2 + length es
(h2,bs2,is1,is2,is3) = compileArgs gr st st avs fvs h1 bs es
in (h2,bs2,PUT_CONSTR (i2i id) : is1 ++ is3)
(_,h2,bs2,is1,is2,is3) = compileArgs gr st st avs fvs h1 bs es
in (h2,bs2,PUT_CONSTR (i2i id) : is1 ++ is3 ++ (if st == 0 then [UPDATE] else []) ++ [RET st])
compileFun gr st avs fvs (QC qid) h0 bs es =
compileFun gr st avs fvs (Q qid) h0 bs es
compileFun gr st avs fvs (Vr x) h0 bs es =
let (h1,bs1,is1,is2,is3) = compileArgs gr st st avs fvs h0 bs (reverse es)
i = case lookup x avs of
Just i -> EVAL_ARG_VAR (st-i-1)
Nothing -> case lookup x fvs of
Just i -> EVAL_FREE_VAR i
Nothing -> error "compileFun: unknown variable"
in (h1,bs1,is3 ++ is2 ++ [i])
let (st1,h1,bs1,is1,is2,is3) = compileArgs gr st st avs fvs h0 bs (reverse es)
mki = case lookup x avs of
Just i -> EVAL (ARG_VAR (st1-i-1))
Nothing -> case lookup x fvs of
Just i -> EVAL (FREE_VAR i)
Nothing -> error "compileFun: unknown variable"
in (h1,bs1,is3 ++ is2 ++ (if st == 0 then [mki RecCall,UPDATE,RET st] else [mki (TailCall st st1)]))
compileFun gr st avs fvs (EInt n) h0 bs _ =
let h1 = h0 + 2
in (h1,bs,[PUT_INT n])
in (h1,bs,[PUT_LIT (LInt n)]++(if st == 0 then [UPDATE] else [])++[RET st])
compileFun gr st avs fvs (K s) h0 bs _ =
let h1 = h0 + 1 + (length s + 4) `div` 4
in (h1,bs,[PUT_STR s])
in (h1,bs,[PUT_LIT (LStr s)]++(if st == 0 then [UPDATE] else [])++[RET st])
compileFun gr st avs fvs (EFloat d) h0 bs _ =
let h1 = h0 + 3
in (h1,bs,[PUT_FLT d])
in (h1,bs,[PUT_LIT (LFlt d)]++(if st == 0 then [UPDATE] else [])++[RET st])
compileFun gr st avs fvs e _ _ _ = error (show e)
compileArgs gr st st0 avs fvs h0 bs [] =
(h0,bs,[],[],[])
(st0,h0,bs,[],[],[])
compileArgs gr st st0 avs fvs h0 bs (e:es) =
(h2,bs2,i1:is1,i2:is2,is++is3)
(st1,h2,bs2,i1:is1,i2:is2,is++is3)
where
(h1,bs1,i1,i2,is) = compileArg gr st st0 avs fvs e h0 bs []
(h2,bs2,is1,is2,is3) = compileArgs gr st (st0+1) avs fvs h1 bs1 es
(st1,h2,bs2,is1,is2,is3) = compileArgs gr st (st0+1) avs fvs h1 bs1 es
compileArg gr st st0 avs fvs (Abs _ x e) h0 bs es =
compileLambda gr st st0 avs fvs [x] e h0 bs
compileArg gr st st0 avs fvs (App e1 e2) h0 bs es = compileArg gr st st0 avs fvs e1 h0 bs (e2:es)
compileArg gr st st0 avs fvs e@(Q(m,id)) h0 bs es =
case lookupAbsDef gr m id of
Ok (_,Just _)
-> if null es
then let h1 = h0 + 2
in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_FUN (i2i id),SET_PAD])
else let es_fvs = nub (foldr freeVars [] es)
in (h1,bs,SET (HEAP h0),PUSH (HEAP h0),[PUT_FUN (i2i id),SET_PAD])
else let es_fvs = nub (foldr (\e fvs -> freeVars [] fvs e) [] es)
h1 = h0 + 1 + length is
(bs1,b) = compileBody gr 0 [] (zip es_fvs [0..]) e bs es
is = if null es_fvs
then [SET_PAD]
else map (fst . compileVar st st0 avs fvs) es_fvs
in (h1,(ENTER:b):bs1,SET_VALUE h0,PUSH_VALUE h0,PUT_CLOSURE (length bs) : is)
in (h1,(ENTER:b):bs1,SET (HEAP h0),PUSH (HEAP h0),PUT_CLOSURE (length bs) : is)
_ -> let h1 = h0 + 2 + length es
(h2,bs2,is1,is2,is3) = compileArgs gr st st avs fvs h1 bs es
in (h2,bs2,SET_VALUE h0,PUSH_VALUE h0,PUT_CONSTR (i2i id) : is1 ++ is3)
(_,h2,bs2,is1,is2,is3) = compileArgs gr st st avs fvs h1 bs es
in (h2,bs2,SET (HEAP h0),PUSH (HEAP h0),PUT_CONSTR (i2i id) : is1 ++ is3)
compileArg gr st st0 avs fvs (QC qid) h0 bs es = compileArg gr st st0 avs fvs (Q qid) h0 bs es
compileArg gr st st0 avs fvs (Vr x) h0 bs es =
let (i1,i2) = compileVar st st0 avs fvs x
in (h0,bs,i1,i2,[])
compileArg gr st st0 avs fvs (EInt n) h0 bs _ =
let h1 = h0 + 2
in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_INT n])
in (h1,bs,SET (HEAP h0),PUSH (HEAP h0),[PUT_LIT (LInt n)])
compileArg gr st st0 avs fvs (K s) h0 bs _ =
let h1 = h0 + 1 + (length s + 4) `div` 4
in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_STR s])
in (h1,bs,SET (HEAP h0),PUSH (HEAP h0),[PUT_LIT (LStr s)])
compileArg gr st st0 avs fvs (EFloat d) h0 bs _ =
let h1 = h0 + 3
in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_FLT d])
in (h1,bs,SET (HEAP h0),PUSH (HEAP h0),[PUT_LIT (LFlt d)])
compileVar st st0 avs fvs x =
case lookup x avs of
Just i -> (SET_ARG_VAR (st-i-1),PUSH_ARG_VAR (st0-i-1))
Just i -> (SET (ARG_VAR (st-i-1)),PUSH (ARG_VAR (st0-i-1)))
Nothing -> case lookup x fvs of
Just i -> (SET_FREE_VAR i,PUSH_FREE_VAR i)
Just i -> (SET (FREE_VAR i),PUSH (FREE_VAR i))
Nothing -> error "compileVar: unknown variable"
freeVars (App e1 e2) vs = (freeVars e1 . freeVars e2) vs
freeVars (Vr x) vs = x:vs
freeVars _ vs = vs
compileLambda gr st st0 avs fvs e_avs (Abs _ x e) h0 bs =
compileLambda gr st st0 avs fvs (x:e_avs) e h0 bs
compileLambda gr st st0 avs fvs e_avs e h0 bs =
let e_fvs = freeVars e_avs [] e
(bs1,b) = compileBody gr (length e_avs)
(zip e_avs [0..])
(zip e_fvs [0..])
e bs []
is = if null e_fvs
then [SET_PAD]
else map (fst . compileVar st st0 avs fvs) e_fvs
h1 = h0 + 1 + length is
in (h1,(ENTER:b):bs1,SET (HEAP h0),PUSH (HEAP h0),PUT_CLOSURE (length bs) : is)
freeVars avs fvs (Abs _ x e) = freeVars (x:avs) fvs e
freeVars avs fvs (App e1 e2) = freeVars avs (freeVars avs fvs e2) e1
freeVars avs fvs (Vr x)
| not (elem x avs) = x:fvs
freeVars avs fvs _ = fvs
i2i :: Ident -> CId
i2i = utf8CId . ident2utf8

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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