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

12 files changed, 76 insertions, 72 deletions

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