the code for def rules now uses proper graph update to preserve lazyness

7 files changed, 67 insertions, 12 deletions

diff --git a/src/compiler/GF/Compile/GenerateBC.hs b/src/compiler/GF/Compile/GenerateBC.hs
index bab6cd4f4..0e26994fe 100644
--- a/src/compiler/GF/Compile/GenerateBC.hs
+++ b/src/compiler/GF/Compile/GenerateBC.hs
@@ -64,7 +64,10 @@ compileEquations gr st (i:is) eqs       bs = whilePP eqs Map.empty
 
 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]))
+  in (bs1,((if heap > 0 then (ALLOC heap :) else id) .
+           (instrs ++) .
+           (if st == 0 then (UPDATE :) else id))
+          [RET st])
 
 compileFun gr st avs fvs (App e1 e2) h0 bs es =
   compileFun gr st avs fvs e1 h0 bs (e2:es)
@@ -110,11 +113,14 @@ compileArg gr st st0 avs fvs e@(Q(m,id)) h0 bs es =
     Ok (_,Just _)
        -> if null es
             then let h1 = h0 + 2
-                 in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_FUN (i2i id)])
+                 in (h1,bs,SET_VALUE h0,PUSH_VALUE h0,[PUT_FUN (i2i id),SET_PAD])
             else let es_fvs = nub (foldr freeVars [] es)
-                     h1 = h0 + 1 + length es_fvs
+                     h1 = h0 + 1 + length is
                      (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)
+                     is = if null es_fvs
+                            then [SET_PAD]
+                            else map (fst . compileVar st st0 avs fvs) es_fvs
+                 in (h1,(ENTER:b):bs1,SET_VALUE h0,PUSH_VALUE h0,PUT_CLOSURE (length bs) : is)
     _  -> 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)
diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h
index f2e646a50..d725a052b 100644
--- a/src/runtime/c/pgf/data.h
+++ b/src/runtime/c/pgf/data.h
@@ -121,11 +121,13 @@ typedef enum {
   PGF_INSTR_SET_VALUE,
   PGF_INSTR_SET_ARG_VAR,
   PGF_INSTR_SET_FREE_VAR,
+  PGF_INSTR_SET_PAD,
   PGF_INSTR_PUSH_VALUE,
   PGF_INSTR_PUSH_ARG_VAR,
   PGF_INSTR_PUSH_FREE_VAR,
   PGF_INSTR_TAIL_CALL,
   PGF_INSTR_FAIL,
+  PGF_INSTR_UPDATE,
   PGF_INSTR_RET
 } PgfInstruction;
 
diff --git a/src/runtime/c/pgf/evaluator.c b/src/runtime/c/pgf/evaluator.c
index fca499a98..0e94792d0 100644
--- a/src/runtime/c/pgf/evaluator.c
+++ b/src/runtime/c/pgf/evaluator.c
@@ -40,7 +40,7 @@ typedef struct {
 	PgfLiteral lit;
 } PgfValueLit;
 
-static PgfClosure*
+PgfClosure*
 pgf_evaluate_indirection(PgfEvalState* state, PgfClosure* closure)
 {
 	PgfIndirection* indir = (PgfIndirection*) closure;
diff --git a/src/runtime/c/pgf/evaluator.h b/src/runtime/c/pgf/evaluator.h
index b2cffd167..6a24b72c7 100644
--- a/src/runtime/c/pgf/evaluator.h
+++ b/src/runtime/c/pgf/evaluator.h
@@ -24,6 +24,9 @@ typedef struct {
 } PgfValue;
 
 PgfClosure*
+pgf_evaluate_indirection(PgfEvalState* state, PgfClosure* closure);
+
+PgfClosure*
 pgf_evaluate_value(PgfEvalState* state, PgfClosure* closure);
 
 void
diff --git a/src/runtime/c/pgf/jit.c b/src/runtime/c/pgf/jit.c
index 24e9ee0d8..77ef98399 100644
--- a/src/runtime/c/pgf/jit.c
+++ b/src/runtime/c/pgf/jit.c
@@ -405,6 +405,13 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
 				jit_ldxi_p(JIT_V0, JIT_V1, offsetof(PgfValue, absfun));
 				break;
 			}
+			case PGF_INSTR_EVAL_FREE_VAR: {
+				size_t index = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+				gu_printf(out, err, "EVAL_FREE_VAR %d\n", index);
+#endif
+				break;
+			}
 			case PGF_INSTR_CASE: {
 				PgfCId id  = pgf_read_cid(rdr, rdr->opool);
 				int target = pgf_read_int(rdr);
@@ -572,6 +579,27 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
 				curr_offset++;
 				break;
 			}
