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

23 files changed, 212 insertions, 103 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 
diff --git a/src/compiler/GFC.hs b/src/compiler/GFC.hs
index 3fff0701c..72a986303 100644
--- a/src/compiler/GFC.hs
+++ b/src/compiler/GFC.hs
@@ -18,6 +18,9 @@ import GF.Data.ErrM
 
 import Data.Maybe
 import Data.Binary
+import qualified Data.Map as Map
+import qualified Data.ByteString as BSS
+import qualified Data.ByteString.Lazy as BSL
 import qualified Data.ByteString.Char8 as BS
 import System.FilePath
 import System.IO
@@ -48,6 +51,7 @@ compileSourceFiles opts fs =
          then return ()
          else do pgf <- link opts (identC (BS.pack cnc)) gr
                  writePGF opts pgf
+                 writeByteCode opts pgf
                  writeOutputs opts pgf
 
 compileCFFiles :: Options -> [FilePath] -> IOE ()
@@ -78,9 +82,31 @@ unionPGFFiles opts fs =
 writeOutputs :: Options -> PGF -> IOE ()
 writeOutputs opts pgf = do
   sequence_ [writeOutput opts name str 
-                 | fmt <- flag optOutputFormats opts, 
+                 | fmt <- flag optOutputFormats opts,
+                   fmt /= FmtByteCode,
                    (name,str) <- exportPGF opts fmt pgf]
 
+writeByteCode :: Options -> PGF -> IOE ()
+writeByteCode opts pgf
+  | elem FmtByteCode (flag optOutputFormats opts) =
+             let name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
+                 file = name <.> "bc"
+                 path = case flag optOutputDir opts of
+                          Nothing  -> file
+                          Just dir -> dir </> file
+             in putPointE Normal opts ("Writing " ++ path ++ "...") $ ioeIO $
+                   bracket
+                      (openFile path WriteMode)
+                      (hClose)
+                      (\h -> do hSetBinaryMode h True
+                                BSL.hPut h (encode addrs)
+                                BSS.hPut h (code (abstract pgf)))
+  | otherwise = return ()
+  where
+    addrs = 
+      [(id,addr) | (id,(_,_,_,_,addr)) <- Map.toList (funs (abstract pgf))] ++
+      [(id,addr) | (id,(_,_,addr))     <- Map.toList (cats (abstract pgf))]
+
 writePGF :: Options -> PGF -> IOE ()
 writePGF opts pgf = do
   let outfile = grammarName opts pgf <.> "pgf"
diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index ac91fa231..b03349963 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -278,8 +278,8 @@ functions pgf = Map.keys (funs (abstract pgf))
 
 functionType pgf fun =
   case Map.lookup fun (funs (abstract pgf)) of
-    Just (ty,_,_,_) -> Just ty
-    Nothing         -> Nothing
+    Just (ty,_,_,_,_) -> Just ty
+    Nothing           -> Nothing
 
 -- | Converts an expression to normal form
 compute :: PGF -> Expr -> Expr
@@ -289,20 +289,20 @@ browse :: PGF -> CId -> Maybe (String,[CId],[CId])
 browse pgf id = fmap (\def -> (def,producers,consumers)) definition
   where
     definition = case Map.lookup id (funs (abstract pgf)) of
