full support for recursive def rules in the C runtime

5 files changed, 74 insertions, 58 deletions

diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index b5c301e3b..2064e9a3b 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -136,24 +136,29 @@ instance Binary Equation where
   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 (PUSH_VALUE    n)= putWord8 13 >> put n

-  put (PUSH_VARIABLE n)= putWord8 14 >> put n

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

-  put (FAIL          ) = putWord8 16

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

+  put (ENTER         ) = putWord8 0

+  put (EVAL_ARG_VAR n) = putWord8 1  >> put n

+  put (EVAL_FREE_VAR n)= putWord8 2  >> put n

+  put (CASE id l     ) = putWord8 3  >> put (id,l)

+  put (CASE_INT n l  ) = putWord8 4  >> put (n,l)

+  put (CASE_STR s l  ) = putWord8 5  >> put (s,l)

+  put (CASE_FLT d l  ) = putWord8 6  >> put (d,l)

+  put (ALLOC        n) = putWord8 7  >> put n

+  put (PUT_CONSTR  id) = putWord8 8  >> put id

+  put (PUT_FUN     id) = putWord8 9  >> put id

+  put (PUT_CLOSURE  l) = putWord8 10  >> put l

+  put (PUT_INT      n) = putWord8 11  >> put n

+  put (PUT_STR      s) = putWord8 12  >> put s

+  put (PUT_FLT      d) = putWord8 13 >> put d

+  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

 

 

 instance Binary Type where

diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs
index bcf21ed9b..2e317d4c0 100644
--- a/src/runtime/haskell/PGF/ByteCode.hs
+++ b/src/runtime/haskell/PGF/ByteCode.hs
@@ -6,46 +6,57 @@ import Text.PrettyPrint
 type CodeLabel = Int
 
 data Instr
-  = EVAL   {-# UNPACK #-} !Int
+  = ENTER
+  | EVAL_ARG_VAR   {-# UNPACK #-} !Int
+  | EVAL_FREE_VAR  {-# 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_FUN CId
   | PUT_CLOSURE   {-# UNPACK #-} !CodeLabel
   | PUT_INT {-# UNPACK #-} !Int
   | PUT_STR String
   | PUT_FLT {-# UNPACK #-} !Double
-  | SET_VALUE {-# UNPACK #-} !Int
-  | SET_VARIABLE    {-# UNPACK #-} !Int
-  | PUSH_VALUE {-# UNPACK #-} !Int
-  | PUSH_VARIABLE    {-# UNPACK #-} !Int
+  | SET_VALUE      {-# UNPACK #-} !Int
+  | SET_ARG_VAR    {-# UNPACK #-} !Int
+  | SET_FREE_VAR   {-# UNPACK #-} !Int
+  | PUSH_VALUE     {-# UNPACK #-} !Int
+  | PUSH_ARG_VAR   {-# UNPACK #-} !Int
+  | PUSH_FREE_VAR  {-# UNPACK #-} !Int
   | TAIL_CALL    CId
+  | UPDATE
   | FAIL
   | RET {-# UNPACK #-} !Int
 
-ppCode :: CodeLabel -> [Instr] -> Doc
-ppCode l []     = empty
-ppCode l (i:is) = ppLabel l <+> ppInstr l i $$ ppCode (l+1) is
+ppCode :: Int -> [[Instr]] -> Doc
+ppCode l []       = empty
+ppCode l (is:iss) = ppLabel l <+> vcat (map ppInstr is) $$ ppCode (l+1) iss
 
-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 (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
+ppInstr (ENTER          ) = text "ENTER"
+ppInstr (EVAL_ARG_VAR  n) = text "EVAL_ARG_VAR " <+> int n
+ppInstr (EVAL_FREE_VAR n) = text "EVAL_FREE_VAR" <+> int n
+ppInstr (CASE id l      ) = text "CASE         " <+> ppCId id <+> ppLabel l
+ppInstr (CASE_INT n l   ) = text "CASE_INT     " <+> int n <+> ppLabel l
+ppInstr (CASE_STR str l ) = text "CASE_STR     " <+> text (show str) <+> ppLabel l
+ppInstr (CASE_FLT d l   ) = text "CASE_FLT     " <+> double d <+> ppLabel l
+ppInstr (ALLOC         n) = text "ALLOC        " <+> int n
+ppInstr (PUT_CONSTR   id) = text "PUT_CONSTR   " <+> ppCId id
+ppInstr (PUT_FUN      id) = text "PUT_FUN      " <+> ppCId id
+ppInstr (PUT_CLOSURE   l) = text "PUT_CLOSURE  " <+> ppLabel l
+ppInstr (PUT_INT n      ) = text "PUT_INT      " <+> int n
+ppInstr (PUT_STR str    ) = text "PUT_STR      " <+> text (show str)
+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 (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 (RET           n) = text "RET          " <+> int n
 
-ppLabel l = text (let s = show l in replicate (4-length s) '0' ++ s)
+ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s)
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index 76dbc616a..e9263cc1c 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -28,11 +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],[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
+  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 {
diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index 0b4ccc554..80a615e67 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -325,8 +325,8 @@ data Value
   | VClosure Env Expr

   | VImplArg Value

 

-type Sig = ( Map.Map CId (Type,Int,Maybe ([Equation],[Instr]),Double) -- 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]

 

diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs
index 1aabce09d..a9985cdeb 100644
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -29,13 +29,13 @@ ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+>
 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 :: 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] $$
+                                  (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 ';'