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

10 files changed, 109 insertions, 30 deletions

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 18194f340..11ae46713 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -1071,7 +1071,7 @@ allCommands env@(pgf, mos) = Map.fromList [
                                                                 if null (functionsToCat pgf id)
                                                                   then empty
                                                                   else space $$
-                                                                       vcat [ppFun fid (ty,0,Just [],0) | (fid,ty) <- functionsToCat pgf id])
+                                                                       vcat [ppFun fid (ty,0,Just [],0,0) | (fid,ty) <- functionsToCat pgf id])
                                                      return void
                                      Nothing   -> do putStrLn ("unknown category of function identifier "++show id)
                                                      return void
@@ -1246,7 +1246,7 @@ allCommands env@(pgf, mos) = Map.fromList [
      | otherwise             = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
                                   return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
 
-   funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))]
+   funsigs pgf = [(f,ty) | (f,(ty,_,_,_,_)) <- Map.assocs (funs (abstract pgf))]
    showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
 
    morphos opts s = 
diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs
new file mode 100644
index 000000000..d5b18c725
--- /dev/null
+++ b/src/compiler/GF/Compile/GenerateBC.hs
@@ -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"
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index c30afb0ee..ae627f9e2 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -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, 
diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs
index 90bb804c9..846b1df14 100644
--- a/src/compiler/GF/Compile/PGFtoHaskell.hs
+++ b/src/compiler/GF/Compile/PGFtoHaskell.hs
@@ -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 =
diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs
index 1e9b00169..b7b3d5545 100644
--- a/src/compiler/GF/Compile/PGFtoJS.hs
+++ b/src/compiler/GF/Compile/PGFtoJS.hs
@@ -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)])
 
diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs
index a9dc551f2..670e3a952 100644
--- a/src/compiler/GF/Compile/PGFtoLProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoLProlog.hs
@@ -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)
diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs
index 03a29871b..de50d86d1 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 d81a531e2..00910171b 100644
--- a/src/compiler/GF/Compile/PGFtoPython.hs
+++ b/src/compiler/GF/Compile/PGFtoPython.hs
@@ -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
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 79e1b9f73..7408d0783 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -89,6 +89,7 @@ data OutputFormat = FmtPGFPretty
                   | FmtHaskell 
                   | FmtProlog
                   | FmtLambdaProlog
+                  | FmtByteCode
                   | FmtBNF
                   | FmtEBNF
                   | FmtRegular
@@ -436,6 +437,7 @@ outputFormatsExpl =
      (("haskell",      FmtHaskell),"Haskell (abstract syntax)"),
      (("prolog",       FmtProlog),"Prolog (whole grammar)"),
      (("lambda_prolog",FmtLambdaProlog),"LambdaProlog (abstract syntax)"),
+     (("lp_byte_code", FmtByteCode),"Bytecode for Teyjus (abstract syntax, experimental)"),
      (("bnf",          FmtBNF),"BNF (context-free grammar)"),
      (("ebnf",         FmtEBNF),"Extended BNF"),
      (("regular",      FmtRegular),"* regular grammar"),
diff --git a/src/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs
index 57168c78c..23a07b62f 100644
--- a/src/compiler/GF/Speech/VoiceXML.hs
+++ b/src/compiler/GF/Speech/VoiceXML.hs
@@ -39,7 +39,7 @@ type Skeleton = [(CId, [(CId, [CId])])]
 
 pgfSkeleton :: PGF -> Skeleton
 pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType (abstract pgf) f))) | (_,f) <- fs]) 
-                   | (c,(_,fs)) <- Map.toList (cats (abstract pgf))]
+                   | (c,(_,fs,_)) <- Map.toList (cats (abstract pgf))]
 
 --
 -- * Questions to ask