partial implementation for recursive def rules

src/compiler/GF/Compile/GenerateBC.hs

@@ -1,23 +1,26 @@
 module GF.Compile.GenerateBC(generateByteCode) where
 
 import GF.Grammar
+import GF.Grammar.Lookup(lookupAbsDef)
+import GF.Data.Operations
 import PGF(CId,utf8CId)
 import PGF.Internal(Instr(..))
 import qualified Data.Map as Map
+import Data.List(mapAccumL)
 
-generateByteCode :: Int -> [L Equation] -> [Instr]
+generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [Instr]
-generateByteCode arity eqs =
+generateByteCode gr arity eqs =
-  compileEquations arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs)
+  compileEquations gr arity is (map (\(L _ (ps,t)) -> ([],ps,t)) eqs)
   where
     is = push_is (arity-1) arity []
 
-compileEquations :: Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [Instr]
+compileEquations :: SourceGrammar -> Int -> [Int] -> [([(Ident,Int)],[Patt],Term)] -> [Instr]
-compileEquations st _  []            = [FAIL]
+compileEquations gr st _  []            = [FAIL]
-compileEquations st [] ((vs,[],t):_) =
+compileEquations gr st [] ((vs,[],t):_) =
-  let (heap,instrs) = compileBody st vs t 0 []
+  let (heap,instrs) = compileBody gr 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
+compileEquations gr 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)
@@ -29,13 +32,13 @@ compileEquations 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 st (i:is) eqs
+    whilePV eqs                          cns vrs = mkCase cns (reverse vrs) ++ compileEquations gr st (i:is) eqs
 
     mkCase cns vrs
-      | Map.null cns = compileEquations st is 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 st is vrs
+                       compileEquations gr st is vrs
 
     compileBranch t n eqs =
       let case_instr = 
@@ -44,32 +47,39 @@ compileEquations st (i:is) eqs       = whilePP eqs Map.empty
               (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
+          instrs = compileEquations gr (st+n) (push_is st n is) eqs
       in case_instr (length instrs) : instrs
-        
 
-compileBody st vs (App e1 e2) h0 os =
+compileBody gr st vs (App e1 e2) h0 es = compileBody gr st vs e1 h0 (e2:es)
-  case e2 of
+compileBody gr st vs (Q (m,id))  h0 es = case lookupAbsDef gr m id of
-    Vr x -> case lookup x vs of
+                                           Ok (Just _,Just _) 
-              Just i  -> compileBody st vs e1 h0 (SET_VARIABLE (st-i-1):os)
+                                              -> let ((h1,st1),iis) = mapAccumL (compileArg gr st vs) (h0,st) (reverse es)
-              Nothing -> error "compileBody: unknown variable"
+                                                     (is1,is2,is3) = unzip3 iis
-    e2   -> let (h1,is1) = compileBody st vs e1 h0 (SET_VALUE h1:os)
+                                                 in (h1,concat is3 ++ is2 ++ [TAIL_CALL (i2i id)])
-                (h2,is2) = compileBody st vs e2 h1 []
+                                           _  -> let h1 = h0 + 2 + length es
-            in (h2,is1 ++ is2)
+                                                     ((h2,st1),iis)  = mapAccumL (compileArg gr st vs) (h1,st) es
-compileBody st vs (QC (_,id)) h0 os = let h1 = h0 + 2 + length os
+                                                     (is1,is2,is3) = unzip3 iis
-                                      in (h1,PUT_CONSTR (i2i id) : os)
+                                                 in (h2,PUT_CONSTR (i2i id) : concat (is1:is3))
-compileBody st vs (Q  (_,id)) h0 os = let h1 = h0 + 2 + length os
+compileBody gr st vs (QC qid)    h0 es = compileBody gr st vs (Q qid) h0 es
-                                      in (h1,PUT_CONSTR (i2i id) : os)
+compileBody gr st vs (Vr x)      h0 es = case lookup x vs of
-compileBody st vs (Vr x)      h0 os = case lookup x vs of
+                                           Just i  -> let ((h1,st1),iis)  = mapAccumL (compileArg gr st vs) (h0,st) (reverse es)
-                                        Just i  -> (h0,EVAL (st-i-1) : os)
+                                                          (is1,is2,is3) = unzip3 iis
-                                        Nothing -> error "compileBody: unknown variable"
+                                                      in (h1,concat is3 ++ is2 ++ [EVAL (st-i-1)])
-compileBody st vs (EInt n)    h0 os = let h1 = h0 + 2
+                                           Nothing -> error "compileBody: unknown variable"
-                                      in (h1,PUT_INT n : os)
+compileBody gr st vs (EInt n)    h0 _  = let h1 = h0 + 2
-compileBody st vs (K s)       h0 os = let h1 = h0 + 1 + (length s + 4) `div` 4
+                                         in (h1,[PUT_INT n])
-                                      in (h1,PUT_STR s : os)
+compileBody gr st vs (K s)       h0 _  = let h1 = h0 + 1 + (length s + 4) `div` 4
-compileBody st vs (EFloat d)  h0 os = let h1 = h0 + 3
+                                         in (h1,[PUT_STR s])
-                                      in (h1,PUT_FLT d : os)
+compileBody gr st vs (EFloat d)  h0 _  = let h1 = h0 + 3
-compileBody st vs t           _  _  = error (show t)
+                                         in (h1,[PUT_FLT d])
+
+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))
 
 i2i :: Ident -> CId
 i2i = utf8CId . ident2utf8

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -48,7 +48,7 @@ mkCanon2pgf opts gr am = do
 
         flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
 
