a major revision of the bytecode generator and JIT compiler. the effect is that now we can compute with lambda functions and with true tail recursion

1 files changed, 48 insertions, 37 deletions

diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs
index 158de0358..f5fc343b7 100644
--- a/src/runtime/haskell/PGF/ByteCode.hs
+++ b/src/runtime/haskell/PGF/ByteCode.hs
@@ -1,65 +1,76 @@
-module PGF.ByteCode(CodeLabel, Instr(..), ppCode, ppInstr) where
+module PGF.ByteCode(Literal(..),
+                    CodeLabel, Instr(..), IVal(..), TailInfo(..),
+                    ppLit, ppCode, ppInstr
+                   ) where
 
 import PGF.CId
 import Text.PrettyPrint
 
+data Literal =
+   LStr String                      -- ^ string constant
+ | LInt Int                         -- ^ integer constant
+ | LFlt Double                      -- ^ floating point constant
+ deriving (Eq,Ord,Show)
+
 type CodeLabel = Int
 
 data Instr
   = 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
+  | CASE_LIT Literal  {-# 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_ARG_VAR    {-# UNPACK #-} !Int
-  | SET_FREE_VAR   {-# UNPACK #-} !Int
+  | PUT_LIT Literal
+  | SET IVal
   | SET_PAD
-  | PUSH_VALUE     {-# UNPACK #-} !Int
-  | PUSH_ARG_VAR   {-# UNPACK #-} !Int
-  | PUSH_FREE_VAR  {-# UNPACK #-} !Int
-  | TAIL_CALL    CId
+  | PUSH IVal
+  | EVAL IVal TailInfo
+  | CALL CId  TailInfo
   | FAIL
   | UPDATE
   | RET {-# UNPACK #-} !Int
 
+data IVal
+  = HEAP     {-# UNPACK #-} !Int
+  | ARG_VAR  {-# UNPACK #-} !Int
+  | FREE_VAR {-# UNPACK #-} !Int
+
+data TailInfo
+  = RecCall
+  | TailCall {-# UNPACK #-} !Int {-# UNPACK #-} !Int
+
+ppLit (LStr s) = text (show s)
+ppLit (LInt n) = int n
+ppLit (LFlt d) = double d
+
 ppCode :: Int -> [[Instr]] -> Doc
 ppCode l []       = empty
 ppCode l (is:iss) = ppLabel l <+> vcat (map ppInstr is) $$ ppCode (l+1) iss
 
 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 (CASE id l      ) = text "CASE       " <+> ppCId id <+> ppLabel l
+ppInstr (CASE_LIT lit l ) = text "CASE_LIT   " <+> ppLit lit <+> 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_LIT lit    ) = text "PUT_LIT    " <+> ppLit lit
+ppInstr (SET           v) = text "SET        " <+> ppIVal v
 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 (PUSH          v) = text "PUSH       " <+> ppIVal v
+ppInstr (EVAL       v ti) = text "EVAL       " <+> ppIVal v <+> ppTailInfo ti
+ppInstr (CALL       v ti) = text "CALL       " <+> ppCId v  <+> ppTailInfo ti
 ppInstr (FAIL           ) = text "FAIL"
 ppInstr (UPDATE         ) = text "UPDATE"
-ppInstr (RET           n) = text "RET          " <+> int n
+ppInstr (RET           n) = text "RET        " <+> int n
+
+ppIVal (HEAP     n) = text "hp"  <> parens (int n)
+ppIVal (ARG_VAR  n) = text "stk" <> parens (int n)
+ppIVal (FREE_VAR n) = text "env" <> parens (int n)
+
+ppTailInfo RecCall        = empty
+ppTailInfo (TailCall a b) = text "tail" <> parens (int a <> comma <> int b)
 
 ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s)