-                   Just (ty,_,Just eqs,_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
-                                                            if null eqs
-                                                              then empty
-                                                              else text "def" <+> vcat [let scope = foldl pattScope [] patts
-                                                                                            ds    = map (ppPatt 9 scope) patts
-                                                                                        in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
-                   Just (ty,_,Nothing, _) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
+                   Just (ty,_,Just eqs,_,_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
+                                                              if null eqs
+                                                                then empty
+                                                                else text "def" <+> vcat [let scope = foldl pattScope [] patts
+                                                                                              ds    = map (ppPatt 9 scope) patts
+                                                                                          in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
+                   Just (ty,_,Nothing, _,_) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
                    Nothing   -> case Map.lookup id (cats (abstract pgf)) of
-                                  Just (hyps,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
-                                  Nothing       -> Nothing
+                                  Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
+                                  Nothing         -> Nothing
 
     (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
       where
-        accum f (ty,_,_,_) (plist,clist) = 
+        accum f (ty,_,_,_,_) (plist,clist) = 
           let !plist' = if id `elem` ps then f : plist else plist
               !clist' = if id `elem` cs then f : clist else clist
           in (plist',clist')
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 22a6ef464..e96bf0ea0 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -44,6 +44,7 @@ instance Binary Abstr where
            cats <- get

            return (Abstr{ aflags=aflags

                         , funs=funs, cats=cats

+                        , code=BS.empty                        

                         })

   

 instance Binary Concr where

diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index f382601a8..357dcc92e 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -9,6 +9,7 @@ import qualified Data.Set as Set
 import qualified Data.IntMap as IntMap
 import qualified Data.IntSet as IntSet
 import qualified GF.Data.TrieMap as TMap
+import qualified Data.ByteString as BS
 import Data.Array.IArray
 import Data.Array.Unboxed
 import Data.List
@@ -26,12 +27,13 @@ data PGF = PGF {
   }
 
 data Abstr = Abstr {
-  aflags  :: Map.Map CId Literal,                     -- ^ value of a flag
-  funs    :: Map.Map CId (Type,Int,Maybe [Equation],Double), -- ^ type, arrity and definition of function + probability
-  cats    :: Map.Map CId ([Hypo],[(Double, CId)])     -- ^ 1. context of a category
-                                                      -- ^ 2. functions of a category. The order in the list is important,
-                                                      -- this is the order in which the type singatures are given in the source.
-                                                      -- The termination of the exhaustive generation might depend on this.
+  aflags  :: Map.Map CId Literal,                            -- ^ value of a flag
+  funs    :: Map.Map CId (Type,Int,Maybe [Equation],Double,BCAddr), -- ^ type, arrity and definition of function + probability
+  cats    :: Map.Map CId ([Hypo],[(Double, CId)],BCAddr),    -- ^ 1. context of a category
+                                                             -- ^ 2. functions of a category. The order in the list is important,
+                                                             -- this is the order in which the type singatures are given in the source.
+                                                             -- The termination of the exhaustive generation might depend on this.
+  code    :: BS.ByteString
   }
 
 data Concr = Concr {
@@ -70,6 +72,7 @@ data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,
 type Sequence = Array DotPos Symbol
 type FunId = Int
 type SeqId = Int
+type BCAddr = Int
 
 data Alternative =
    Alt [Token] [String]
@@ -102,8 +105,8 @@ emptyPGF = PGF {
 haveSameFunsPGF :: PGF -> PGF -> Bool
 haveSameFunsPGF one two = 
   let 
-    fsone = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract one))]
-    fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))]
+    fsone = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract one))]
+    fstwo = [(f,t) | (f,(t,_,_,_,_)) <- Map.toList (funs (abstract two))]
   in fsone == fstwo
 
 -- | This is just a 'CId' with the language name.
diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index 5fbcdf120..998819687 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -318,22 +318,22 @@ data Value
   | VClosure Env Expr

   | VImplArg Value

 

-type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double)    -- type and def of a fun

-           , Int -> Maybe Expr                                 -- lookup for metavariables

+type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double,Int) -- type and def of a fun

+           , Int -> Maybe Expr                                  -- lookup for metavariables

            )

 type Env = [Value]

 

 eval :: Sig -> Env -> Expr -> Value

 eval sig env (EVar i)     = env !! i

 eval sig env (EFun f)     = case Map.lookup f (fst sig) of

-                              Just (_,a,meqs,_) -> case meqs of

-                                                     Just eqs -> if a == 0

-                                                                   then case eqs of

-                                                                          Equ [] e : _ -> eval sig [] e

-                                                                          _            -> VConst f []

-                                                                   else VApp f []

-                                                     Nothing  -> VApp f []

-                              Nothing           -> error ("unknown function "++showCId f)

+                              Just (_,a,meqs,_,_) -> case meqs of

+                                                       Just eqs -> if a == 0

+                                                                     then case eqs of

+                                                                            Equ [] e : _ -> eval sig [] e