+			case PGF_INSTR_SET_FREE_VAR: {
+				size_t index = pgf_read_int(rdr);
+#ifdef PGF_JIT_DEBUG
+				gu_printf(out, err, "SET_FREE_VAR  %d\n", index);
+#endif
+
+				jit_getarg_p(JIT_V0, closure_arg);
+				jit_ldxi_p(JIT_V0, JIT_V0, sizeof(PgfClosure)+index*sizeof(PgfClosure*));
+				jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0);
+				curr_offset++;
+				break;
+			}
+			case PGF_INSTR_SET_PAD: {
+#ifdef PGF_JIT_DEBUG
+				gu_printf(out, err, "SET_PAD\n");
+#endif
+                jit_movi_p(JIT_V0, NULL);
+				jit_stxi_p(curr_offset*sizeof(void*), JIT_V1, JIT_V0);
+				curr_offset++;
+				break;
+			}
 			case PGF_INSTR_PUSH_VALUE: {
 				size_t offset = pgf_read_int(rdr);
 #ifdef PGF_JIT_DEBUG
@@ -649,6 +677,17 @@ pgf_jit_function(PgfReader* rdr, PgfAbstr* abstr,
 				gu_printf(out, err, "FAIL\n");
 #endif
 				break;
+			case PGF_INSTR_UPDATE: {
+#ifdef PGF_JIT_DEBUG
+				gu_printf(out, err, "UPDATE\n");
+#endif
+
+				jit_getarg_p(JIT_V0, closure_arg);
+				jit_movi_p(JIT_V2, pgf_evaluate_indirection);
+				jit_stxi_p(0, JIT_V0, JIT_V2);
+				jit_stxi_p(sizeof(PgfClosure), JIT_V0, JIT_V1);
+				break;
+			}
 			case PGF_INSTR_RET: {
 				size_t count = pgf_read_int(rdr);
 
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 2064e9a3b..64707f386 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -153,12 +153,14 @@ instance Binary Instr where
   put (SET_VALUE    n) = putWord8 14 >> put n

   put (SET_ARG_VAR  n) = putWord8 15 >> put n

   put (SET_FREE_VAR n) = putWord8 16 >> put n

-  put (PUSH_VALUE   n) = putWord8 17 >> put n

-  put (PUSH_ARG_VAR n) = putWord8 18 >> put n

-  put (PUSH_FREE_VAR n)= putWord8 19 >> put n

-  put (TAIL_CALL   id) = putWord8 20 >> put id

-  put (FAIL          ) = putWord8 21

-  put (RET          n) = putWord8 22 >> put n

+  put (SET_PAD       ) = putWord8 17

+  put (PUSH_VALUE   n) = putWord8 18 >> put n

+  put (PUSH_ARG_VAR n) = putWord8 19 >> put n

+  put (PUSH_FREE_VAR n)= putWord8 20 >> put n

+  put (TAIL_CALL   id) = putWord8 21 >> put id

+  put (FAIL          ) = putWord8 22

+  put (UPDATE        ) = putWord8 23

+  put (RET          n) = putWord8 24 >> put n

 

 

 instance Binary Type where

diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs
index 2e317d4c0..158de0358 100644
--- a/src/runtime/haskell/PGF/ByteCode.hs
+++ b/src/runtime/haskell/PGF/ByteCode.hs
@@ -23,12 +23,13 @@ data Instr
   | SET_VALUE      {-# UNPACK #-} !Int
   | SET_ARG_VAR    {-# UNPACK #-} !Int
   | SET_FREE_VAR   {-# UNPACK #-} !Int
+  | SET_PAD
   | PUSH_VALUE     {-# UNPACK #-} !Int
   | PUSH_ARG_VAR   {-# UNPACK #-} !Int
   | PUSH_FREE_VAR  {-# UNPACK #-} !Int
   | TAIL_CALL    CId
-  | UPDATE
   | FAIL
+  | UPDATE
   | RET {-# UNPACK #-} !Int
 
 ppCode :: Int -> [[Instr]] -> Doc
@@ -52,11 +53,13 @@ ppInstr (PUT_FLT d      ) = text "PUT_FLT      " <+> double d
 ppInstr (SET_VALUE     n) = text "SET_VALUE    " <+> int n
 ppInstr (SET_ARG_VAR   n) = text "SET_ARG_VAR  " <+> int n
 ppInstr (SET_FREE_VAR  n) = text "SET_FREE_VAR " <+> int n
+ppInstr (SET_PAD        ) = text "SET_PAD"
 ppInstr (PUSH_VALUE    n) = text "PUSH_VALUE   " <+> int n
 ppInstr (PUSH_ARG_VAR  n) = text "PUSH_ARG_VAR " <+> int n
 ppInstr (PUSH_FREE_VAR n) = text "PUSH_FREE_VAR" <+> int n
 ppInstr (TAIL_CALL    id) = text "TAIL_CALL    " <+> ppCId id
 ppInstr (FAIL           ) = text "FAIL"
+ppInstr (UPDATE         ) = text "UPDATE"
 ppInstr (RET           n) = text "RET          " <+> int n
 
 ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s)