From 9b0f354c7cef175c172edae582dcfa48817db7ba Mon Sep 17 00:00:00 2001
From: "kr.angelov" <kr.angelov@gmail.com>
Date: Thu, 30 Oct 2014 13:09:50 +0000
Subject: a more efficient tail call by using the new TUCK instruction

---
 src/runtime/haskell/PGF/Binary.hs   | 36 ++++++++++++++++++++----------------
 src/runtime/haskell/PGF/ByteCode.hs | 13 ++++++++-----
 2 files changed, 28 insertions(+), 21 deletions(-)

(limited to 'src/runtime/haskell')

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)
-- 
cgit v1.2.3