a partial support for def rules in the C runtime

The def rules are now compiled to byte code by the compiler and then to
native code by the JIT compiler in the runtime. Not all constructions
are implemented yet. The partial implementation is now in the repository
but it is not activated by default since this requires changes in the
PGF format. I will enable it only after it is complete.

gf.cabal

@@ -121,6 +121,7 @@ Library
     PGF.Forest
     PGF.TrieMap
     PGF.VisualizeTree
+    PGF.ByteCode
     PGF.OldBinary
 
   if flag(c-runtime)

src/compiler/GF/Command/Commands.hs

@@ -1137,7 +1137,7 @@ allCommands = Map.fromList [
        case arg of
          [EFun id] -> case Map.lookup id (funs (abstract pgf)) of
                         Just fd -> do putStrLn $ render (ppFun id fd)
-                                      let (_,_,_,prob,_) = fd
+                                      let (_,_,_,prob) = fd
                                       putStrLn ("Probability: "++show prob)
                                       return void
                         Nothing -> case Map.lookup id (cats (abstract pgf)) of
@@ -1146,9 +1146,9 @@ allCommands = Map.fromList [
                                                                 if null (functionsToCat pgf id)
                                                                   then empty
                                                                   else ' ' $$
-                                                                       vcat [ppFun fid (ty,0,Just [],0,0) | (fid,ty) <- functionsToCat pgf id] $$
+                                                                       vcat [ppFun fid (ty,0,Just ([],[]),0) | (fid,ty) <- functionsToCat pgf id] $$
                                                                        ' ')
-                                                     let (_,_,prob,_) = cd
+                                                     let (_,_,prob) = cd
                                                      putStrLn ("Probability: "++show prob)
                                                      return void
                                      Nothing   -> do putStrLn ("unknown category of function identifier "++show id)
@@ -1322,7 +1322,7 @@ allCommands = 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 (pgf,mos) opts s =

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]
 

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

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

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 =

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)])
 

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)

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)

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

src/compiler/GF/Speech/VoiceXML.hs

@@ -38,7 +38,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 

src/compiler/GF/Text/Coding.hs

@@ -23,7 +23,7 @@ encodeUnicode enc s =
   where
     translate cod cbuf
       | i < w     = do bbuf <- newByteBuffer 128 WriteBuffer
-                       (_,cbuf,bbuf) <- cod cbuf bbuf
+                       (cbuf,bbuf) <- cod cbuf bbuf
                        if isEmptyBuffer bbuf
                          then ioe_invalidCharacter1
                          else do let bs = PS (bufRaw bbuf) (bufL bbuf) (bufR bbuf-bufL bbuf)
@@ -48,7 +48,7 @@ decodeUnicodeIO enc (PS fptr l len) = do
   where
     translate cod bbuf cbuf
       | i < w     = do
-                       (_,bbuf,cbuf) <- cod bbuf cbuf
+                       (bbuf,cbuf) <- cod bbuf cbuf
                        if isEmptyBuffer cbuf
                          then ioe_invalidCharacter2
                          else unpack cod bbuf cbuf

src/compiler/GFC.hs

@@ -2,8 +2,8 @@ module GFC (mainGFC, writePGF) where
 -- module Main where
 
 import PGF
-import PGF.Internal(PGF,abstract,concretes,code,funs,cats,optimizePGF,unionPGF)
-import PGF.Internal(putSplitAbs)
+import PGF.Internal(PGF,concretes,optimizePGF,unionPGF)
+import PGF.Internal(putSplitAbs,encodeFile,runPut)
 import GF.Compile
 import GF.Compile.Export
 import GF.Compile.CFGtoPGF
@@ -17,13 +17,10 @@ import GF.Data.ErrM
 import GF.System.Directory
 
 import Data.Maybe
-import PGF.Internal(encode,encodeFile,runPut)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import qualified Data.ByteString as BSS
 import qualified Data.ByteString.Lazy as BSL
 import System.FilePath
-import System.IO
 import Control.Monad(unless,forM_)
 
 mainGFC :: Options -> [FilePath] -> IO ()
@@ -55,7 +52,6 @@ compileSourceFiles opts fs =
                    then putIfVerb opts $ pgfFile ++ " is up-to-date."
                    else do pgf <- link opts cnc_gr
                            writePGF opts pgf
-                           writeByteCode opts pgf
                            writeOutputs opts pgf
 
 compileCFFiles :: Options -> [FilePath] -> IOE ()
@@ -105,20 +101,6 @@ writeOutputs opts pgf = do
                  | fmt <- outputFormats opts,
                    (name,str) <- exportPGF opts fmt pgf]
 