+                                                                            _            -> VConst f []

+                                                                     else VApp f []

+                                                       Nothing  -> VApp f []

+                              Nothing             -> error ("unknown function "++showCId f)

 eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2]

 eval sig env (EAbs b x e) = VClosure env (EAbs b x e)

 eval sig env (EMeta i)    = case snd sig i of

@@ -347,11 +347,11 @@ apply :: Sig -> Env -> Expr -> [Value] -> Value
 apply sig env e            []     = eval sig env e

 apply sig env (EVar i)     vs     = applyValue sig (env !! i) vs

 apply sig env (EFun f)     vs     = case Map.lookup f (fst sig) of

-                                      Just (_,a,meqs,_) -> case meqs of

-                                                             Just eqs -> if a <= length vs

-                                                                           then match sig f eqs vs

-                                                                           else VApp f vs

-                                                             Nothing  -> VApp f vs

+                                      Just (_,a,meqs,_,_) -> case meqs of

+                                                               Just eqs -> if a <= length vs

+                                                                             then match sig f eqs vs

+                                                                             else VApp f vs

+                                                               Nothing  -> VApp f vs

                                       Nothing           -> error ("unknown function "++showCId f)

 apply sig env (EApp e1 e2) vs     = apply sig env e1 (eval sig env e2 : vs)

 apply sig env (EAbs b x e) (v:vs) = case (b,v) of

diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs
index 24bafb475..3c4272317 100644
--- a/src/runtime/haskell/PGF/Forest.hs
+++ b/src/runtime/haskell/PGF/Forest.hs
@@ -75,7 +75,7 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
                                                  cat = case isLindefCId fun of

                                                          Just cat -> cat

                                                          Nothing  -> case Map.lookup fun (funs abs) of

-                                                                       Just (DTyp _ cat _,_,_,_) -> cat

+                                                                       Just (DTyp _ cat _,_,_,_,_) -> cat

                                                  largs  = map (render forest) args

                                                  ltable = mkLinTable cnc isTrusted [] funid largs

                                              in ((cat,fid),wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)

diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index 9181fdab2..39c59cd3f 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -98,7 +98,7 @@ linTree pgf lang e =
             Nothing        -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
           where
             toApp fid (PApply funid pargs) =
-              let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))
+              let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))
                   (args,res) = catSkeleton ty
               in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])]
             toApp _   (PCoerce fid) = 
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 7879004cd..88057ce45 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -21,18 +21,18 @@ mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) }
 lookType :: Abstr -> CId -> Type
 lookType abs f = 
   case lookMap (error $ "lookType " ++ show f) f (funs abs) of
-    (ty,_,_,_) -> ty
+    (ty,_,_,_,_) -> ty
 
 lookDef :: Abstr -> CId -> Maybe [Equation]
 lookDef abs f = 
   case lookMap (error $ "lookDef " ++ show f) f (funs abs) of
-    (_,a,eqs,_) -> eqs
+    (_,a,eqs,_,_) -> eqs
 
 isData :: Abstr -> CId -> Bool
 isData abs f =
   case Map.lookup f (funs abs) of
-    Just (_,_,Nothing,_) -> True             -- the encoding of data constrs
-    _                    -> False
+    Just (_,_,Nothing,_,_) -> True       -- the encoding of data constrs
+    _                      -> False
 
 lookValCat :: Abstr -> CId -> CId
 lookValCat abs = valCat . lookType abs
@@ -65,9 +65,9 @@ lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
 
 functionsToCat :: PGF -> CId -> [(CId,Type)]
 functionsToCat pgf cat =
