full support for recursive def rules in the C runtime

4 files changed, 114 insertions, 52 deletions

diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs
index 488368887..bab6cd4f4 100644
--- a/src/compiler/GF/Compile/GenerateBC.hs
+++ b/src/compiler/GF/Compile/GenerateBC.hs
@@ -6,21 +6,19 @@ import GF.Data.Operations
 import PGF(CId,utf8CId)
 import PGF.Internal(Instr(..))
 import qualified Data.Map as Map
-import Data.List(mapAccumL)
+import Data.List(nub)
 
-generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [Instr]
+generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
 generateByteCode gr arity eqs =
-  compileEquations gr arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs)
+  let (bs,instrs) = compileEquations gr arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) [ENTER:instrs]
+  in reverse bs
   where
     is = push_is (arity-1) arity []
 
-compileEquations :: SourceGrammar -> Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [Instr]
-compileEquations gr st _  []            = [FAIL]
-compileEquations gr st [] ((vs,[],t):_) =
-  let (heap,instrs) = compileBody gr st vs t 0 []
-  in (if heap > 0 then (ALLOC heap :) else id)
-     (instrs ++ [RET st])
-compileEquations gr st (i:is) eqs       = whilePP eqs Map.empty
+compileEquations :: SourceGrammar -> Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [[Instr]] -> ([[Instr]],[Instr])
+compileEquations gr st _  []            bs = (bs,[FAIL])
+compileEquations gr st [] ((vs,[],t):_) bs = compileBody gr st vs [] t bs []
+compileEquations gr st (i:is) eqs       bs = 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)
@@ -32,54 +30,118 @@ compileEquations gr st (i:is) eqs       = whilePP eqs Map.empty
     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 gr st (i:is) eqs
+    whilePV eqs                          cns vrs = let (bs1,instrs1) = mkCase cns (reverse vrs)
+                                                       (bs2,instrs2) = compileEquations gr st (i:is) eqs (instrs2:bs1)
+                                                   in (bs2,instrs1)
 
-    mkCase cns vrs
-      | Map.null cns = compileEquations gr st is vrs
-      | otherwise    = EVAL (st-i-1) :
-                       concat [compileBranch t n eqs | ((t,n),eqs) <- Map.toList cns] ++
-                       compileEquations gr st is vrs
+    mkCase cns vrs =
+      case Map.toList cns of
+        []       -> compileEquations gr st is vrs bs
+        (cn:cns) -> let (bs1,instrs1) = compileBranch0 cn bs
+                        bs2 = foldr compileBranch bs1 cns
+                        (bs3,instrs3) = compileEquations gr st is vrs (instrs3:bs2)
+                    in (bs3,instrs1)
 
-    compileBranch t n eqs =
+    compileBranch0 ((t,n),eqs) bs =
       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 gr (st+n) (push_is st n is) eqs
-      in case_instr (length instrs) : instrs
+          (bs1,instrs) = compileEquations gr (st+n) (push_is st n is) eqs bs
+      in (bs1, EVAL_ARG_VAR (st-i-1) : case_instr (length bs1) : instrs)
 