-writeByteCode :: Options -> PGF -> IOE ()
-writeByteCode opts pgf
-  | elem FmtByteCode (flag optOutputFormats opts) =
-             let path = outputPath opts (grammarName opts pgf <.> "bc")
-             in writing opts path $
-                  withBinaryFile path WriteMode
-                      (\h -> do 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 =
     if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF

src/runtime/c/Makefile.am

@@ -33,7 +33,6 @@ guinclude_HEADERS = \
 pgfincludedir=$(includedir)/pgf
 pgfinclude_HEADERS = \
 	pgf/expr.h \
-	pgf/reader.h \
 	pgf/linearizer.h \
 	pgf/parser.h \
 	pgf/literals.h \

src/runtime/c/pgf/data.h

@@ -76,6 +76,7 @@ typedef struct {
 	PgfEquations* defns; // maybe null
 	PgfExprProb ep;
 	void* predicate;
+	void* function;
 } PgfAbsFun;
 
 extern GU_DECLARE_TYPE(PgfAbsFun, abstract);
@@ -102,6 +103,25 @@ typedef struct {
 	PgfAbsFun* abs_lin_fun;
 } PgfAbstr;
 
+typedef enum {
+  PGF_INSTR_EVAL,
+  PGF_INSTR_CASE,
+  PGF_INSTR_CASE_INT,
+  PGF_INSTR_CASE_STR,
+  PGF_INSTR_CASE_FLT,
+  PGF_INSTR_ALLOC,
+  PGF_INSTR_PUT_CONSTR,
+  PGF_INSTR_PUT_CLOSURE,
+  PGF_INSTR_PUT_INT,
+  PGF_INSTR_PUT_STR,
+  PGF_INSTR_PUT_FLT,
+  PGF_INSTR_SET_VALUE,
+  PGF_INSTR_SET_VARIABLE,
+  PGF_INSTR_TAIL_CALL,
+  PGF_INSTR_FAIL,
+  PGF_INSTR_RET
+} PgfInstruction;
+
 struct PgfPGF {
 	uint16_t major_version;
 	uint16_t minor_version;

src/runtime/c/pgf/evaluator.c

@@ -1,17 +1,18 @@
 #include "pgf/pgf.h"
 #include "pgf/data.h"
+#include "pgf/evaluator.h"
 
 typedef struct PgfEnv PgfEnv;
-typedef struct PgfClosure PgfClosure;
-typedef struct PgfEvalState PgfEvalState;
 
 struct PgfEnv {
 	PgfEnv* next;
 	PgfClosure* closure;
 };
 
+typedef PgfClosure* (*PgfFunction)(PgfEvalState* state, PgfClosure* val);
+
 struct PgfClosure {
-	PgfClosure* (*code)(PgfEvalState* state, PgfClosure* val);
+	PgfFunction code;
 };
 
 typedef struct {
@@ -28,7 +29,6 @@ typedef struct {
 typedef struct {
 	PgfClosure header;
 	PgfAbsFun* absfun;
-	size_t n_args;
 	PgfClosure* args[];
 } PgfValue;
 
@@ -52,13 +52,6 @@ typedef struct {
 	PgfLiteral lit;
 } PgfValueLit;
 
-struct PgfEvalState {
-	PgfPGF* pgf;
-	GuPool* pool;
-	GuExn* err;
-	GuBuf* stack;
-};
-
 static PgfClosure*
 pgf_evaluate_indirection(PgfEvalState* state, PgfClosure* closure)
 {
@@ -66,20 +59,20 @@ pgf_evaluate_indirection(PgfEvalState* state, PgfClosure* closure)
 	return indir->val;
 }
 
-static PgfClosure*
+PgfClosure*
 pgf_evaluate_value(PgfEvalState* state, PgfClosure* closure)
 {
 	PgfValue* val = (PgfValue*) closure;
 
-	size_t n_args = val->n_args + gu_buf_length(state->stack);
+	size_t n_args = gu_seq_length(val->absfun->type->hypos) +
+	                gu_buf_length(state->stack);
 	PgfValue* new_val =
 		gu_new_flex(state->pool, PgfValue, args, n_args);
 	new_val->header.code = pgf_evaluate_value;
 	new_val->absfun = val->absfun;
-	new_val->n_args = n_args;
 	
 	size_t i = 0;
-	while (i < val->n_args) {
+	while (i < gu_seq_length(val->absfun->type->hypos)) {
 		new_val->args[i] = val->args[i];
 		i++;
 	}
@@ -236,15 +229,18 @@ pgf_evaluate_expr_thunk(PgfEvalState* state, PgfClosure* closure)
 				return NULL;
 			}
 
-			size_t n_args = gu_buf_length(state->stack);
+			PgfValue* val;
+			if (absfun->function != NULL) {
+				val = (PgfValue*) ((PgfFunction) absfun->function)(state, closure);
+			} else {
+				size_t n_args = gu_buf_length(state->stack);
 
-			PgfValue* val =
-				gu_new_flex(state->pool, PgfValue, args, n_args);
-			val->header.code = pgf_evaluate_value;
-			val->absfun = absfun;
-			val->n_args = n_args;
-			for (size_t i = 0; i < n_args; i++) {
-				val->args[i] = gu_buf_pop(state->stack, PgfClosure*);
+				val = gu_new_flex(state->pool, PgfValue, args, n_args);
+				val->header.code = pgf_evaluate_value;
+				val->absfun = absfun;
+				for (size_t i = 0; i < n_args; i++) {
+					val->args[i] = gu_buf_pop(state->stack, PgfClosure*);
+				}
 			}
 
 			PgfIndirection* indir = (PgfIndirection*) closure;
@@ -309,7 +305,7 @@ pgf_value2expr(PgfEvalState* state, int level, PgfClosure* clos, GuPool* pool)
 		PgfValue* val = (PgfValue*) clos;
 
 		expr   = val->absfun->ep.expr;
-		n_args = val->n_args;
+		n_args = gu_seq_length(val->absfun->type->hypos);
 		args   = val->args;
 	} else if (clos->code == pgf_evaluate_value_gen) {
 		PgfValueGen* val = (PgfValueGen*) clos;

src/runtime/c/pgf/jit.c

@@ -1,23 +1,22 @@
 #include <gu/seq.h>
 #include <gu/file.h>
 #include <pgf/data.h>
-#include <pgf/jit.h>
 #include <pgf/reasoner.h>
+#include <pgf/evaluator.h>
+#include <pgf/reader.h>
 #include "lightning.h"
 
 //#define PGF_JIT_DEBUG
 
 
 struct PgfJitState {
-	GuPool* tmp_pool;
-	GuPool* pool;
 	jit_state jit;
 	jit_insn *buf;
 	char *save_ip_ptr;
 	GuBuf* patches;
 };
 
-#define _jit (state->jit)
+#define _jit (rdr->jit_state->jit)
 
 typedef struct {
 	PgfCId cid;
@@ -27,7 +26,7 @@ typedef struct {
 // Between two calls to pgf_jit_make_space we are not allowed
 // to emit more that JIT_CODE_WINDOW bytes. This is not quite
 // safe but this is how GNU lightning is designed.
-#define JIT_CODE_WINDOW 128
+#define JIT_CODE_WINDOW 1280
 
 typedef struct {
 	GuFinalizer fin;
@@ -42,7 +41,7 @@ pgf_jit_finalize_page(GuFinalizer* self)
 }
 
 static void
-pgf_jit_alloc_page(PgfJitState* state)
+pgf_jit_alloc_page(PgfReader* rdr)
 {
 	void *page;
 
@@ -58,46 +57,63 @@ pgf_jit_alloc_page(PgfJitState* state)
 		gu_fatal("Memory allocation failed");
 	}
 
-	PgfPageFinalizer* fin = gu_new(PgfPageFinalizer, state->pool);
+	PgfPageFinalizer* fin = 
+		gu_new(PgfPageFinalizer, rdr->opool);
 	fin->fin.fn = pgf_jit_finalize_page;
 	fin->page = page;
-	gu_pool_finally(state->pool, &fin->fin);
+	gu_pool_finally(rdr->opool, &fin->fin);
 	
-	state->buf = page;
-	jit_set_ip(state->buf);
+	rdr->jit_state->buf = page;
+	jit_set_ip(rdr->jit_state->buf);
 }
 
 PgfJitState*
-pgf_jit_init(GuPool* tmp_pool, GuPool* pool)
+pgf_new_jit(PgfReader* rdr)
 {
-	PgfJitState* state = gu_new(PgfJitState, tmp_pool);
-	state->tmp_pool = tmp_pool;
-	state->pool = pool;
-	state->patches = gu_new_buf(PgfCallPatch, tmp_pool);
-	
-	pgf_jit_alloc_page(state);
-	state->save_ip_ptr = jit_get_ip().ptr;
-
+	PgfJitState* state = gu_new(PgfJitState, rdr->tmp_pool);
+	state->patches = gu_new_buf(PgfCallPatch, rdr->tmp_pool);
+	state->buf = NULL;
+	state->save_ip_ptr = NULL;
 	return state;
 }
 
 static void
-pgf_jit_make_space(PgfJitState* state)
+pgf_jit_make_space(PgfReader* rdr)
 {
-	assert (state->save_ip_ptr + JIT_CODE_WINDOW > jit_get_ip().ptr);
-
 	size_t page_size = getpagesize();
-	if (jit_get_ip().ptr + JIT_CODE_WINDOW > ((char*) state->buf) + page_size) {
-		jit_flush_code(state->buf, jit_get_ip().ptr);
-		pgf_jit_alloc_page(state);
+	if (rdr->jit_state->buf == NULL) {
+		pgf_jit_alloc_page(rdr);
+	} else {
+		assert (rdr->jit_state->save_ip_ptr + JIT_CODE_WINDOW > jit_get_ip().ptr);
+
+		if (jit_get_ip().ptr + JIT_CODE_WINDOW > ((char*) rdr->jit_state->buf) + page_size) {
+			jit_flush_code(rdr->jit_state->buf, jit_get_ip().ptr);
+			pgf_jit_alloc_page(rdr);
+		}
 	}
+
+	rdr->jit_state->save_ip_ptr = jit_get_ip().ptr;
+}
+
+static PgfAbsFun*
+pgf_jit_read_absfun(PgfReader* rdr, PgfAbstr* abstr)
+{
+	gu_in_f64be(rdr->in, rdr->err);  // ignore
+	gu_return_on_exn(rdr->err, NULL);
+
+	PgfCId name = pgf_read_cid(rdr, rdr->tmp_pool);
+	gu_return_on_exn(rdr->err, NULL);
 	
-	state->save_ip_ptr = jit_get_ip().ptr;
+	PgfAbsFun* absfun =
+		gu_map_get(abstr->funs, name, PgfAbsFun*);
+	assert(absfun != NULL);
+	
+	return absfun;
 }
 
 void
-pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, 
-                  PgfAbsCat* abscat, GuBuf* functions)
+pgf_jit_predicate(PgfReader* rdr, PgfAbstr* abstr,
+                  PgfAbsCat* abscat)
 {
 #ifdef PGF_JIT_DEBUG
 	GuPool* tmp_pool = gu_new_pool();
@@ -110,21 +126,24 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 	int label = 0;
 #endif
 
-	size_t n_funs = gu_buf_length(functions);
-	
-	pgf_jit_make_space(state);
+	size_t n_funs = pgf_read_len(rdr);
+	gu_return_on_exn(rdr->err, );
+
+	pgf_jit_make_space(rdr);
 
 	abscat->predicate = (PgfPredicate) jit_get_ip().ptr;
 	
 	jit_prolog(2);
 
+	PgfAbsFun* absfun = NULL;
+	PgfAbsFun* next_absfun = NULL;
+
 	if (n_funs > 0) {
-		PgfAbsFun* absfun = 
-			gu_buf_get(functions, PgfAbsFun*, 0);
+		next_absfun = pgf_jit_read_absfun(rdr, abstr);
 
 #ifdef PGF_JIT_DEBUG
 		gu_puts("    TRY_FIRST ", out, err);
-		gu_string_write(absfun->name, out, err);
+		gu_string_write(next_absfun->name, out, err);
 		gu_puts("\n", out, err);
 #endif
 
@@ -135,7 +154,7 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 
 		// compile TRY_FIRST
 		jit_prepare(3);
-		jit_movi_p(JIT_V0,absfun);
+		jit_movi_p(JIT_V0,next_absfun);
 		jit_pusharg_p(JIT_V0);
 		jit_pusharg_p(JIT_V2);
 		jit_pusharg_p(JIT_V1);
@@ -150,20 +169,15 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 
 #ifdef PGF_JIT_DEBUG
 	if (n_funs > 0) {
-		PgfAbsFun* absfun = 
-			gu_buf_get(functions, PgfAbsFun*, 0);
-
-		gu_string_write(absfun->name, out, err);
+		gu_string_write(next_absfun->name, out, err);
 		gu_puts(":\n", out, err);
 	}
 #endif
 
 	for (size_t i = 0; i < n_funs; i++) {
-		PgfAbsFun* absfun = 
-			gu_buf_get(functions, PgfAbsFun*, i);
-
-		pgf_jit_make_space(state);
+		pgf_jit_make_space(rdr);
 
+		absfun = next_absfun;
 		absfun->predicate = (PgfPredicate) jit_get_ip().ptr;
 
 		jit_prolog(2);
@@ -176,18 +190,17 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 
 		if (n_hypos > 0) {
 			if (i+1 < n_funs) {
-				PgfAbsFun* absfun = 
-					gu_buf_get(functions, PgfAbsFun*, i+1);
+				next_absfun = pgf_jit_read_absfun(rdr, abstr); // i+1
 
 #ifdef PGF_JIT_DEBUG
 				gu_puts("    TRY_ELSE ", out, err);
-				gu_string_write(absfun->name, out, err);
+				gu_string_write(next_absfun->name, out, err);
 				gu_puts("\n", out, err);
 #endif
 
 				// compile TRY_ELSE
 				jit_prepare(3);
-				jit_movi_p(JIT_V0, absfun);
+				jit_movi_p(JIT_V0, next_absfun);
 				jit_pusharg_p(JIT_V0);
 				jit_pusharg_p(JIT_V2);
 				jit_pusharg_p(JIT_V1);
@@ -200,9 +213,6 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 				jit_insn *ref;
 				
 				// call the predicate for the category in hypo->type->cid
-				PgfAbsCat* arg =
-					gu_map_get(abscats, hypo->type->cid, PgfAbsCat*);
-
 #ifdef PGF_JIT_DEBUG
 				gu_puts("    CALL ", out, err);
 				gu_string_write(hypo->type->cid, out, err);
@@ -219,14 +229,11 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 				jit_prepare(2);
 				jit_pusharg_p(JIT_V2);
 				jit_pusharg_p(JIT_V1);
-				if (arg != NULL) {
-					jit_finish(arg->predicate);
-				} else {
-					PgfCallPatch patch;
-					patch.cid = hypo->type->cid;
-					patch.ref = jit_finish(jit_forward());
-					gu_buf_push(state->patches, PgfCallPatch, patch);
-				}
+
+				PgfCallPatch patch;
+				patch.cid = hypo->type->cid;
+				patch.ref = jit_finish(jit_forward());
+				gu_buf_push(rdr->jit_state->patches, PgfCallPatch, patch);
 
 #ifdef PGF_JIT_DEBUG
 				gu_puts("    RET\n", out, err);
@@ -239,7 +246,7 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 				jit_ret();
 
 				if (i+1 < n_hypos) {
-					pgf_jit_make_space(state);
+					pgf_jit_make_space(rdr);
 
 					jit_patch_movi(ref,jit_get_label());
 					
@@ -254,18 +261,17 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 			}
 		} else {
 			if (i+1 < n_funs) {
-				PgfAbsFun* absfun = 
-					gu_buf_get(functions, PgfAbsFun*, i+1);
+				next_absfun = pgf_jit_read_absfun(rdr, abstr); // i+1
 
 #ifdef PGF_JIT_DEBUG
 				gu_puts("    TRY_CONSTANT ", out, err);
-				gu_string_write(absfun->name, out, err);
+				gu_string_write(next_absfun->name, out, err);
 				gu_puts("\n", out, err);
 #endif
 
 				// compile TRY_CONSTANT
 				jit_prepare(3);
-				jit_movi_p(JIT_V0, absfun);
+				jit_movi_p(JIT_V0, next_absfun);
 				jit_pusharg_p(JIT_V0);
 				jit_pusharg_p(JIT_V2);
 				jit_pusharg_p(JIT_V1);
@@ -289,13 +295,10 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 			// compile RET
 			jit_ret();
 		}
-		
+
 #ifdef PGF_JIT_DEBUG
 		if (i+1 < n_funs) {
-			PgfAbsFun* absfun = 
-				gu_buf_get(functions, PgfAbsFun*, i+1);
-
-			gu_string_write(absfun->name, out, err);
+			gu_string_write(next_absfun->name, out, err);
 			gu_puts(":\n", out, err);
 		}
 #endif
@@ -307,18 +310,251 @@ pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats,
 }
 
 void
-pgf_jit_done(PgfJitState* state, PgfAbstr* abstr)
+pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
+                 PgfAbsFun* absfun)
 {
-	size_t n_patches = gu_buf_length(state->patches);
+#ifdef PGF_JIT_DEBUG
+	GuPool* tmp_pool = gu_new_pool();
+    GuOut* out = gu_file_out(stderr, tmp_pool);
+    GuExn* err = gu_exn(NULL, type, tmp_pool);
+    
+	gu_string_write(absfun->name, out, err);
+	gu_puts(":\n", out, err);
+#endif
+
+	pgf_jit_make_space(rdr);
+
+	absfun->function = jit_get_ip().ptr;
+
+	jit_prolog(2);
+
+	int es_arg = jit_arg_p();
+	int closure_arg = jit_arg_p();
+
+	size_t n_instrs = pgf_read_len(rdr);
+	gu_return_on_exn(rdr->err, );
+	
+	size_t curr_offset = 0;
+	size_t curr_label  = 0;
+	
+	for (size_t i = 0; i < n_instrs; i++) {
+#ifdef PGF_JIT_DEBUG
+   	    gu_printf(out, err, "%04d ", curr_label++);
+#endif
+
+		uint8_t opcode = pgf_read_tag(rdr);
+		switch (opcode) {
+		case PGF_INSTR_EVAL: {
+			size_t index = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "EVAL         %d\n", index);
+#endif
+
+			jit_getarg_p(JIT_V0, es_arg);
+			jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
+			jit_prepare(1);
+			jit_pusharg_p(JIT_V0);
+			jit_finish(gu_buf_length);
+			jit_subi_i(JIT_V2, JIT_RET, index+1);
+			jit_lshi_i(JIT_V2, JIT_V2, 2);
+			jit_prepare(1);
+			jit_pusharg_p(JIT_V0);
+			jit_finish(gu_buf_data);
+			jit_ldxr_p(JIT_V0, JIT_RET, JIT_V2);
+			jit_prepare(2);
+			jit_pusharg_p(JIT_V0);
+			jit_getarg_p(JIT_V2, es_arg);
+			jit_pusharg_p(JIT_V2);
+			jit_ldr_p(JIT_V0, JIT_V0);
+			jit_callr(JIT_V0);
+			break;
+		}
+		case PGF_INSTR_CASE: {
+			PgfCId id  = pgf_read_cid(rdr, rdr->opool);
+			int offset = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "CASE         %s %04d\n", id, curr_label+offset);
+#endif
+			break;
+		}
+		case PGF_INSTR_CASE_INT: {
+			int n = pgf_read_int(rdr);
+			int offset = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "CASE_INT     %d %04d\n", n, curr_label+offset);
+#endif
+			break;
+		}
+		case PGF_INSTR_CASE_STR: {
+			GuString s = pgf_read_string(rdr);
+			int offset = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "CASE_STR     %s %04d\n", s, curr_label+offset);
+#endif
+			break;
+		}
+		case PGF_INSTR_CASE_FLT: {
+			double d = pgf_read_double(rdr);
+			int offset = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "CASE_FLT     %f %04d\n", d, curr_label+offset);
+#endif
+			break;
+		}
+		case PGF_INSTR_ALLOC: {
+			size_t size = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "ALLOC        %d\n", size);
+#endif
+			jit_prepare(2);
+			jit_movi_ui(JIT_V0, size*sizeof(void*));
+			jit_pusharg_ui(JIT_V0);
+			jit_getarg_p(JIT_V0, es_arg);
+			jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,pool));
+			jit_pusharg_p(JIT_V0);
+			jit_finish(gu_malloc);
+			jit_retval_p(JIT_V1);
+			
+			curr_offset = 0;
+			break;
+		}
+		case PGF_INSTR_PUT_CONSTR: {
+			PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "PUT_CONSTR   %s\n", id);
+#endif
+
+			jit_movi_p(JIT_V0, pgf_evaluate_value);
+			jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0);
+			curr_offset++;
+			
+			PgfCallPatch patch;
+			patch.cid = id;
+			patch.ref = jit_movi_p(JIT_V0, jit_forward());
+			jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0);
+			curr_offset++;
+
+			gu_buf_push(rdr->jit_state->patches, PgfCallPatch, patch);
+			break;
+		}
+		case PGF_INSTR_PUT_CLOSURE: {
+			size_t addr = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "PUT_CLOSURE  %d\n", addr);
+#endif
+			break;
+		}
+		case PGF_INSTR_PUT_INT: {
+			size_t n = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "PUT_INT      %d\n", n);
+#endif
+			break;
+		}
+		case PGF_INSTR_PUT_STR: {
+			size_t addr = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "PUT_STR      %d\n", addr);
+#endif
+			break;
+		}
+		case PGF_INSTR_PUT_FLT: {
+			size_t addr = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "PUT_FLT      %d\n", addr);
+#endif
+			
+			break;
+		}
+		case PGF_INSTR_SET_VALUE: {
+			size_t offset = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "SET_VALUE    %d\n", offset);
+#endif
+			jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*));
+			jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0);
+			curr_offset++;
+			break;
+		}
+		case PGF_INSTR_SET_VARIABLE: {
+			size_t index = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "SET_VARIABLE %d\n", index);
+#endif
+
+			jit_getarg_p(JIT_V0, es_arg);
+			jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
+			jit_prepare(1);
+			jit_pusharg_p(JIT_V0);
+			jit_finish(gu_buf_length);
+			jit_subi_i(JIT_V2, JIT_RET, index+1);
+			jit_lshi_i(JIT_V2, JIT_V2, 2);
+			jit_prepare(1);
+			jit_pusharg_p(JIT_V0);
+			jit_finish(gu_buf_data);
+			jit_ldxr_p(JIT_V0, JIT_RET, JIT_V2);
+			jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0);
+			break;
+		}
+		case PGF_INSTR_TAIL_CALL: {
+			PgfCId id = pgf_read_cid(rdr, rdr->tmp_pool);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "TAIL_CALL    %s\n", id);
+#endif
+			break;
+		}
+		case PGF_INSTR_FAIL:
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "FAIL\n");
+#endif
+			break;
+		case PGF_INSTR_RET: {
+		    size_t count = pgf_read_int(rdr);
+
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "RET          %d\n", count);
+#endif
+
+			jit_prepare(2);
+			jit_movi_ui(JIT_V0, count);
+			jit_pusharg_p(JIT_V0);
+			jit_getarg_p(JIT_V0, es_arg);
+			jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfEvalState,stack));
+			jit_pusharg_p(JIT_V0);
+			jit_finish(gu_buf_trim_n);
+
+			jit_movr_p(JIT_RET, JIT_V1);
+			jit_ret();
+			break;
+		}
+		default:
+			gu_impossible();
+		}
+	}
+}
+
+void
+pgf_jit_done(PgfReader* rdr, PgfAbstr* abstr)
+{
+	size_t n_patches = gu_buf_length(rdr->jit_state->patches);
 	for (size_t i = 0; i < n_patches; i++) {
 		PgfCallPatch* patch =
-			gu_buf_index(state->patches, PgfCallPatch, i);
+			gu_buf_index(rdr->jit_state->patches, PgfCallPatch, i);
+
 		PgfAbsCat* arg =
 			gu_map_get(abstr->cats, patch->cid, PgfAbsCat*);
-		gu_assert(arg != NULL);
-
-		jit_patch_calli(patch->ref,(jit_insn*) arg->predicate);
+		if (arg != NULL)
+			jit_patch_calli(patch->ref,(jit_insn*) arg->predicate);
+		else {
+			PgfAbsFun* con =
+				gu_map_get(abstr->funs, patch->cid, PgfAbsFun*);
+			if (con != NULL)
+				jit_patch_movi(patch->ref,con);
+			else {
+				gu_impossible();
+			}
+		}
 	}
 	
-	jit_flush_code(state->buf, jit_get_ip().ptr);
+	jit_flush_code(rdr->jit_state->buf, jit_get_ip().ptr);
 }

