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

A basic infrastructure for generating Teyjus bytecode from the GF abstract syntax

Browse Source
This commit is contained in:
kr.angelov
2012-08-29 11:43:02 +00:00
parent 27196778ac
commit f8fe23fda7
23 changed files with 211 additions and 102 deletions
Download Patch File Download Diff File Expand all files Collapse all files

75
src/compiler/GF/Compile/GenerateBC.hs Normal file
View File

@@ -0,0 +1,75 @@
module GF.Compile.GenerateBC(generateByteCode) where
import GF.Grammar
import GF.Compile.Instructions
import PGF.Data
import Data.Maybe
import qualified Data.IntMap as IntMap
import qualified Data.ByteString as BSS
import qualified Data.ByteString.Lazy as BS
import Data.Binary
generateByteCode :: [(QIdent,Info)] -> ([(QIdent,Info,BCAddr)], BSS.ByteString)
generateByteCode = runGenM . mapM genFun
type BCLabel = (Int, BCAddr)
genFun (id,info@(AbsFun (Just (L _ ty)) ma pty _)) = do
l1 <- newLabel
emitLabel l1
emit Ins_fail
l2 <- newLabel
l3 <- newLabel
emit (Ins_switch_on_reg (1,addr l2,addr l3))
emitLabel l2
emit (Ins_try (1,addr l3))
emit (Ins_trust_ext (1,1))
emit (Ins_try_me_else (0,addr l1))
emitLabel l3
l4 <- newLabel
l5 <- newLabel
emit (Ins_switch_on_term (addr l4,addr l5,addr l1,addr l4))
emitLabel l4
emitLabel l5
return (id,info,addr l1)
genFun (id,info@(AbsCat (Just (L _ cont)))) = do
l1 <- newLabel
return (id,info,addr l1)
newtype GenM a = GenM {unGenM :: IntMap.IntMap BCAddr ->
IntMap.IntMap BCAddr ->
[Instruction] ->
(a,IntMap.IntMap BCAddr,[Instruction])}
instance Monad GenM where
return x = GenM (\fm cm is -> (x,cm,is))
f >>= g = GenM (\fm cm is -> case unGenM f fm cm is of
(x,cm,is) -> unGenM (g x) fm cm is)
runGenM :: GenM a -> (a, BSS.ByteString)
runGenM f =
let (x, cm, is) = unGenM f cm IntMap.empty []
in (x, BSS.concat (BS.toChunks (encode (BC (reverse is)))))
emit :: Instruction -> GenM ()
emit i = GenM (\fm cm is -> ((), cm, i:is))
newLabel :: GenM BCLabel
newLabel = GenM (\fm cm is ->
let lbl = IntMap.size cm
addr = fromMaybe (error "newLabel") (IntMap.lookup lbl fm)
in ((lbl,addr), IntMap.insert lbl 0 cm, is))
emitLabel :: BCLabel -> GenM ()
emitLabel (lbl,addr) = GenM (\fm cm is ->
((), IntMap.insert lbl (length is) cm, is))
addr :: BCLabel -> BCAddr
addr (lbl,addr) = addr
data ByteCode = BC [Instruction]
instance Binary ByteCode where
put (BC is) = mapM_ putInstruction is
get = error "get ByteCode"

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