-compileBody gr st vs (App e1 e2) h0 es = compileBody gr st vs e1 h0 (e2:es)
-compileBody gr st vs (Q (m,id))  h0 es = case lookupAbsDef gr m id of
-                                           Ok (Just _,Just _) 
-                                              -> let ((h1,st1),iis) = mapAccumL (compileArg gr st vs) (h0,st) (reverse es)
-                                                     (is1,is2,is3) = unzip3 iis
-                                                 in (h1,concat is3 ++ is2 ++ [TAIL_CALL (i2i id)])
-                                           _  -> let h1 = h0 + 2 + length es
-                                                     ((h2,st1),iis)  = mapAccumL (compileArg gr st vs) (h1,st) es
-                                                     (is1,is2,is3) = unzip3 iis
-                                                 in (h2,PUT_CONSTR (i2i id) : concat (is1:is3))
-compileBody gr st vs (QC qid)    h0 es = compileBody gr st vs (Q qid) h0 es
-compileBody gr st vs (Vr x)      h0 es = case lookup x vs of
-                                           Just i  -> let ((h1,st1),iis)  = mapAccumL (compileArg gr st vs) (h0,st) (reverse es)
-                                                          (is1,is2,is3) = unzip3 iis
-                                                      in (h1,concat is3 ++ is2 ++ [EVAL (st-i-1)])
-                                           Nothing -> error "compileBody: unknown variable"
-compileBody gr st vs (EInt n)    h0 _  = let h1 = h0 + 2
-                                         in (h1,[PUT_INT n])
-compileBody gr st vs (K s)       h0 _  = let h1 = h0 + 1 + (length s + 4) `div` 4
-                                         in (h1,[PUT_STR s])
-compileBody gr st vs (EFloat d)  h0 _  = let h1 = h0 + 3
-                                         in (h1,[PUT_FLT d])
+    compileBranch ((t,n),eqs) bs =
+      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
+          (bs1,instrs) = compileEquations gr (st+n) (push_is st n is) eqs ((case_instr (length bs1) : instrs) : bs)
+      in bs1
+
+compileBody gr st avs fvs e bs es =
+  let (heap,bs1,instrs) = compileFun gr st avs fvs e 0 bs es
+  in (bs1,(if heap > 0 then (ALLOC heap :) else id) (instrs ++ [RET st]))
+
+compileFun gr st avs fvs (App e1 e2) h0 bs es =
+  compileFun gr st avs fvs e1 h0 bs (e2:es)
+compileFun gr st avs fvs (Q (m,id))  h0 bs es =
+  case lookupAbsDef gr m id of
+    Ok (_,Just _)
+       -> let (h1,bs1,is1,is2,is3) = compileArgs gr st st avs fvs h0 bs (reverse es)
+          in (h1,bs1,is3 ++ is2 ++ [TAIL_CALL (i2i id)])
+    _  -> let h1 = h0 + 2 + length es
+              (h2,bs2,is1,is2,is3) = compileArgs gr st st avs fvs h1 bs es
+          in (h2,bs2,PUT_CONSTR (i2i id) : is1 ++ is3)
+compileFun gr st avs fvs (QC qid)    h0 bs es =
+  compileFun gr st avs fvs (Q qid) h0 bs es
+compileFun gr st avs fvs (Vr x)      h0 bs es =
+  let (h1,bs1,is1,is2,is3)  = compileArgs gr st st avs fvs h0 bs (reverse es)
+      i = case lookup x avs of
+            Just i  -> EVAL_ARG_VAR (st-i-1)
+            Nothing -> case lookup x fvs of
+                         Just i  -> EVAL_FREE_VAR i
+                         Nothing -> error "compileFun: unknown variable"
+  in (h1,bs1,is3 ++ is2 ++ [i])
+compileFun gr st avs fvs (EInt n)    h0 bs _  =
+  let h1 = h0 + 2
+  in (h1,bs,[PUT_INT n])
+compileFun gr st avs fvs (K s)       h0 bs _  =
+  let h1 = h0 + 1 + (length s + 4) `div` 4
+  in (h1,bs,[PUT_STR s])
+compileFun gr st avs fvs (EFloat d)  h0 bs _  =
+  let h1 = h0 + 3
+  in (h1,bs,[PUT_FLT d])
+
+compileArgs gr st st0 avs fvs h0 bs []     =
+  (h0,bs,[],[],[])
+compileArgs gr st st0 avs fvs h0 bs (e:es) =
+  (h2,bs2,i1:is1,i2:is2,is++is3)
+  where 
+    (h1,bs1,i1,i2,is)    = compileArg gr st st0 avs fvs e h0 bs []
+    (h2,bs2,is1,is2,is3) = compileArgs gr st (st0+1) avs fvs h1 bs1 es
+
+compileArg gr st st0 avs fvs (App e1 e2) h0 bs es = compileArg gr st st0 avs fvs e1 h0 bs (e2:es)
+compileArg gr st st0 avs fvs e@(Q(m,id)) h0 bs es =
+  case lookupAbsDef gr m id of
+    Ok (_,Just _)
+       -> if null es
+            then let h1 = h0 + 2
+                 in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_FUN (i2i id)])
+            else let es_fvs = nub (foldr freeVars [] es)
+                     h1 = h0 + 1 + length es_fvs
+                     (bs1,b) = compileBody gr 0 [] (zip es_fvs [0..]) e bs es
+                 in (h1,(ENTER:b):bs1,SET_VALUE h0,PUSH_VALUE h0,PUT_CLOSURE (length bs) : map (fst . compileVar st st0 avs fvs) es_fvs)
+    _  -> let h1 = h0 + 2 + length es
+              (h2,bs2,is1,is2,is3) = compileArgs gr st st avs fvs h1 bs es
+          in (h2,bs2,SET_VALUE h0,PUSH_VALUE h0,PUT_CONSTR (i2i id) : is1 ++ is3)
+compileArg gr st st0 avs fvs (QC qid)    h0 bs es = compileArg gr st st0 avs fvs (Q qid) h0 bs es
+compileArg gr st st0 avs fvs (Vr x)      h0 bs es =
+  let (i1,i2) = compileVar st st0 avs fvs x
+  in (h0,bs,i1,i2,[])
+compileArg gr st st0 avs fvs (EInt n)    h0 bs _  = 
+  let h1 = h0 + 2
+  in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_INT n])
+compileArg gr st st0 avs fvs (K s)       h0 bs _  =
+  let h1 = h0 + 1 + (length s + 4) `div` 4
+  in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_STR s])
+compileArg gr st st0 avs fvs (EFloat d)  h0 bs _  =
+  let h1 = h0 + 3
+  in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_FLT d])
+
+compileVar st st0 avs fvs x =
+  case lookup x avs of
+    Just i  -> (SET_ARG_VAR (st-i-1),PUSH_ARG_VAR (st0-i-1))
+    Nothing -> case lookup x fvs of
+                 Just i  -> (SET_FREE_VAR i,PUSH_FREE_VAR i)
+                 Nothing -> error "compileVar: unknown variable"
 