src/runtime/c/pgf/jit.h

@@ -1,16 +0,0 @@
-#ifndef PGF_JIT_H_
-#define PGF_JIT_H_
-
-typedef struct PgfJitState PgfJitState;
-
-PgfJitState*
-pgf_jit_init(GuPool* tmp_pool, GuPool* pool);
-
-void
-pgf_jit_done(PgfJitState* state, PgfAbstr* abstr);
-
-void
-pgf_jit_predicate(PgfJitState* state, PgfCIdMap* abscats, 
-                  PgfAbsCat* abscat, GuBuf* functions);
-
-#endif

src/runtime/c/pgf/pgf.h

@@ -17,44 +17,24 @@ extern GU_DECLARE_TYPE(PgfExn, abstract);
 extern GU_DECLARE_TYPE(PgfParseError, abstract);
 extern GU_DECLARE_TYPE(PgfTypeError, abstract);
 
-/// @name PGF Grammar objects
-/// @{
-
 typedef struct PgfPGF PgfPGF;
 
 typedef struct PgfConcr PgfConcr;
 
-
-/**< A representation of a PGF grammar. 
- */
-
 #include <pgf/expr.h>
 #include <pgf/graphviz.h>
 
-/// An enumeration of #PgfExpr elements.
 typedef GuEnum PgfExprEnum;
 
 PgfPGF*
 pgf_read(const char* fpath,
          GuPool* pool, GuExn* err);
 