-  [(f,ty) | (_,f) <- fs, Just (ty,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
+  [(f,ty) | (_,f) <- fs, Just (ty,_,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
  where 
-   (_,fs) = lookMap ([],[]) cat $ cats $ abstract pgf
+   (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf
 
 missingLins :: PGF -> CId -> [CId]
 missingLins pgf lang = [c | c <- fs, not (hasl c)] where
@@ -81,7 +81,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF
 restrictPGF cond pgf = pgf {
   abstract = abstr {
     funs = Map.filterWithKey (\c _ -> cond c) (funs abstr),
-    cats = Map.map (\(hyps,fs) -> (hyps,filter (cond . snd) fs)) (cats abstr)
+    cats = Map.map (\(hyps,fs,addr) -> (hyps,filter (cond . snd) fs,addr)) (cats abstr)
     }
   }  ---- restrict concrs also, might be needed
  where
diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs
index 92e3d12ce..015779ace 100644
--- a/src/runtime/haskell/PGF/Paraphrase.hs
+++ b/src/runtime/haskell/PGF/Paraphrase.hs
@@ -53,7 +53,7 @@ fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where
               isClosed d || (length equs == 1 && isLinear d)]
 
   equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | 
-                   (f,(_,_,Just eqs,_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
+                   (f,(_,_,Just eqs,_,_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
   ---- AR 14/12/2010: (expr2tree d) fails unless we send the variable list from ps in eqs;
   ---- cf. PGF.Tree.expr2tree
   trequ s f e = True ----trace (s ++ ": " ++ show f ++ "  " ++ show e) True
diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index 980b5dcdf..c0529b116 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -28,17 +28,17 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$
 ppFlag :: CId -> Literal -> Doc
 ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';'
 
-ppCat :: CId -> ([Hypo],[(Double,CId)]) -> Doc
-ppCat c (hyps,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
-
-ppFun :: CId -> (Type,Int,Maybe [Equation],Double) -> Doc
-ppFun f (t,_,Just eqs,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
-                           if null eqs
-                             then empty
-                             else text "def" <+> vcat [let scope = foldl pattScope [] patts
-                                                           ds    = map (ppPatt 9 scope) patts
-                                                       in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]
-ppFun f (t,_,Nothing,_)  = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
+ppCat :: CId -> ([Hypo],[(Double,CId)],BCAddr) -> Doc
+ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
+
+ppFun :: CId -> (Type,Int,Maybe [Equation],Double,BCAddr) -> Doc
+ppFun f (t,_,Just eqs,_,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
+                             if null eqs
+                               then empty
+                               else text "def" <+> vcat [let scope = foldl pattScope [] patts
+                                                             ds    = map (ppPatt 9 scope) patts
+                                                         in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]
+ppFun f (t,_,Nothing,_,_)  = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
 
 ppCnc :: Language -> Concr -> Doc
 ppCnc name cnc =
diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs
index ee44e73e1..bf2464b1d 100644
--- a/src/runtime/haskell/PGF/Probabilistic.hs
+++ b/src/runtime/haskell/PGF/Probabilistic.hs
@@ -50,7 +50,7 @@ readProbabilitiesFromFile file pgf = do
 mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities
 mkProbabilities pgf probs =
   let funs1 = Map.fromList [(f,p) | (_,cf) <- Map.toList cats1, (p,f) <- cf]
-      cats1 = Map.map (\(_,fs) -> fill fs) (cats (abstract pgf))
+      cats1 = Map.map (\(_,fs,_) -> fill fs) (cats (abstract pgf))
   in Probs funs1 cats1
   where
     fill fs = pad [(Map.lookup f probs,f) | (_,f) <- fs]
@@ -68,15 +68,15 @@ defaultProbabilities pgf = mkProbabilities pgf Map.empty
 
 getProbabilities :: PGF -> Probabilities
 getProbabilities pgf = Probs {
-  funProbs = Map.map (\(_,_,_,p) -> p) (funs (abstract pgf)),
-  catProbs = Map.map (\(_,fns) -> fns) (cats (abstract pgf))
+  funProbs = Map.map (\(_,_,_,p,_) -> p) (funs (abstract pgf)),
+  catProbs = Map.map (\(_,fns,_) -> fns) (cats (abstract pgf))
   }
 
 setProbabilities :: Probabilities -> PGF -> PGF
 setProbabilities probs pgf = pgf {
   abstract = (abstract pgf) {
-    funs = mapUnionWith (\(ty,a,df,_) p -> (ty,a,df,p)) (funs (abstract pgf)) (funProbs probs),
-    cats = mapUnionWith (\(hypos,_) fns -> (hypos,fns)) (cats (abstract pgf)) (catProbs probs)
+    funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df,p,addr)) (funs (abstract pgf)) (funProbs probs),
+    cats = mapUnionWith (\(hypos,_,addr) fns -> (hypos,fns,addr)) (cats (abstract pgf)) (catProbs probs)
   }}
   where
     mapUnionWith f map1 map2 = 
@@ -87,8 +87,8 @@ probTree :: PGF -> Expr -> Double
 probTree pgf t = case t of
   EApp f e -> probTree pgf f * probTree pgf e
   EFun f   -> case Map.lookup f (funs (abstract pgf)) of
-                Just (_,_,_,p) -> p
-                Nothing        -> 1
+                Just (_,_,_,p,_) -> p
+                Nothing          -> 1
   _ -> 1
 
 -- | rank from highest to lowest probability
diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs
index b5b5f4857..42b5d36d0 100644
--- a/src/runtime/haskell/PGF/SortTop.hs
+++ b/src/runtime/haskell/PGF/SortTop.hs
@@ -39,7 +39,7 @@ showInOrder abs fset remset avset =
 isArg :: Abstr -> Map.Map CId CId -> Set.Set CId -> CId -> Maybe [CId]
 isArg abs mtypes scid cid = 
    let p = Map.lookup cid $ funs abs
-       (ty,_,_,_) = fromJust p 
+       (ty,_,_,_,_) = fromJust p 
        args  = arguments ty  
        setargs = Set.fromList args
        cond = Set.null $ Set.difference setargs scid
@@ -52,7 +52,7 @@ typesInterm :: Abstr -> Set.Set CId -> Map.Map CId CId
 typesInterm abs fset = 
           let fs = funs abs
               fsetTypes = Set.map (\x -> 
-                                    let (DTyp _ c _,_,_,_)=fromJust $ Map.lookup x fs
+                                    let (DTyp _ c _,_,_,_,_)=fromJust $ Map.lookup x fs
                                      in (x,c)) fset
               in Map.fromList $ Set.toList fsetTypes             
 
@@ -68,7 +68,7 @@ doesReturnCat (DTyp _ c _) cat = c == cat
 returnCat :: Abstr -> CId -> CId 
 returnCat abs cid = 
       let p = Map.lookup cid $ funs abs           
-          (DTyp _ c _,_,_,_) = fromJust p  
+          (DTyp _ c _,_,_,_,_) = fromJust p  
         in if isNothing p then error $ "not found "++ show cid ++ " in abstract "
                    else c
 
diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index 890e77bb4..268742b94 100644
--- a/src/runtime/haskell/PGF/TypeCheck.hs
+++ b/src/runtime/haskell/PGF/TypeCheck.hs
@@ -121,13 +121,13 @@ runTcM abstr f ms s = unTcM f abstr (\x ms s cp b -> let (es,xs) = cp b
 
 lookupCatHyps :: CId -> TcM s [Hypo]
 lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of
-                                            Just (hyps,_) -> k hyps ms
-                                            Nothing       -> h (UnknownCat cat))
+                                            Just (hyps,_,_) -> k hyps ms
+                                            Nothing         -> h (UnknownCat cat))
 
 lookupFunType :: CId -> TcM s Type
 lookupFunType fun = TcM (\abstr k h ms -> case Map.lookup fun (funs abstr) of
-                                            Just (ty,_,_,_) -> k ty ms
-                                            Nothing         -> h (UnknownFun fun))
+                                            Just (ty,_,_,_,_) -> k ty ms
+                                            Nothing           -> h (UnknownFun fun))
 
 typeGenerators :: Scope -> CId -> TcM s [(Double,Expr,TType)]
 typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
@@ -143,8 +143,8 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
       | cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))]
       | otherwise        = TcM (\abstr k h ms ->
                                     case Map.lookup cat (cats abstr) of
-                                      Just (_,fns) -> unTcM (mapM helper fns) abstr k h ms
-                                      Nothing      -> h (UnknownCat cat))
+                                      Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms
+                                      Nothing        -> h (UnknownCat cat))
 
     helper (p,fn) = do
       ty <- lookupFunType fn