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

3 files changed, 78 insertions, 73 deletions

diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 64707f386..ae9a7e358 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -136,32 +136,36 @@ instance Binary Equation where
   get = liftM2 Equ get get

 

 instance Binary Instr where

-  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 (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

-

+  put (ENTER              ) = putWord8 0

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

+  put (CASE_LIT (LInt n) l) = putWord8 16  >> put (n,l)

+  put (CASE_LIT (LStr s) l) = putWord8 17  >> put (s,l)

+  put (CASE_LIT (LFlt d) l) = putWord8 18  >> put (d,l)

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

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

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

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

+  put (PUT_LIT   (LInt  n)) = putWord8 56  >> put n

+  put (PUT_LIT   (LStr  s)) = putWord8 57 >> put s

+  put (PUT_LIT   (LFlt  d)) = putWord8 58 >> put d

+  put (SET    (HEAP     n)) = putWord8 64 >> put n

+  put (SET    (ARG_VAR  n)) = putWord8 65 >> put n

+  put (SET    (FREE_VAR n)) = putWord8 66 >> put n

+  put (SET_PAD            ) = putWord8 72

+  put (PUSH   (HEAP     n)) = putWord8 80 >> put n

+  put (PUSH   (ARG_VAR  n)) = putWord8 81 >> put n

+  put (PUSH   (FREE_VAR n)) = putWord8 82 >> put n

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

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

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

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

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

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

+  put (CALL id           RecCall       ) = putWord8 96 >> put id

+  put (CALL id           (TailCall a b)) = putWord8 100 >> put id >> put a >> put b

+  put (FAIL               ) = putWord8 104

+  put (UPDATE             ) = putWord8 112

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

 

 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 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)
diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index 80a615e67..27b0623ea 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -31,12 +31,6 @@ import Control.Monad
 import qualified Text.PrettyPrint as PP

 import qualified Text.ParserCombinators.ReadP as RP

 

-data Literal = 

-   LStr String                      -- ^ string constant

- | LInt Int                         -- ^ integer constant

- | LFlt Double                      -- ^ floating point constant

- deriving (Eq,Ord,Show)

-

 type MetaId = Int

 

 data BindType = 

@@ -274,10 +268,6 @@ pattScope scope (PTilde e)   = scope
 ppBind Explicit x = ppCId x

 ppBind Implicit x = PP.braces (ppCId x)

 

-ppLit (LStr s) = PP.text (show s)

-ppLit (LInt n) = PP.int n

-ppLit (LFlt d) = PP.double d

-

 ppMeta :: MetaId -> PP.Doc

 ppMeta n

   | n == 0    = PP.char '?'