-/**< Read a grammar from a PGF file.
- *
- * @param from  PGF input stream.
- * The stream must be positioned in the beginning of a binary
- * PGF representation. After a succesful invocation, the stream is
- * still open and positioned at the end of the representation.
- *
- * @param[out] err_out  Raised error.
- * If non-\c NULL, \c *err_out should be \c NULL. Then, upon
- * failure, \c *err_out is set to point to a newly allocated
- * error object, which the caller must free with #g_exn_free
- * or #g_exn_propagate.
- *
- * @return A new PGF object, or \c NULL upon failure. The returned
- * object must later be freed with #pgf_free.
- *
- */
+void
+pgf_concrete_load(PgfConcr* concr, GuIn* in, GuExn* err);
+
+void
+pgf_concrete_unload(PgfConcr* concr);
 
 GuString
 pgf_abstract_name(PgfPGF*);
@@ -176,8 +156,6 @@ pgf_concr_add_literal(PgfConcr *concr, PgfCId cat,
                       PgfLiteralCallback* callback,
                       GuExn* err);
 
-/// @}
-
 void
 pgf_print(PgfPGF* pgf, GuOut* out, GuExn* err); 
 

src/runtime/c/pgf/reader.c

@@ -2,7 +2,6 @@
 #include "expr.h"
 #include "literals.h"
 #include "reader.h"
