a more efficient tail call by using the new TUCK instruction

2 files changed, 28 insertions, 21 deletions

diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 87946a7cb..6f63e63c0 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -158,22 +158,26 @@ instance Binary Instr where
   put (PUSH   (ARG_VAR  n)) = putWord8 45 >> put n

   put (PUSH   (FREE_VAR n)) = putWord8 46 >> put n

   put (PUSH   (GLOBAL  id)) = putWord8 47 >> put id

-  put (EVAL (HEAP     n) (RecCall       )) = putWord8 48 >> put n

-  put (EVAL (ARG_VAR  n) (RecCall       )) = putWord8 49 >> put n

-  put (EVAL (FREE_VAR n) (RecCall       )) = putWord8 50 >> put n

-  put (EVAL (GLOBAL  id) (RecCall       )) = putWord8 51 >> put id

-  put (EVAL (HEAP     n) (TailCall a b c)) = putWord8 52 >> put n >> put (a,b,c)

-  put (EVAL (ARG_VAR  n) (TailCall a b c)) = putWord8 53 >> put n >> put (a,b,c)

-  put (EVAL (FREE_VAR n) (TailCall a b c)) = putWord8 54 >> put n >> put (a,b,c)

-  put (EVAL (GLOBAL  id) (TailCall a b c)) = putWord8 55 >> put id >> put (a,b,c)

-  put (EVAL (HEAP     n) (UpdateCall b c)) = putWord8 56 >> put n >> put (b,c)

-  put (EVAL (ARG_VAR  n) (UpdateCall b c)) = putWord8 57 >> put n >> put (b,c)

-  put (EVAL (FREE_VAR n) (UpdateCall b c)) = putWord8 58 >> put n >> put (b,c)

-  put (EVAL (GLOBAL  id) (UpdateCall b c)) = putWord8 59 >> put id >> put (b,c)

-  put (DROP n             ) = putWord8 60  >> put n

-  put (JUMP l             ) = putWord8 64  >> put l

-  put (FAIL               ) = putWord8 68

-  put (ADD                ) = putWord8 72

+  put (TUCK (HEAP     n) i) = putWord8 48 >> put (n,i)

+  put (TUCK (ARG_VAR  n) i) = putWord8 49 >> put (n,i)

+  put (TUCK (FREE_VAR n) i) = putWord8 50 >> put (n,i)

+  put (TUCK (GLOBAL  id) i) = putWord8 51 >> put (id,i)

+  put (EVAL (HEAP     n) RecCall) = putWord8 52 >> put n

+  put (EVAL (ARG_VAR  n) RecCall) = putWord8 53 >> put n

+  put (EVAL (FREE_VAR n) RecCall) = putWord8 54 >> put n

+  put (EVAL (GLOBAL  id) RecCall) = putWord8 55 >> put id

+  put (EVAL (HEAP     n) (TailCall a)) = putWord8 56 >> put n >> put a

+  put (EVAL (ARG_VAR  n) (TailCall a)) = putWord8 57 >> put n >> put a

+  put (EVAL (FREE_VAR n) (TailCall a)) = putWord8 58 >> put n >> put a

+  put (EVAL (GLOBAL  id) (TailCall a)) = putWord8 59 >> put id >> put a

+  put (EVAL (HEAP     n) UpdateCall) = putWord8 60 >> put n

+  put (EVAL (ARG_VAR  n) UpdateCall) = putWord8 61 >> put n

+  put (EVAL (FREE_VAR n) UpdateCall) = putWord8 62 >> put n

+  put (EVAL (GLOBAL  id) UpdateCall) = putWord8 63 >> put id

+  put (DROP n             ) = putWord8 64  >> put n

+  put (JUMP l             ) = putWord8 68  >> put l

+  put (FAIL               ) = putWord8 72

+  put (ADD                ) = putWord8 76

 

 instance Binary Type where

   put (DTyp hypos cat exps) = put (hypos,cat,exps)

diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs
index 6cf7daffd..9ac072378 100644
--- a/src/runtime/haskell/PGF/ByteCode.hs
+++ b/src/runtime/haskell/PGF/ByteCode.hs
@@ -27,6 +27,7 @@ data Instr
   | SET_PAD
   | PUSH_FRAME
   | PUSH IVal
+  | TUCK IVal {-# UNPACK #-} !Int
   | EVAL IVal TailInfo
   | DROP {-# UNPACK #-} !Int
   | JUMP {-# UNPACK #-} !CodeLabel
@@ -38,11 +39,12 @@ data IVal
   | ARG_VAR  {-# UNPACK #-} !Int
   | FREE_VAR {-# UNPACK #-} !Int
   | GLOBAL   CId
+  deriving Eq
 
 data TailInfo
   = RecCall
-  | TailCall   {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int
-  | UpdateCall                     {-# UNPACK #-} !Int {-# UNPACK #-} !Int
+  | TailCall {-# UNPACK #-} !Int
+  | UpdateCall
 
 ppLit (LStr s) = text (show s)
 ppLit (LInt n) = int n
@@ -65,6 +67,7 @@ ppInstr (SET_PAD        ) = text "SET_PAD"
 ppInstr (PUSH_FRAME     ) = text "PUSH_FRAME"
 ppInstr (PUSH          v) = text "PUSH       " <+> ppIVal v
 ppInstr (EVAL       v ti) = text "EVAL       " <+> ppIVal v <+> ppTailInfo ti
+ppInstr (TUCK v n       ) = text "TUCK       " <+> ppIVal v <+> int n
 ppInstr (DROP n         ) = text "DROP       " <+> int n
 ppInstr (JUMP l         ) = text "JUMP       " <+> ppLabel l
 ppInstr (FAIL           ) = text "FAIL"
@@ -75,8 +78,8 @@ ppIVal (ARG_VAR  n) = text "stk" <> parens (int n)
 ppIVal (FREE_VAR n) = text "env" <> parens (int n)
 ppIVal (GLOBAL  id) = ppCId id
 
-ppTailInfo RecCall            = empty
-ppTailInfo (TailCall   a b c) = text "tail"   <> parens (int a <> comma <> int b <> comma <> int c)
-ppTailInfo (UpdateCall   b c) = text "update" <> parens (int b <> comma <> int c)
+ppTailInfo RecCall      = empty
+ppTailInfo (TailCall n) = text "tail" <> parens (int n)
+ppTailInfo UpdateCall   = text "update"
 
 ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s)