-compileArg gr st vs (h0,st0) (Vr x) =
-  case lookup x vs of
-    Just i  -> ((h0,st0+1),(SET_VARIABLE (st-i-1),PUSH_VARIABLE (st0-i-1),[]))
-    Nothing -> error "compileFunArg: unknown variable"
-compileArg gr st vs (h0,st0) e =
-  let (h1,is2) = compileBody gr st vs e h0 []
-  in ((h1,st0+1),(SET_VALUE h0,PUSH_VALUE h0,is2))
+freeVars (App e1 e2) vs = (freeVars e1 . freeVars e2) vs
+freeVars (Vr x)      vs = x:vs
+freeVars _           vs = vs
 
 i2i :: Ident -> CId
 i2i = utf8CId . ident2utf8
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index c5a04230b..b8a79af52 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -146,8 +146,8 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
                                                            else (x:scope,(bt,i2i x,ty'))) scope hyps 
 
 mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
-                              ,generateByteCode gr arity eqs
-                              )
+                                 ,generateByteCode gr arity eqs
+                                 )
 mkDef gr arity Nothing    = Nothing
 
 mkArrity (Just a) ty = a
diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs
index 2195ce431..1a3d81a89 100644
--- a/src/compiler/GF/Compile/PGFtoJS.hs
+++ b/src/compiler/GF/Compile/PGFtoJS.hs
@@ -32,7 +32,7 @@ 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],[M.Instr]),Double)) -> JS.Property
+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/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs
index 1fee9c8c5..72b4f1ff8 100644
--- a/src/compiler/GF/Compile/PGFtoPython.hs
+++ b/src/compiler/GF/Compile/PGFtoPython.hs
@@ -39,7 +39,7 @@ pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
       abs = abstract pgf
       cncs = concretes pgf
 
-pyAbsdef :: (Type, Int, Maybe ([Equation], [M.Instr]), Double) -> String
+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