-#include "jit.h"
 
 #include <gu/defs.h>
 #include <gu/map.h>
@@ -22,14 +21,6 @@
 // PgfReader
 // 
 
-struct PgfReader {
-	GuIn* in;
-	GuExn* err;
-	GuPool* opool;
-	GuPool* tmp_pool;
-	PgfJitState* jit_state;
-};
-
 typedef struct PgfReadTagExn PgfReadTagExn;
 
 struct PgfReadTagExn {
@@ -41,13 +32,13 @@ static GU_DEFINE_TYPE(PgfReadTagExn, abstract, _);
 
 static GU_DEFINE_TYPE(PgfReadExn, abstract, _);
 
-static uint8_t
+uint8_t
 pgf_read_tag(PgfReader* rdr)
 {
 	return gu_in_u8(rdr->in, rdr->err);
 }
 
-static uint32_t
+uint32_t
 pgf_read_uint(PgfReader* rdr)
 {
 	uint32_t u = 0;
@@ -62,14 +53,14 @@ pgf_read_uint(PgfReader* rdr)
 	return u;
 }
 
-static int32_t
+int32_t
 pgf_read_int(PgfReader* rdr)
 {
 	uint32_t u = pgf_read_uint(rdr);
 	return gu_decode_2c32(u, rdr->err);
 }
 
-static GuLength
+size_t
 pgf_read_len(PgfReader* rdr)
 {
 	int32_t len = pgf_read_int(rdr);
@@ -88,23 +79,29 @@ pgf_read_len(PgfReader* rdr)
 
 		return 0;
 	}
-	return (GuLength) len;
+	return len;
 }
 
-static PgfCId
+PgfCId
 pgf_read_cid(PgfReader* rdr, GuPool* pool)
 {
 	size_t len = pgf_read_len(rdr);
 	return gu_string_read_latin1(len, pool, rdr->in, rdr->err);
 }
 
-static GuString
+GuString
 pgf_read_string(PgfReader* rdr)
 {	
 	GuLength len = pgf_read_len(rdr);
 	return gu_string_read(len, rdr->opool, rdr->in, rdr->err);
 }
 
+double
+pgf_read_double(PgfReader* rdr)
+{
+	return gu_in_f64be(rdr->in, rdr->err);
+}
+
 static void
 pgf_read_tag_error(PgfReader* rdr)
 {
@@ -149,7 +146,7 @@ pgf_read_literal(PgfReader* rdr)
 			gu_new_variant(PGF_LITERAL_FLT,
 						   PgfLiteralFlt,
 						   &lit, rdr->opool);
-		lit_flt->val = gu_in_f64be(rdr->in, rdr->err);
+		lit_flt->val = pgf_read_double(rdr);
 		break;
 	}
 	default:
@@ -417,7 +414,7 @@ pgf_read_patt(PgfReader* rdr)
 }
 
 static PgfAbsFun*
-pgf_read_absfun(PgfReader* rdr)
+pgf_read_absfun(PgfReader* rdr, PgfAbstr* abstr)
 {
 	PgfAbsFun* absfun = gu_new(PgfAbsFun, rdr->opool);
 
@@ -444,6 +441,7 @@ pgf_read_absfun(PgfReader* rdr)
 	switch (tag) {
 	case 0:
 		absfun->defns = NULL;
+		absfun->function = NULL;
 		break;
 	case 1: {
         GuLength length = pgf_read_len(rdr);
@@ -468,6 +466,8 @@ pgf_read_absfun(PgfReader* rdr)
 
             data[i] = equ;
         }
+        
+      // 	pgf_jit_function(rdr, abstr, absfun);
 		break;
     }
 	default:
@@ -475,13 +475,13 @@ pgf_read_absfun(PgfReader* rdr)
 		break;
 	}
 
-	absfun->ep.prob = - log(gu_in_f64be(rdr->in, rdr->err));
+	absfun->ep.prob = - log(pgf_read_double(rdr));
 
 	return absfun;
 }
 					    
 static PgfCIdMap*
