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.

8 files changed, 102 insertions, 121 deletions

diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs
index 96fc13554..aebf918bb 100644
--- a/src/compiler/GF/Compile/CFGtoPGF.hs
+++ b/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]
 
diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs
index 61605e3f8..393c6722e 100644
--- a/src/compiler/GF/Compile/GenerateBC.hs
+++ b/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
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index feccea46a..f042d5f38 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/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
diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs
index 9a921f645..749ad24bc 100644
--- a/src/compiler/GF/Compile/PGFtoHaskell.hs
+++ b/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 =
diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs
index 534b00812..2195ce431 100644
--- a/src/compiler/GF/Compile/PGFtoJS.hs
+++ b/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)])
 
diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs
index 9f990d4f9..28ee6afaf 100644
--- a/src/compiler/GF/Compile/PGFtoLProlog.hs
+++ b/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)
diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs
index 25d1e6e41..1279e3d8a 100644
--- a/src/compiler/GF/Compile/PGFtoProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoProlog.hs
@@ -49,16 +49,16 @@ plAbstract name abs
                     (f, v) <- Map.assocs (aflags abs)] ++++
        plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
                    [[plType cat args, plHypos hypos'] |
-                    (cat, (hypos,_,_,_)) <- Map.assocs (cats abs),
+                    (cat, (hypos,_,_)) <- Map.assocs (cats abs),
                     let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
                         let args = reverse [EFun x | (_,x) <- subst]] ++++
        plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
                    [[plp fun, plType cat args, plHypos hypos] |
-                    (fun, (typ, _, _, _, _)) <- Map.assocs (funs abs),
+                    (fun, (typ, _, _, _)) <- Map.assocs (funs abs),
                     let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
        plFacts name "def" 2 "(?Fun, ?Expr)" 
                    [[plp fun, plp expr] |
-                    (fun, (_, _, Just eqs, _, _)) <- Map.assocs (funs abs),
+                    (fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
                     let (_, expr) = alphaConvert emptyEnv eqs]
       )
     where plType cat args = plTerm (plp cat) (map plp args)
diff --git a/src/compiler/GF/Compile/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs
index a186509fe..1fee9c8c5 100644
--- a/src/compiler/GF/Compile/PGFtoPython.hs
+++ b/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