@@ -3,6 +3,7 @@ module GF.Compile.GrammarToPGF (mkCanon2pgf) where
import GF.Compile.Export
import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import PGF.CId
import PGF.Data(fidInt,fidFloat,fidString)
@@ -41,26 +42,27 @@ mkCanon2pgf opts gr am = do
cncs <- mapM (mkConcr gr) (allConcretes gr am)
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
where
mkAbstr gr am = return (i2i am, D.Abstr flags funs cats)
mkAbstr gr am = return (i2i am, D.Abstr flags funs cats bcode)
where
aflags =
concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo])
adefs =
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am
(adefs,bcode) =
generateByteCode $
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF aflags]
funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) |
((m,f),AbsFun (Just (L _ ty)) ma pty _) <- adefs]
funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0, addr)) |
((m,f),AbsFun (Just (L _ ty)) ma pty _,addr) <- adefs]
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
((m,c),AbsCat (Just (L _ cont))) <- adefs]
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, addr)) |
((m,c),AbsCat (Just (L _ cont)),addr) <- adefs]
catfuns cat =
(map (\x -> (0,snd x)) . sortBy (compare `on` fst))
[(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
[(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True),_) <- adefs, snd (GM.valCat ty) == cat]
mkConcr gr cm = do
let cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo,

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

@@ -264,7 +264,7 @@ hSkeleton gr =
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
jty (f,(ty,_,_,_,_)) = (f,catSkeleton ty)
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
updateSkeleton cat skel rule =

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

@@ -33,8 +33,8 @@ 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],Double)) -> JS.Property
absdef2js (f,(typ,_,_,_)) =
absdef2js :: (CId,(Type,Int,Maybe [Equation],Double,BCAddr)) -> 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)])

20
src/compiler/GF/Compile/PGFtoLProlog.hs
View File

@@ -12,25 +12,25 @@ import Debug.Trace
grammar2lambdaprolog_mod pgf = render $
text "module" <+> ppCId (absname pgf) <> char '.' $$
space $$
vcat [ppClauses cat fns | (cat,(_,fs)) <- Map.toList (cats (abstract pgf)),
vcat [ppClauses cat fns | (cat,(_,fs,_)) <- Map.toList (cats (abstract pgf)),
let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]]
where
ppClauses cat fns =
text "/*" <+> ppCId cat <+> text "*/" $$
vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_)) <- fns] $$
vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_,_)) <- fns] $$
space $$
vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_)) <- fns] $$
vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_,_)) <- fns] $$
space
grammar2lambdaprolog_sig pgf = render $
text "sig" <+> ppCId (absname pgf) <> char '.' $$
space $$
vcat [ppCat c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
vcat [ppCat c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$
space $$
vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_)) <- Map.toList (funs (abstract pgf))] $$
vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_,_)) <- Map.toList (funs (abstract pgf))] $$
space $$
vcat [ppExport c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_)) <- Map.toList (funs (abstract pgf))]
vcat [ppExport c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$
vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_,_)) <- Map.toList (funs (abstract pgf))]
ppCat :: CId -> [Hypo] -> Doc
ppCat c hyps = text "kind" <+> ppKind c <+> text "type"
@@ -157,8 +157,8 @@ expr2goal abstr scope goals i (EApp e1 e2) args =
in expr2goal abstr scope goals' i' e1 (e2':args)
expr2goal abstr scope goals i (EFun f) args =
case Map.lookup f (funs abstr) of
Just (_,_,Just _,_) -> let e = EFun (mkVar i)
in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
_ -> (goals,i,foldl EApp (EFun f) args)
Just (_,_,Just _,_,_) -> let e = EFun (mkVar i)
in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
_ -> (goals,i,foldl EApp (EFun f) args)
expr2goal abstr scope goals i (EVar j) args =
(goals,i,foldl EApp (EVar j) args)

6
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -49,16 +49,16 @@ plAbstract name abs
(f, v) <- Map.assocs (aflags abs)] ++++
plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
[[plType cat args, plHypos hypos'] |
(cat, (hypos, _)) <- Map.assocs (cats abs),
(cat, (hypos, _, _)) <- Map.assocs (cats abs),
let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
let args = reverse [EFun x | (_,x) <- subst]] ++++
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
[[plp fun, plType cat args, plHypos hypos] |
(fun, (typ, _, _, _)) <- Map.assocs (funs abs),
(fun, (typ, _, _, _, _)) <- Map.assocs (funs abs),
let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
plFacts name "def" 2 "(?Fun, ?Expr)"
[[plp fun, plp expr] |
(fun, (_, _, Just eqs, _)) <- Map.assocs (funs abs),
(fun, (_, _, Just eqs, _, _)) <- Map.assocs (funs abs),
let (_, expr) = alphaConvert emptyEnv eqs]
)
where plType cat args = plTerm (plp cat) (map plp args)

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

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