-pgf_read_absfuns(PgfReader* rdr)
+pgf_read_absfuns(PgfReader* rdr, PgfAbstr* abstr)
 {
 	GuMapType* map_type = (GuMapType*)
 		GU_TYPE_LIT(GuStringMap, _,
@@ -493,7 +493,7 @@ pgf_read_absfuns(PgfReader* rdr)
 	gu_return_on_exn(rdr->err, NULL);
 
 	for (size_t i = 0; i < len; i++) {
-		PgfAbsFun* absfun = pgf_read_absfun(rdr);
+		PgfAbsFun* absfun = pgf_read_absfun(rdr, abstr);
 		gu_return_on_exn(rdr->err, NULL);
 		
 		gu_map_put(absfuns, absfun->name, PgfAbsFun*, absfun);
@@ -519,27 +519,9 @@ pgf_read_abscat(PgfReader* rdr, PgfAbstr* abstr, PgfCIdMap* abscats)
 		gu_return_on_exn(rdr->err, NULL);
 	}
 
-    GuBuf* functions = gu_new_buf(PgfAbsFun*, rdr->tmp_pool);
+	pgf_jit_predicate(rdr, abstr, abscat);
 
-	size_t n_functions = pgf_read_len(rdr);
-	gu_return_on_exn(rdr->err, NULL);
-
-	for (size_t i = 0; i < n_functions; i++) {
-		gu_in_f64be(rdr->in, rdr->err);  // ignore
-		gu_return_on_exn(rdr->err, NULL);
-
-		PgfCId name = pgf_read_cid(rdr, rdr->tmp_pool);
-		gu_return_on_exn(rdr->err, NULL);
-		
-		PgfAbsFun* absfun =
-			gu_map_get(abstr->funs, name, PgfAbsFun*);
-		assert(absfun != NULL);
-		gu_buf_push(functions, PgfAbsFun*, absfun);
-	}
-
-	abscat->prob = - log(gu_in_f64be(rdr->in, rdr->err));
-
-	pgf_jit_predicate(rdr->jit_state, abscats, abscat, functions);
+	abscat->prob = - log(pgf_read_double(rdr));
 
 	return abscat;
 }
@@ -552,7 +534,7 @@ pgf_read_abscats(PgfReader* rdr, PgfAbstr* abstr)
 			 		gu_ptr_type(PgfAbsCat),
 					&gu_null_struct);
 	PgfCIdMap* abscats = gu_map_type_make(map_type, rdr->opool);
-	
+
 	size_t len = pgf_read_len(rdr);
 	gu_return_on_exn(rdr->err, NULL);
 
@@ -575,7 +557,7 @@ pgf_read_abstract(PgfReader* rdr, PgfAbstr* abstract)
 	abstract->aflags = pgf_read_flags(rdr);
 	gu_return_on_exn(rdr->err, );
 	
-	abstract->funs = pgf_read_absfuns(rdr);
+	abstract->funs = pgf_read_absfuns(rdr, abstract);
 	gu_return_on_exn(rdr->err, );
 	
 	abstract->cats = pgf_read_abscats(rdr, abstract);
@@ -1350,7 +1332,7 @@ pgf_new_reader(GuIn* in, GuPool* opool, GuPool* tmp_pool, GuExn* err)
 	rdr->tmp_pool = tmp_pool;
 	rdr->err = err;
 	rdr->in = in;
-	rdr->jit_state = pgf_jit_init(tmp_pool, rdr->opool);
+	rdr->jit_state = pgf_new_jit(rdr);
 	return rdr;
 }
 
@@ -1360,5 +1342,5 @@ pgf_reader_done(PgfReader* rdr, PgfPGF* pgf)
 	if (pgf == NULL)
 		return;
 
-	pgf_jit_done(rdr->jit_state, &pgf->abstract);
+	pgf_jit_done(rdr, &pgf->abstract);
 }

src/runtime/c/pgf/reader.h

@@ -5,21 +5,64 @@
 #include <gu/mem.h>
 #include <gu/in.h>
 
-typedef struct PgfReader PgfReader;
+// general reader interface
+
+typedef struct {
+	GuIn* in;
+	GuExn* err;
+	GuPool* opool;
+	GuPool* tmp_pool;
+	struct PgfJitState* jit_state;
+} PgfReader;
 
 PgfReader*
 pgf_new_reader(GuIn* in, GuPool* opool, GuPool* tmp_pool, GuExn* err);
 
+uint8_t
+pgf_read_tag(PgfReader* rdr);
+
+uint32_t
+pgf_read_uint(PgfReader* rdr);
+
+int32_t
+pgf_read_int(PgfReader* rdr);
+
+GuString
+pgf_read_string(PgfReader* rdr);
+
+double
+pgf_read_double(PgfReader* rdr);
+
+size_t
+pgf_read_len(PgfReader* rdr);
+
+PgfCId
+pgf_read_cid(PgfReader* rdr, GuPool* pool);
+
 PgfPGF*
 pgf_read_pgf(PgfReader* rdr);
 
-void
-pgf_concrete_load(PgfConcr* concr, GuIn* in, GuExn* err);
-
-void
-pgf_concrete_unload(PgfConcr* concr);
-
 void
 pgf_reader_done(PgfReader* rdr, PgfPGF* pgf);
 
+
+// JIT specific interface
+
+typedef struct PgfJitState PgfJitState;
+
+PgfJitState*
+pgf_new_jit(PgfReader* rdr);
+
+void
+pgf_jit_predicate(PgfReader* rdr, PgfAbstr* abstr,
+                  PgfAbsCat* abscat);
+
+void
+pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
+                 PgfAbsFun* absfun);
+
+void
+pgf_jit_done(PgfReader* state, PgfAbstr* abstr);
+
+
 #endif // READER_H_

src/runtime/haskell/PGF.hs

@@ -293,8 +293,8 @@ categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
 
 categoryContext pgf cat =
   case Map.lookup cat (cats (abstract pgf)) of
-    Just (hypos,_,_,_) -> Just hypos
-    Nothing            -> Nothing
+    Just (hypos,_,_) -> Just hypos
+    Nothing          -> Nothing
 
 startCat pgf = DTyp [] (lookStartCat pgf) []
 
@@ -302,13 +302,13 @@ functions pgf = Map.keys (funs (abstract pgf))
 
 functionsByCat pgf cat =
   case Map.lookup cat (cats (abstract pgf)) of
-    Just (_,fns,_,_) -> map snd fns
-    Nothing          -> []
+    Just (_,fns,_) -> map snd fns
+    Nothing        -> []
 
 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
@@ -318,20 +318,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')

src/runtime/haskell/PGF/Binary.hs

@@ -3,12 +3,12 @@ module PGF.Binary(putSplitAbs) where
 import PGF.CId
 import PGF.Data
 import PGF.Optimize
+import PGF.ByteCode
 import qualified PGF.OldBinary as Old
 import Data.Binary
 import Data.Binary.Put
 import Data.Binary.Get
 import Data.Array.IArray
-import qualified Data.ByteString as BS
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 --import qualified Data.Set as Set
@@ -43,16 +43,15 @@ instance Binary CId where
   get    = liftM CId get
 
 instance Binary Abstr where
-  put abs = put (aflags abs, 
-                 fmap (\(w,x,y,z,_) -> (w,x,y,z)) (funs abs),
-                 fmap (\(x,y,z,_) -> (x,y,z)) (cats abs))
+  put abs = do put (aflags abs)
+               put (Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap fst mb_eq,prob)) (funs abs))
+               put (cats abs)
   get = do aflags <- get
            funs <- get
            cats <- get
            return (Abstr{ aflags=aflags
-                        , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs
-                        , cats=fmap (\(x,y,z) -> (x,y,z,0)) cats
-                        , code=BS.empty                        
+                        , funs=Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs
+                        , cats=cats
                         })
 
 putSplitAbs :: PGF -> Put
@@ -136,6 +135,25 @@ instance Binary Equation where
   put (Equ ps e) = put (ps,e)
   get = liftM2 Equ get get
 
