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

partial implementation for recursive def rules

Browse Source
This commit is contained in:
kr.angelov
2014-09-01 14:51:20 +00:00
parent 0ce95397a1
commit 442dadf100
6 changed files with 110 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

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

8
src/compiler/GF/Compile/GrammarToPGF.hs
View File

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

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

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

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

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

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

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

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

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