summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Compile
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/Compile')
-rw-r--r--src/compiler/GF/Compile/CFGtoPGF.hs7
-rw-r--r--src/compiler/GF/Compile/GenerateBC.hs135
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs43
-rw-r--r--src/compiler/GF/Compile/PGFtoHaskell.hs2
-rw-r--r--src/compiler/GF/Compile/PGFtoJS.hs6
-rw-r--r--src/compiler/GF/Compile/PGFtoLProlog.hs20
-rw-r--r--src/compiler/GF/Compile/PGFtoProlog.hs6
-rw-r--r--src/compiler/GF/Compile/PGFtoPython.hs4
8 files changed, 102 insertions, 121 deletions
diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs
index 96fc13554..aebf918bb 100644
--- a/src/compiler/GF/Compile/CFGtoPGF.hs
+++ b/src/compiler/GF/Compile/CFGtoPGF.hs
@@ -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]
diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs
index 61605e3f8..393c6722e 100644
--- a/src/compiler/GF/Compile/GenerateBC.hs
+++ b/src/compiler/GF/Compile/GenerateBC.hs
@@ -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
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index feccea46a..f042d5f38 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -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
diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs
index 9a921f645..749ad24bc 100644
--- a/src/compiler/GF/Compile/PGFtoHaskell.hs
+++ b/src/compiler/GF/Compile/PGFtoHaskell.hs
@@ -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 =
diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs
index 534b00812..2195ce431 100644
--- a/src/compiler/GF/Compile/PGFtoJS.hs
+++ b/src/compiler/GF/Compile/PGFtoJS.hs
@@ -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)])
diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs
index 9f990d4f9..28ee6afaf 100644
--- a/src/compiler/GF/Compile/PGFtoLProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoLProlog.hs
@@ -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)
diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs
index 25d1e6e41..1279e3d8a 100644
--- a/src/compiler/GF/Compile/PGFtoProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoProlog.hs
@@ -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)
diff --git a/src/compiler/GF/Compile/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs
index a186509fe..1fee9c8c5 100644
--- a/src/compiler/GF/Compile/PGFtoPython.hs
+++ b/src/compiler/GF/Compile/PGFtoPython.hs
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-23 22:20:44 +0000