+instance Binary Instr where
+  put (EVAL         n) = putWord8 0  >> put n
+  put (CASE id l     ) = putWord8 1  >> put (id,l)
+  put (CASE_INT n l  ) = putWord8 2  >> put (n,l)
+  put (CASE_STR s l  ) = putWord8 3  >> put (s,l)
+  put (CASE_FLT d l  ) = putWord8 4  >> put (d,l)
+  put (ALLOC        n) = putWord8 5  >> put n
+  put (PUT_CONSTR  id) = putWord8 6  >> put id
+  put (PUT_CLOSURE  l) = putWord8 7  >> put l
+  put (PUT_INT      n) = putWord8 8  >> put n
+  put (PUT_STR      s) = putWord8 9  >> put s
+  put (PUT_FLT      d) = putWord8 10 >> put d
+  put (SET_VALUE    n) = putWord8 11 >> put n
+  put (SET_VARIABLE n) = putWord8 12 >> put n
+  put (TAIL_CALL   id) = putWord8 13 >> put id
+  put (FAIL          ) = putWord8 14
+  put (RET          n) = putWord8 15 >> put n
+
+
 instance Binary Type where
   put (DTyp hypos cat exps) = put (hypos,cat,exps)
   get = liftM3 DTyp get get get

src/runtime/haskell/PGF/ByteCode.hs

@@ -0,0 +1,47 @@
+module PGF.ByteCode(CodeLabel, Instr(..), ppCode, ppInstr) where
+
+import PGF.CId
+import Text.PrettyPrint
+
+type CodeLabel = Int
+
+data Instr
+  = EVAL   {-# UNPACK #-} !Int
+  | CASE CId     {-# UNPACK #-} !CodeLabel
+  | CASE_INT Int    {-# UNPACK #-} !CodeLabel
+  | CASE_STR String {-# UNPACK #-} !CodeLabel
+  | CASE_FLT Double {-# UNPACK #-} !CodeLabel
+  | ALLOC  {-# UNPACK #-} !Int
+  | PUT_CONSTR CId
+  | PUT_CLOSURE   {-# UNPACK #-} !CodeLabel
+  | PUT_INT {-# UNPACK #-} !Int
+  | PUT_STR String
+  | PUT_FLT {-# UNPACK #-} !Double
+  | SET_VALUE {-# UNPACK #-} !Int
+  | SET_VARIABLE    {-# UNPACK #-} !Int
+  | TAIL_CALL    CId
+  | FAIL
+  | RET {-# UNPACK #-} !Int
+
+ppCode :: CodeLabel -> [Instr] -> Doc
+ppCode l []     = empty
+ppCode l (i:is) = ppLabel l <+> ppInstr l i $$ ppCode (l+1) is
+
+ppInstr l (EVAL         n) = text "EVAL        " <+> int n
+ppInstr l (CASE id o     ) = text "CASE        " <+> ppCId id <+> ppLabel (l+o+1)
+ppInstr l (CASE_INT n o  ) = text "CASE_INT    " <+> int n <+> ppLabel (l+o+1)
+ppInstr l (CASE_STR s o  ) = text "CASE_STR    " <+> text (show s) <+> ppLabel (l+o+1)
+ppInstr l (CASE_FLT d o  ) = text "CASE_FLT    " <+> double d <+> ppLabel (l+o+1)
+ppInstr l (ALLOC        n) = text "ALLOC       " <+> int n
+ppInstr l (SET_VALUE    n) = text "SET_VALUE   " <+> int n
+ppInstr l (PUT_CONSTR  id) = text "PUT_CONSTR  " <+> ppCId id
+ppInstr l (PUT_CLOSURE  c) = text "PUT_CLOSURE " <+> ppLabel c
+ppInstr l (PUT_INT n     ) = text "PUT_INT     " <+> int n
+ppInstr l (PUT_STR s     ) = text "PUT_STR     " <+> text (show s)
+ppInstr l (PUT_FLT d     ) = text "PUT_FLT     " <+> double d
+ppInstr l (SET_VARIABLE n) = text "SET_VARIABLE" <+> int n
+ppInstr l (TAIL_CALL   id) = text "TAIL_CALL   " <+> ppCId id
+ppInstr l (FAIL          ) = text "FAIL"
+ppInstr l (RET          n) = text "RET         " <+> int n
+
+ppLabel l = text (let s = show l in replicate (4-length s) '0' ++ s)

src/runtime/haskell/PGF/Data.hs

@@ -2,6 +2,7 @@ module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type) where
 
 import PGF.CId
 import PGF.Expr hiding (Value, Sig, Env, Tree, eval, apply, applyValue, value2expr)
+import PGF.ByteCode
 import PGF.Type
 
 import qualified Data.Map as Map
@@ -9,7 +10,6 @@ import qualified Data.Set as Set
 import qualified Data.IntMap as IntMap
 import qualified Data.IntSet as IntSet
 import qualified PGF.TrieMap as TMap
-import qualified Data.ByteString as BS
 import Data.Array.IArray
 import Data.Array.Unboxed
 --import Data.List
@@ -28,12 +28,11 @@ data PGF = PGF {
 
 data Abstr = Abstr {
   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)],Double,BCAddr),    -- ^ 1. context of a category
-                                                                    --   2. functions of a category. The functions are stored
-                                                                    --      in decreasing probability order.
-                                                                    --   3. probability
-  code    :: BS.ByteString
+  funs    :: Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double),-- ^ type, arrity and definition of function + probability
+  cats    :: Map.Map CId ([Hypo],[(Double, CId)],Double)              -- ^ 1. context of a category
+                                                                      --   2. functions of a category. The functions are stored
+                                                                      --      in decreasing probability order.
+                                                                      --   3. probability
   }
 
 data Concr = Concr {
@@ -76,8 +75,6 @@ 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
-
 
 -- merge two PGFs; fails is differens absnames; priority to second arg
 
@@ -105,8 +102,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.

src/runtime/haskell/PGF/Expr.hs

@@ -21,6 +21,7 @@ module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..
 
 import PGF.CId
 import PGF.Type
+import PGF.ByteCode
 
 import Data.Char
 --import Data.Maybe
@@ -324,21 +325,22 @@ data Value
   | VClosure Env Expr
   | VImplArg Value
 
-type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double,Int) -- type and def of a fun
-           , Int -> Maybe Expr                                  -- lookup for metavariables
+type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double) -- 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 []
+                              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)
@@ -353,11 +355,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

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),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)

src/runtime/haskell/PGF/Internal.hs

@@ -11,6 +11,7 @@ import PGF.Macros as Internal
 import PGF.Optimize as Internal
 import PGF.Printer as Internal
 import PGF.Utilities as Internal
+import PGF.ByteCode as Internal
 
 import Data.Binary as Internal
 import Data.Binary.Get as Internal

src/runtime/haskell/PGF/Linearize.hs

@@ -101,7 +101,7 @@ linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] 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) = 

src/runtime/haskell/PGF/Macros.hs

@@ -21,18 +21,13 @@ 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
-
-lookDef :: Abstr -> CId -> Maybe [Equation]
-lookDef abs f = 
-  case lookMap (error $ "lookDef " ++ show f) f (funs abs) of
-    (_,a,eqs,_,_) -> eqs
+    (ty,_,_,_) -> ty
 
 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 +60,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 ([],[],0,0) cat $ cats $ abstract pgf
+   (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf
 
 -- | List of functions that lack linearizations in the given language.
 missingLins :: PGF -> Language -> [CId]
@@ -82,7 +77,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,p,addr) -> (hyps,filter (cond . snd) fs,p,addr)) (cats abstr)
+    cats = Map.map (\(hyps,fs,p) -> (hyps,filter (cond . snd) fs,p)) (cats abstr)
     }
   }  ---- restrict concrs also, might be needed
  where

