mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 03:32:51 -06:00
a partial support for def rules in the C runtime
The def rules are now compiled to byte code by the compiler and then to native code by the JIT compiler in the runtime. Not all constructions are implemented yet. The partial implementation is now in the repository but it is not activated by default since this requires changes in the PGF format. I will enable it only after it is complete.
This commit is contained in:
kr.angelov
@@ -9,7 +9,6 @@ import PGF.Internal
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Array.IArray
|
||||
import Data.List
|
||||
|
||||
@@ -27,13 +26,13 @@ cf2pgf fpath cf =
|
||||
cname = mkCId name
|
||||
|
||||
cf2abstr :: CFG -> Abstr
|
||||
cf2abstr cfg = Abstr aflags afuns acats BS.empty
|
||||
cf2abstr cfg = Abstr aflags afuns acats
|
||||
where
|
||||
aflags = Map.singleton (mkCId "startcat") (LStr (cfgStartCat cfg))
|
||||
acats = Map.fromList [(mkCId cat, ([], [(0,mkRuleName rule)
|
||||
| rule <- Set.toList rules], 0, 0))
|
||||
| rule <- Set.toList rules], 0))
|
||||
| (cat,rules) <- Map.toList (cfgRules cfg)]
|
||||
afuns = Map.fromList [(mkRuleName rule, (cftype [mkCId c | NonTerminal c <- ruleRhs rule] (mkCId cat), 0, Nothing, 0, 0))
|
||||
afuns = Map.fromList [(mkRuleName rule, (cftype [mkCId c | NonTerminal c <- ruleRhs rule] (mkCId cat), 0, Nothing, 0))
|
||||
| (cat,rules) <- Map.toList (cfgRules cfg)
|
||||
, rule <- Set.toList rules]
|
||||
|
||||
|
||||
@@ -1,78 +1,79 @@
|
||||
module GF.Compile.GenerateBC(generateByteCode) where
|
||||
|
||||
import GF.Grammar
|
||||
import GF.Compile.Instructions
|
||||
import PGF.Internal(Binary(..),encode,BCAddr)
|
||||
import PGF(CId,utf8CId)
|
||||
import PGF.Internal(Instr(..))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.ByteString as BSS
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import PGF.Internal()
|
||||
generateByteCode :: Int -> [L Equation] -> [Instr]
|
||||
generateByteCode arity eqs =
|
||||
compileEquations arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs)
|
||||
where
|
||||
is = push_is (arity-1) arity []
|
||||
|
||||
generateByteCode :: [(QIdent,Info)] -> ([(QIdent,Info,BCAddr)], BSS.ByteString)
|
||||
generateByteCode = runGenM . mapM genFun
|
||||
compileEquations :: Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [Instr]
|
||||
compileEquations st _ [] = [FAIL]
|
||||
compileEquations st [] ((vs,[],t):_) =
|
||||
let (heap,instrs) = compileBody 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
|
||||
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)
|
||||
whilePP ((vs, PInt n : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (EInt n,0) [(vs,ps,t)] cns)
|
||||
whilePP ((vs, PString s: ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (K s,0) [(vs,ps,t)] cns)
|
||||
whilePP ((vs, PFloat d : ps, t):eqs) cns = whilePP eqs (Map.insertWith (++) (EFloat d,0) [(vs,ps,t)] cns)
|
||||
whilePP eqs cns = whilePV eqs cns []
|
||||
|
||||
type BCLabel = (Int, BCAddr)
|
||||
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
|
||||
|
||||
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)
|
||||
genFun (id,info) = do
|
||||
l1 <- newLabel
|
||||
return (id,info,addr l1)
|
||||
mkCase cns vrs
|
||||
| Map.null cns = compileEquations st is vrs
|
||||
| otherwise = EVAL (st-i-1) :
|
||||
concat [compileBranch t n eqs | ((t,n),eqs) <- Map.toList cns] ++
|
||||
compileEquations st is vrs
|
||||
|
||||
newtype GenM a = GenM {unGenM :: IntMap.IntMap BCAddr ->
|
||||
IntMap.IntMap BCAddr ->
|
||||
[Instruction] ->
|
||||
(a,IntMap.IntMap BCAddr,[Instruction])}
|
||||
compileBranch t n eqs =
|
||||
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 (st+n) (push_is st n is) eqs
|
||||
in case_instr (length instrs) : instrs
|
||||
|
||||
|
||||
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)
|
||||
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)
|
||||
|
||||
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)))))
|
||||
i2i :: Ident -> CId
|
||||
i2i = utf8CId . ident2utf8
|
||||
|
||||
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"
|
||||
push_is :: Int -> Int -> [Int] -> [Int]
|
||||
push_is i 0 is = is
|
||||
push_is i n is = i : push_is (i-1) (n-1) is
|
||||
|
||||
@@ -25,13 +25,10 @@ import GF.Infra.UseIO (IOE)
|
||||
import GF.Data.Operations
|
||||
|
||||
import Data.List
|
||||
--import Data.Char (isDigit,isSpace)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Data.Array.IArray
|
||||
--import GF.Text.Pretty
|
||||
--import Control.Monad.Identity
|
||||
|
||||
mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF
|
||||
mkCanon2pgf opts gr am = do
|
||||
@@ -41,25 +38,25 @@ mkCanon2pgf opts gr am = do
|
||||
where
|
||||
cenv = resourceValues gr
|
||||
|
||||
mkAbstr am = return (i2i am, D.Abstr flags funs cats bcode)
|
||||
mkAbstr am = return (i2i am, D.Abstr flags funs cats)
|
||||
where
|
||||
aflags = err (const noOptions) mflags (lookupModule gr am)
|
||||
|
||||
(adefs,bcode) =
|
||||
generateByteCode $
|
||||
adefs =
|
||||
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
|
||||
Look.allOrigInfos gr am
|
||||
|
||||
flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
|
||||
|
||||
funs = Map.fromList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0, addr)) |
|
||||
((m,f),AbsFun (Just (L _ ty)) ma pty _,addr) <- adefs]
|
||||
funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef arity mdef, 0)) |
|
||||
((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
|
||||
let arity = mkArrity ma]
|
||||
|
||||
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0, addr)) |
|
||||
((m,c),AbsCat (Just (L _ cont)),addr) <- adefs]
|
||||
cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) |
|
||||
((m,c),AbsCat (Just (L _ cont))) <- adefs]
|
||||
|
||||
catfuns cat =
|
||||
[(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True),_) <- adefs, snd (GM.valCat ty) == cat]
|
||||
[(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
|
||||
|
||||
mkConcr cm = do
|
||||
let cflags = err (const noOptions) mflags (lookupModule gr cm)
|
||||
@@ -148,30 +145,14 @@ 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 (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
|
||||
mkDef Nothing = Nothing
|
||||
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 arity Nothing = Nothing
|
||||
|
||||
mkArrity (Just a) = a
|
||||
mkArrity Nothing = 0
|
||||
|
||||
data PattTree
|
||||
= Ret C.Expr
|
||||
| Case (Map.Map QIdent [PattTree]) [PattTree]
|
||||
|
||||
compilePatt :: [Equation] -> [PattTree]
|
||||
compilePatt (([],t):_) = [Ret (mkExp [] t)]
|
||||
compilePatt eqs = whilePP eqs Map.empty
|
||||
where
|
||||
whilePP [] cns = [mkCase cns []]
|
||||
whilePP (((PP c ps' : ps), t):eqs) cns = whilePP eqs (Map.insertWith (++) c [(ps'++ps,t)] cns)
|
||||
whilePP eqs cns = whilePV eqs cns []
|
||||
|
||||
whilePV [] cns vrs = [mkCase cns (reverse vrs)]
|
||||
whilePV (((PV x : ps), t):eqs) cns vrs = whilePV eqs cns ((ps,t) : vrs)
|
||||
whilePV eqs cns vrs = mkCase cns (reverse vrs) : compilePatt eqs
|
||||
|
||||
mkCase cns vrs = Case (fmap compilePatt cns) (compilePatt vrs)
|
||||
|
||||
|
||||
genCncCats gr am cm cdefs =
|
||||
let (index,cats) = mkCncCats 0 cdefs
|
||||
|
||||
@@ -272,7 +272,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 =
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
module GF.Compile.PGFtoJS (pgf2js) where
|
||||
|
||||
import PGF(CId,showCId)
|
||||
import PGF(showCId)
|
||||
import PGF.Internal as M
|
||||
import qualified GF.JavaScript.AbsJS as JS
|
||||
import qualified GF.JavaScript.PrintJS as JS
|
||||
@@ -32,8 +32,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,BCAddr)) -> JS.Property
|
||||
absdef2js (f,(typ,_,_,_,_)) =
|
||||
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)])
|
||||
|
||||
|
||||
@@ -12,25 +12,25 @@ import qualified Data.Map as Map
|
||||
grammar2lambdaprolog_mod pgf = render $
|
||||
"module" <+> ppCId (absname pgf) <> '.' $$
|
||||
' ' $$
|
||||
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 =
|
||||
"/*" <+> ppCId cat <+> "*/" $$
|
||||
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] $$
|
||||
' ' $$
|
||||
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] $$
|
||||
' '
|
||||
|
||||
grammar2lambdaprolog_sig pgf = render $
|
||||
"sig" <+> ppCId (absname pgf) <> '.' $$
|
||||
' ' $$
|
||||
vcat [ppCat c hyps <> dot | (c,(hyps,_,_,_)) <- Map.toList (cats (abstract pgf))] $$
|
||||
vcat [ppCat c hyps <> dot | (c,(hyps,_,_)) <- Map.toList (cats (abstract pgf))] $$
|
||||
' ' $$
|
||||
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))] $$
|
||||
' ' $$
|
||||
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 = "kind" <+> ppKind c <+> "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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -39,8 +39,8 @@ pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
|
||||
abs = abstract pgf
|
||||
cncs = concretes pgf
|
||||
|
||||
pyAbsdef :: (Type, Int, Maybe [Equation], Double, BCAddr) -> String
|
||||
pyAbsdef (typ, _, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
|
||||
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
|
||||
|
||||
pyLiteral :: Literal -> String
|
||||
|
||||
Reference in New Issue
Block a user