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

full support for recursive def rules in the C runtime

Browse Source
This commit is contained in:
kr.angelov
2014-09-05 10:09:43 +00:00
parent a21ffc1941
commit 86b5f78c57
11 changed files with 513 additions and 366 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -6,21 +6,19 @@ import GF.Data.Operations
import PGF(CId,utf8CId)
import PGF.Internal(Instr(..))
import qualified Data.Map as Map
import Data.List(mapAccumL)
import Data.List(nub)
generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [Instr]
generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
generateByteCode gr arity eqs =
compileEquations gr arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs)
let (bs,instrs) = compileEquations gr arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) [ENTER:instrs]
in reverse bs
where
is = push_is (arity-1) arity []
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 gr st (i:is) eqs = whilePP eqs Map.empty
compileEquations :: SourceGrammar -> Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [[Instr]] -> ([[Instr]],[Instr])
compileEquations gr st _ [] bs = (bs,[FAIL])
compileEquations gr st [] ((vs,[],t):_) bs = compileBody gr st vs [] t bs []
compileEquations gr st (i:is) eqs bs = 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)
@@ -32,54 +30,118 @@ compileEquations gr 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 gr st (i:is) eqs
whilePV eqs cns vrs = let (bs1,instrs1) = mkCase cns (reverse vrs)
(bs2,instrs2) = compileEquations gr st (i:is) eqs (instrs2:bs1)
in (bs2,instrs1)
mkCase cns 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 gr st is vrs
mkCase cns vrs =
case Map.toList cns of
[] -> compileEquations gr st is vrs bs
(cn:cns) -> let (bs1,instrs1) = compileBranch0 cn bs
bs2 = foldr compileBranch bs1 cns
(bs3,instrs3) = compileEquations gr st is vrs (instrs3:bs2)
in (bs3,instrs1)
compileBranch t n eqs =
compileBranch0 ((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
instrs = compileEquations gr (st+n) (push_is st n is) eqs
in case_instr (length instrs) : instrs
(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)
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])
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
(bs1,instrs) = compileEquations gr (st+n) (push_is st n is) eqs ((case_instr (length bs1) : instrs) : bs)
in bs1
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))
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 ++ [RET st]))
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 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)
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])
compileFun gr st avs fvs (EInt n) h0 bs _ =
let h1 = h0 + 2
in (h1,bs,[PUT_INT n])
compileFun gr st avs fvs (K s) h0 bs _ =
let h1 = h0 + 1 + (length s + 4) `div` 4
in (h1,bs,[PUT_STR s])
compileFun gr st avs fvs (EFloat d) h0 bs _ =
let h1 = h0 + 3
in (h1,bs,[PUT_FLT d])
compileArgs gr st st0 avs fvs h0 bs [] =
(h0,bs,[],[],[])
compileArgs gr st st0 avs fvs h0 bs (e:es) =
(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
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)])
else let es_fvs = nub (foldr freeVars [] es)
h1 = h0 + 1 + length es_fvs
(bs1,b) = compileBody gr 0 [] (zip es_fvs [0..]) e bs es
in (h1,(ENTER:b):bs1,SET_VALUE h0,PUSH_VALUE h0,PUT_CLOSURE (length bs) : map (fst . compileVar st st0 avs fvs) es_fvs)
_ -> 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)
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])
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])
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])
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))
Nothing -> case lookup x fvs of
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
i2i :: Ident -> CId
i2i = utf8CId . ident2utf8

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

@@ -146,8 +146,8 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
else (x:scope,(bt,i2i x,ty'))) scope hyps
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
)
,generateByteCode gr arity eqs
)
mkDef gr arity Nothing = Nothing
mkArrity (Just a) ty = a

2
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -32,7 +32,7 @@ pgf2js pgf =
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
absdef2js :: (CId,(Type,Int,Maybe ([Equation],[M.Instr]),Double)) -> JS.Property
absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
absdef2js (f,(typ,_,_,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])

2
src/compiler/GF/Compile/PGFtoPython.hs
View File

@@ -39,7 +39,7 @@ pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
abs = abstract pgf
cncs = concretes pgf
pyAbsdef :: (Type, Int, Maybe ([Equation], [M.Instr]), Double) -> String
pyAbsdef :: (Type, Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
where (args, cat) = M.catSkeleton typ