-        funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef arity mdef, 0)) | 
+        funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) | 
                                    ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
                                    let arity = mkArrity ma ty]
                                    
@@ -145,10 +145,10 @@ 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 arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
+mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
-                              ,generateByteCode arity eqs
+                              ,generateByteCode gr arity eqs
                               )
-mkDef arity Nothing    = Nothing
+mkDef gr arity Nothing    = Nothing
 
 mkArrity (Just a) ty = a
 mkArrity Nothing  ty = let (ctxt, _, _) = GM.typeForm ty 

src/runtime/c/pgf/data.h

@@ -117,6 +117,8 @@ typedef enum {
   PGF_INSTR_PUT_FLT,
   PGF_INSTR_SET_VALUE,
   PGF_INSTR_SET_VARIABLE,
+  PGF_INSTR_PUSH_VALUE,
+  PGF_INSTR_PUSH_VARIABLE,
   PGF_INSTR_TAIL_CALL,
   PGF_INSTR_FAIL,
   PGF_INSTR_RET

src/runtime/c/pgf/jit.c

@@ -527,11 +527,60 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
 			curr_offset++;
 			break;
 		}
+		case PGF_INSTR_PUSH_VALUE: {
+			size_t offset = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "PUSH_VALUE    %d\n", offset);
+#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_extend);
+			if (offset == 0) {
+				jit_str_p(JIT_RET, JIT_V1);
+			} else {
+				jit_addi_p(JIT_V0, JIT_V1, offset*sizeof(void*));
+				jit_str_p(JIT_RET, JIT_V0);
+			}
+			break;
+		}
+		case PGF_INSTR_PUSH_VARIABLE: {
+			size_t index = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+			gu_printf(out, err, "PUSH_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_extend);
+			jit_ldxi_p(JIT_V0, JIT_RET, -(index+1)*sizeof(PgfClosure*));
+			jit_str_p(JIT_RET, 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
+			
+			jit_getarg_p(JIT_V0, es_arg);
+			jit_getarg_p(JIT_V1, closure_arg);
+			jit_prepare(2);
+			jit_pusharg_p(JIT_V1);
+			jit_pusharg_p(JIT_V0);
+
+			PgfCallPatch patch;
+			patch.cid = id;
+			patch.ref = jit_movi_p(JIT_V0, jit_forward());
+			gu_buf_push(rdr->jit_state->call_patches, PgfCallPatch, patch);			
+			jit_ldxi_p(JIT_V0, JIT_V0, offsetof(PgfAbsFun,function));
+
+			jit_finishr(JIT_V0);
+			jit_retval_p(JIT_V1);
 			break;
 		}
 		case PGF_INSTR_FAIL:

src/runtime/haskell/PGF/Binary.hs

@@ -149,9 +149,11 @@ instance Binary Instr where
   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 (PUSH_VALUE    n)= putWord8 13 >> put n
-  put (FAIL          ) = putWord8 14
+  put (PUSH_VARIABLE n)= putWord8 14 >> put n
-  put (RET          n) = putWord8 15 >> put n
+  put (TAIL_CALL   id) = putWord8 15 >> put id
+  put (FAIL          ) = putWord8 16
+  put (RET          n) = putWord8 17 >> put n
 
 
 instance Binary Type where

src/runtime/haskell/PGF/ByteCode.hs

@@ -19,6 +19,8 @@ data Instr
   | PUT_FLT {-# UNPACK #-} !Double
   | SET_VALUE {-# UNPACK #-} !Int
   | SET_VARIABLE    {-# UNPACK #-} !Int
+  | PUSH_VALUE {-# UNPACK #-} !Int
+  | PUSH_VARIABLE    {-# UNPACK #-} !Int
   | TAIL_CALL    CId
   | FAIL
   | RET {-# UNPACK #-} !Int
@@ -33,13 +35,15 @@ 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_VALUE    n) = text "SET_VALUE   " <+> int n
 ppInstr l (SET_VARIABLE n) = text "SET_VARIABLE" <+> int n
+ppInstr l (PUSH_VALUE   n) = text "PUSH_VALUE  " <+> int n
+ppInstr l (PUSH_VARIABLE n)= text "PUSH_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