diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs index 0e26994fe..2c407b880 100644 --- a/src/compiler/GF/Compile/GenerateBC.hs +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -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 diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index d725a052b..dc6965174 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -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 diff --git a/src/runtime/c/pgf/evaluator.c b/src/runtime/c/pgf/evaluator.c index 0e94792d0..a3f22e274 100644 --- a/src/runtime/c/pgf/evaluator.c +++ b/src/runtime/c/pgf/evaluator.c @@ -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) { diff --git a/src/runtime/c/pgf/evaluator.h b/src/runtime/c/pgf/evaluator.h index 6a24b72c7..3962e772f 100644 --- a/src/runtime/c/pgf/evaluator.h +++ b/src/runtime/c/pgf/evaluator.h @@ -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 diff --git a/src/runtime/c/pgf/jit.c b/src/runtime/c/pgf/jit.c index 77ef98399..1a9e25e6f 100644 --- a/src/runtime/c/pgf/jit.c +++ b/src/runtime/c/pgf/jit.c @@ -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) { diff --git a/src/runtime/c/pgf/lightning/core-common.h b/src/runtime/c/pgf/lightning/core-common.h index b60f0bf31..04dbb2c7b 100644 --- a/src/runtime/c/pgf/lightning/core-common.h +++ b/src/runtime/c/pgf/lightning/core-common.h @@ -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 diff --git a/src/runtime/c/pgf/lightning/i386/core-32.h b/src/runtime/c/pgf/lightning/i386/core-32.h index 9b1810761..561fab5fb 100644 --- a/src/runtime/c/pgf/lightning/i386/core-32.h +++ b/src/runtime/c/pgf/lightning/i386/core-32.h @@ -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)) diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index 64707f386..ae9a7e358 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -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) diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs index 158de0358..f5fc343b7 100644 --- a/src/runtime/haskell/PGF/ByteCode.hs +++ b/src/runtime/haskell/PGF/ByteCode.hs @@ -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) diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index 80a615e67..27b0623ea 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -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 '?'