From bfd414554d2bb114baa8acc176744d55367eabb3 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Mon, 1 Sep 2014 14:51:20 +0000 Subject: [PATCH] partial implementation for recursive def rules --- src/compiler/GF/Compile/GenerateBC.hs | 80 ++++++++++++++----------- src/compiler/GF/Compile/GrammarToPGF.hs | 8 +-- src/runtime/c/pgf/data.h | 2 + src/runtime/c/pgf/jit.c | 49 +++++++++++++++ src/runtime/haskell/PGF/Binary.hs | 8 ++- src/runtime/haskell/PGF/ByteCode.hs | 6 +- 6 files changed, 110 insertions(+), 43 deletions(-) diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs index 393c6722e..488368887 100644 --- a/src/compiler/GF/Compile/GenerateBC.hs +++ b/src/compiler/GF/Compile/GenerateBC.hs @@ -1,23 +1,26 @@ module GF.Compile.GenerateBC(generateByteCode) where import GF.Grammar +import GF.Grammar.Lookup(lookupAbsDef) +import GF.Data.Operations import PGF(CId,utf8CId) import PGF.Internal(Instr(..)) import qualified Data.Map as Map +import Data.List(mapAccumL) -generateByteCode :: Int -> [L Equation] -> [Instr] -generateByteCode arity eqs = - compileEquations arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) +generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [Instr] +generateByteCode gr arity eqs = + compileEquations gr arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) where is = push_is (arity-1) arity [] -compileEquations :: Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [Instr] -compileEquations st _ [] = [FAIL] -compileEquations st [] ((vs,[],t):_) = - let (heap,instrs) = compileBody st vs t 0 [] +compileEquations :: SourceGrammar -> Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [Instr] +compileEquations gr st _ [] = [FAIL] +compileEquations gr st [] ((vs,[],t):_) = + let (heap,instrs) = compileBody gr st vs t 0 [] in (if heap > 0 then (ALLOC heap :) else id) (instrs ++ [RET st]) -compileEquations st (i:is) eqs = whilePP eqs Map.empty +compileEquations gr st (i:is) eqs = whilePP eqs Map.empty where whilePP [] cns = mkCase cns [] whilePP ((vs, PP c ps' : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (Q c,length ps') [(vs,ps'++ps,t)] cns) @@ -29,13 +32,13 @@ compileEquations st (i:is) eqs = whilePP eqs Map.empty whilePV [] cns vrs = mkCase cns (reverse vrs) whilePV ((vs, PV x : ps, t):eqs) cns vrs = whilePV eqs cns (((x,i):vs,ps,t) : vrs) whilePV ((vs, PW : ps, t):eqs) cns vrs = whilePV eqs cns (( vs,ps,t) : vrs) - whilePV eqs cns vrs = mkCase cns (reverse vrs) ++ compileEquations st (i:is) eqs + whilePV eqs cns vrs = mkCase cns (reverse vrs) ++ compileEquations gr st (i:is) eqs mkCase cns vrs - | Map.null cns = compileEquations st is vrs + | Map.null cns = compileEquations gr st is vrs | otherwise = EVAL (st-i-1) : concat [compileBranch t n eqs | ((t,n),eqs) <- Map.toList cns] ++ - compileEquations st is vrs + compileEquations gr st is vrs compileBranch t n eqs = let case_instr = @@ -44,32 +47,39 @@ compileEquations st (i:is) eqs = whilePP eqs Map.empty (EInt n) -> CASE_INT n (K s) -> CASE_STR s (EFloat d) -> CASE_FLT d - instrs = compileEquations (st+n) (push_is st n is) eqs + instrs = compileEquations gr (st+n) (push_is st n is) eqs in case_instr (length instrs) : instrs - -compileBody st vs (App e1 e2) h0 os = - case e2 of - Vr x -> case lookup x vs of - Just i -> compileBody st vs e1 h0 (SET_VARIABLE (st-i-1):os) - Nothing -> error "compileBody: unknown variable" - e2 -> let (h1,is1) = compileBody st vs e1 h0 (SET_VALUE h1:os) - (h2,is2) = compileBody st vs e2 h1 [] - in (h2,is1 ++ is2) -compileBody st vs (QC (_,id)) h0 os = let h1 = h0 + 2 + length os - in (h1,PUT_CONSTR (i2i id) : os) -compileBody st vs (Q (_,id)) h0 os = let h1 = h0 + 2 + length os - in (h1,PUT_CONSTR (i2i id) : os) -compileBody st vs (Vr x) h0 os = case lookup x vs of - Just i -> (h0,EVAL (st-i-1) : os) - Nothing -> error "compileBody: unknown variable" -compileBody st vs (EInt n) h0 os = let h1 = h0 + 2 - in (h1,PUT_INT n : os) -compileBody st vs (K s) h0 os = let h1 = h0 + 1 + (length s + 4) `div` 4 - in (h1,PUT_STR s : os) -compileBody st vs (EFloat d) h0 os = let h1 = h0 + 3 - in (h1,PUT_FLT d : os) -compileBody st vs t _ _ = error (show t) +compileBody gr st vs (App e1 e2) h0 es = compileBody gr st vs e1 h0 (e2:es) +compileBody gr st vs (Q (m,id)) h0 es = case lookupAbsDef gr m id of + Ok (Just _,Just _) + -> let ((h1,st1),iis) = mapAccumL (compileArg gr st vs) (h0,st) (reverse es) + (is1,is2,is3) = unzip3 iis + in (h1,concat is3 ++ is2 ++ [TAIL_CALL (i2i id)]) + _ -> let h1 = h0 + 2 + length es + ((h2,st1),iis) = mapAccumL (compileArg gr st vs) (h1,st) es + (is1,is2,is3) = unzip3 iis + in (h2,PUT_CONSTR (i2i id) : concat (is1:is3)) +compileBody gr st vs (QC qid) h0 es = compileBody gr st vs (Q qid) h0 es +compileBody gr st vs (Vr x) h0 es = case lookup x vs of + Just i -> let ((h1,st1),iis) = mapAccumL (compileArg gr st vs) (h0,st) (reverse es) + (is1,is2,is3) = unzip3 iis + in (h1,concat is3 ++ is2 ++ [EVAL (st-i-1)]) + Nothing -> error "compileBody: unknown variable" +compileBody gr st vs (EInt n) h0 _ = let h1 = h0 + 2 + in (h1,[PUT_INT n]) +compileBody gr st vs (K s) h0 _ = let h1 = h0 + 1 + (length s + 4) `div` 4 + in (h1,[PUT_STR s]) +compileBody gr st vs (EFloat d) h0 _ = let h1 = h0 + 3 + in (h1,[PUT_FLT d]) + +compileArg gr st vs (h0,st0) (Vr x) = + case lookup x vs of + Just i -> ((h0,st0+1),(SET_VARIABLE (st-i-1),PUSH_VARIABLE (st0-i-1),[])) + Nothing -> error "compileFunArg: unknown variable" +compileArg gr st vs (h0,st0) e = + let (h1,is2) = compileBody gr st vs e h0 [] + in ((h1,st0+1),(SET_VALUE h0,PUSH_VALUE h0,is2)) i2i :: Ident -> CId i2i = utf8CId . ident2utf8 diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 6373133d7..c5a04230b 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -48,7 +48,7 @@ mkCanon2pgf opts gr am = do flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags] - funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef arity mdef, 0)) | + funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) | ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs, let arity = mkArrity ma ty] @@ -145,10 +145,10 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty then ( scope,(bt,i2i x,ty')) else (x:scope,(bt,i2i x,ty'))) scope hyps -mkDef arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] - ,generateByteCode arity eqs +mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] + ,generateByteCode gr arity eqs ) -mkDef arity Nothing = Nothing +mkDef gr arity Nothing = Nothing mkArrity (Just a) ty = a mkArrity Nothing ty = let (ctxt, _, _) = GM.typeForm ty diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 552856995..bbf3351cb 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -117,6 +117,8 @@ typedef enum { PGF_INSTR_PUT_FLT, PGF_INSTR_SET_VALUE, PGF_INSTR_SET_VARIABLE, + PGF_INSTR_PUSH_VALUE, + PGF_INSTR_PUSH_VARIABLE, PGF_INSTR_TAIL_CALL, PGF_INSTR_FAIL, PGF_INSTR_RET diff --git a/src/runtime/c/pgf/jit.c b/src/runtime/c/pgf/jit.c index 646115c4e..0efaa7fd2 100644 --- a/src/runtime/c/pgf/jit.c +++ b/src/runtime/c/pgf/jit.c @@ -527,11 +527,60 @@ 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 + + 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*)); + jit_str_p(JIT_RET, JIT_V0); + } + break; + } + case PGF_INSTR_PUSH_VARIABLE: { + size_t index = pgf_read_int(rdr); +#ifdef PGF_JIT_DEBUG + gu_printf(out, err, "PUSH_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_extend); + jit_ldxi_p(JIT_V0, JIT_RET, -(index+1)*sizeof(PgfClosure*)); + jit_str_p(JIT_RET, 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 + + 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); + + 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 PGF_INSTR_FAIL: diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index b2bfda069..b5c301e3b 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -149,9 +149,11 @@ instance Binary Instr where 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 + put (PUSH_VALUE n)= putWord8 13 >> put n + put (PUSH_VARIABLE n)= putWord8 14 >> put n + put (TAIL_CALL id) = putWord8 15 >> put id + put (FAIL ) = putWord8 16 + put (RET n) = putWord8 17 >> put n instance Binary Type where diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs index b8e7d889d..bcf21ed9b 100644 --- a/src/runtime/haskell/PGF/ByteCode.hs +++ b/src/runtime/haskell/PGF/ByteCode.hs @@ -19,6 +19,8 @@ data Instr | PUT_FLT {-# UNPACK #-} !Double | SET_VALUE {-# UNPACK #-} !Int | SET_VARIABLE {-# UNPACK #-} !Int + | PUSH_VALUE {-# UNPACK #-} !Int + | PUSH_VARIABLE {-# UNPACK #-} !Int | TAIL_CALL CId | FAIL | RET {-# UNPACK #-} !Int @@ -33,13 +35,15 @@ 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_VALUE n) = text "SET_VALUE " <+> int n ppInstr l (SET_VARIABLE n) = text "SET_VARIABLE" <+> int n +ppInstr l (PUSH_VALUE n) = text "PUSH_VALUE " <+> int n +ppInstr l (PUSH_VARIABLE n)= text "PUSH_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