src/runtime/haskell/PGF/OldBinary.hs

@@ -7,7 +7,6 @@ import PGF.Optimize
 import Data.Binary
 import Data.Binary.Get
 import Data.Array.IArray
-import qualified Data.ByteString as BS
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import qualified Data.Set as Set
@@ -40,9 +39,8 @@ getAbstract =
            funs <- getMap getCId getFun
            cats <- getMap getCId getCat
            return (Abstr{ aflags=aflags
-                        , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs
-                        , cats=fmap (\(x,y) -> (x,y,0,0)) cats
-                        , code=BS.empty                        
+                        , funs=fmap (\(w,x,y,z) -> (w,x,fmap (flip (,) []) y,z)) funs
+                        , cats=fmap (\(x,y) -> (x,y,0)) cats
                         })
 getFun :: Get (Type,Int,Maybe [Equation],Double)
 getFun = (,,,) `fmap` getType `ap` get `ap` getMaybe (getList getEquation) `ap` get

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

src/runtime/haskell/PGF/Printer.hs

@@ -2,7 +2,7 @@ module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where
 
 import PGF.CId
 import PGF.Data
---import PGF.Macros
+import PGF.ByteCode
 
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -26,17 +26,18 @@ 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)],Double,BCAddr) -> Doc
-ppCat c (hyps,_,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
+ppCat :: CId -> ([Hypo],[(Double,CId)],Double) -> 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 ';'
+ppFun :: CId -> (Type,Int,Maybe ([Equation],[Instr]),Double) -> Doc
+ppFun f (t,_,Just (eqs,code),_) = 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] $$
+                                  ppCode 0 code
+ppFun f (t,_,Nothing,_)         = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
 
 ppCnc :: Language -> Concr -> Doc
 ppCnc name cnc =

src/runtime/haskell/PGF/Probabilistic.hs

@@ -52,7 +52,7 @@ readProbabilitiesFromFile file pgf = do
 mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities
 mkProbabilities pgf probs =
   let funs1 = Map.fromList [(f,p) | (_,(_,fns)) <- Map.toList cats1, (p,f) <- fns]
-      cats1 = Map.mapWithKey (\c (_,fns,_,_) -> 
+      cats1 = Map.mapWithKey (\c (_,fns,_) -> 
                                  let p'   = fromMaybe 0 (Map.lookup c probs)
                                      fns' = sortBy cmpProb (fill fns)
                                  in (p', fns'))
@@ -76,15 +76,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,p,_) -> (p,fns)) (cats (abstract pgf))
+  funProbs = Map.map (\(_,_,_,p) -> p      ) (funs (abstract pgf)),
+  catProbs = Map.map (\(_,fns,p) -> (p,fns)) (cats (abstract pgf))
   }
 
 setProbabilities :: Probabilities -> PGF -> PGF
 setProbabilities probs pgf = pgf {
   abstract = (abstract pgf) {
-    funs = mapUnionWith (\(ty,a,df,_,addr) p       -> (ty,a,df,  p,addr)) (funs (abstract pgf)) (funProbs probs),
-    cats = mapUnionWith (\(hypos,_,_,addr) (p,fns) -> (hypos,fns,p,addr)) (cats (abstract pgf)) (catProbs probs)
+    funs = mapUnionWith (\(ty,a,df,_) p       -> (ty,a,df,  p)) (funs (abstract pgf)) (funProbs probs),
+    cats = mapUnionWith (\(hypos,_,_) (p,fns) -> (hypos,fns,p)) (cats (abstract pgf)) (catProbs probs)
   }}
   where
     mapUnionWith f map1 map2 = 
@@ -95,8 +95,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
@@ -107,13 +107,13 @@ rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
 
 mkProbDefs :: PGF -> ([[CId]],[(CId,Type,[Equation])])
 mkProbDefs pgf =
-  let cs = [(c,hyps,fns) | (c,(hyps0,fs,_,_)) <- Map.toList (cats (abstract pgf)),
+  let cs = [(c,hyps,fns) | (c,(hyps0,fs,_)) <- Map.toList (cats (abstract pgf)),
                            not (elem c [cidString,cidInt,cidFloat]),
 	                       let hyps = zipWith (\(bt,_,ty) n -> (bt,mkCId ('v':show n),ty))
 	                                          hyps0
 	                                          [1..]
 	                           fns  = [(f,ty) | (_,f) <- fs, 
-	                                            let Just (ty,_,_,_,_) = Map.lookup f (funs (abstract pgf))]
+	                                            let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))]
            ]
       ((_,css),eqss) = mapAccumL (\(ngen,css) (c,hyps,fns) -> 
               let st0      = (1,Map.empty)
@@ -263,7 +263,7 @@ computeConstrs pgf st fns =
       where
         addArgs (cn,fns) = addArg (length args) cn [] fns
           where
-            Just (ty@(DTyp args _ es),_,_,_,_) = Map.lookup cn (funs (abstract pgf))
+            Just (ty@(DTyp args _ es),_,_,_) = Map.lookup cn (funs (abstract pgf))
 
         addArg 0 cn ps fns = [(PApp cn (reverse ps),fns)]
         addArg n cn ps fns = concat [addArg (n-1) cn (arg:ps) fns' | (arg,fns') <- computeConstr fns]

src/runtime/haskell/PGF/SortTop.hs

@@ -38,7 +38,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
@@ -51,7 +51,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             
 
@@ -67,7 +67,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
 

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

src/runtime/java/Test.java

@@ -3,10 +3,10 @@ import java.util.*;
 import org.grammaticalframework.pgf.*;
 
 public class Test {
-	public static void main(String[] args) {
+	public static void main(String[] args) throws IOException {		
 		PGF gr = null;
 		try {
-			gr = PGF.readPGF("Phrasebook.pgf");
+			gr = PGF.readPGF("/home/krasimir/www.grammaticalframework.org/examples/phrasebook/Phrasebook.pgf");
 		} catch (FileNotFoundException e) {
 			e.printStackTrace();
 			return;
@@ -14,28 +14,19 @@ public class Test {
 			e.printStackTrace();
 			return;
 		}
-
+		
+		Type typ = gr.getFunctionType("Bulgarian");
+		System.out.println(typ.getCategory());
 		System.out.println(gr.getAbstractName());
 		for (Map.Entry<String,Concr> entry : gr.getLanguages().entrySet()) {
 			System.out.println(entry.getKey()+" "+entry.getValue()+" "+entry.getValue().getName());
 			entry.getValue().addLiteral("PN", new NercLiteralCallback(gr,entry.getValue()));
 		}
-		
-		int count = 10;
-		for (ExprProb ep : gr.generateAll("Phrase")) {
-			System.out.println(ep.getExpr());
-			
-			if (count-- <= 0)
-				break;
-		}
-
-		Concr eng = gr.getLanguages().get("PhrasebookEng");
-		Concr ger = gr.getLanguages().get("PhrasebookGer");
 
+		Concr eng = gr.getLanguages().get("SimpleEng");
 		try {
-			for (ExprProb ep : eng.parse(gr.getStartCat(), "where is the hotel")) {
+			for (ExprProb ep : eng.parse(gr.getStartCat(), "persons who work with Malmö")) {
 				System.out.println("["+ep.getProb()+"] "+ep.getExpr());
-				System.out.println(ger.linearize(ep.getExpr()));
 			}
 		} catch (ParseError e) {
 			System.out.println("Parsing failed at token \""+e.getToken()+"\"");