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.

15 files changed, 156 insertions, 97 deletions

diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index 77eac1ada..8c901c7a9 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/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')
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 4d4c53102..b2bfda069 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/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

diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs
new file mode 100644
index 000000000..b8e7d889d
--- /dev/null
+++ b/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)
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index 3222867d2..76dbc616a 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/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.
diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index 264be4aaa..0b4ccc554 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/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

diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs
index 8a38948be..bb4ba29af 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),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)

diff --git a/src/runtime/haskell/PGF/Internal.hs b/src/runtime/haskell/PGF/Internal.hs
index f2c79596c..3b252a36b 100644
--- a/src/runtime/haskell/PGF/Internal.hs
+++ b/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
diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index ea560165d..3f11f93d1 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/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) = 
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 0e73180d5..7cf2661cc 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/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
diff --git a/src/runtime/haskell/PGF/OldBinary.hs b/src/runtime/haskell/PGF/OldBinary.hs
index 55a1f1a5c..9a65b0fa6 100644
--- a/src/runtime/haskell/PGF/OldBinary.hs
+++ b/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
diff --git a/src/runtime/haskell/PGF/Paraphrase.hs b/src/runtime/haskell/PGF/Paraphrase.hs
index 57697b8d2..8bee81f43 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 4945667f4..1aabce09d 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/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 ';'
-
-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 ';'
+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],[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 =
diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs
index 7d8d58134..555ae0ce9 100644
--- a/src/runtime/haskell/PGF/Probabilistic.hs
+++ b/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]
diff --git a/src/runtime/haskell/PGF/SortTop.hs b/src/runtime/haskell/PGF/SortTop.hs
index 5bebd89d6..f3747b805 100644
--- a/src/runtime/haskell/PGF/SortTop.hs
+++ b/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
 
diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index e582f97af..0818aeb4a 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