module PGF.ByteCode(Literal(..),
                    CodeLabel, Instr(..), IVal(..), TailInfo(..),
                    ppLit, ppCode, ppInstr
                   ) where
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import PGF.CId
import Text.PrettyPrint

data Literal =
   LStr String                      -- ^ string constant
 | LInt Int                         -- ^ integer constant
 | LFlt Double                      -- ^ floating point constant
 deriving (Literal -> Literal -> Bool
(Literal -> Literal -> Bool)
-> (Literal -> Literal -> Bool) -> Eq Literal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Literal -> Literal -> Bool
$c/= :: Literal -> Literal -> Bool
== :: Literal -> Literal -> Bool
$c== :: Literal -> Literal -> Bool
Eq,Eq Literal
Eq Literal
-> (Literal -> Literal -> Ordering)
-> (Literal -> Literal -> Bool)
-> (Literal -> Literal -> Bool)
-> (Literal -> Literal -> Bool)
-> (Literal -> Literal -> Bool)
-> (Literal -> Literal -> Literal)
-> (Literal -> Literal -> Literal)
-> Ord Literal
Literal -> Literal -> Bool
Literal -> Literal -> Ordering
Literal -> Literal -> Literal
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Literal -> Literal -> Literal
$cmin :: Literal -> Literal -> Literal
max :: Literal -> Literal -> Literal
$cmax :: Literal -> Literal -> Literal
>= :: Literal -> Literal -> Bool
$c>= :: Literal -> Literal -> Bool
> :: Literal -> Literal -> Bool
$c> :: Literal -> Literal -> Bool
<= :: Literal -> Literal -> Bool
$c<= :: Literal -> Literal -> Bool
< :: Literal -> Literal -> Bool
$c< :: Literal -> Literal -> Bool
compare :: Literal -> Literal -> Ordering
$ccompare :: Literal -> Literal -> Ordering
$cp1Ord :: Eq Literal
Ord,Int -> Literal -> ShowS
[Literal] -> ShowS
Literal -> String
(Int -> Literal -> ShowS)
-> (Literal -> String) -> ([Literal] -> ShowS) -> Show Literal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Literal] -> ShowS
$cshowList :: [Literal] -> ShowS
show :: Literal -> String
$cshow :: Literal -> String
showsPrec :: Int -> Literal -> ShowS
$cshowsPrec :: Int -> Literal -> ShowS
Show)

type CodeLabel = Int

data Instr
  = CHECK_ARGS {-# UNPACK #-} !Int
  | CASE CId  {-# UNPACK #-} !CodeLabel
  | CASE_LIT Literal  {-# UNPACK #-} !CodeLabel
  | SAVE {-# UNPACK #-} !Int
  | ALLOC  {-# UNPACK #-} !Int
  | PUT_CONSTR CId
  | PUT_CLOSURE   {-# UNPACK #-} !CodeLabel
  | PUT_LIT Literal
  | SET IVal
  | SET_PAD
  | PUSH_FRAME
  | PUSH IVal
  | TUCK IVal {-# UNPACK #-} !Int
  | EVAL IVal TailInfo
  | DROP {-# UNPACK #-} !Int
  | JUMP {-# UNPACK #-} !CodeLabel
  | FAIL
  | PUSH_ACCUM Literal
  | POP_ACCUM
  | ADD

data IVal
  = HEAP     {-# UNPACK #-} !Int
  | ARG_VAR  {-# UNPACK #-} !Int
  | FREE_VAR {-# UNPACK #-} !Int
  | GLOBAL   CId
  deriving IVal -> IVal -> Bool
(IVal -> IVal -> Bool) -> (IVal -> IVal -> Bool) -> Eq IVal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IVal -> IVal -> Bool
$c/= :: IVal -> IVal -> Bool
== :: IVal -> IVal -> Bool
$c== :: IVal -> IVal -> Bool
Eq

data TailInfo
  = RecCall
  | TailCall {-# UNPACK #-} !Int
  | UpdateCall

ppLit :: Literal -> Doc
ppLit (LStr String
s) = String -> Doc
text (ShowS
forall a. Show a => a -> String
show String
s)
ppLit (LInt Int
n) = Int -> Doc
int Int
n
ppLit (LFlt Double
d) = Double -> Doc
double Double
d

ppCode :: Int -> [[Instr]] -> Doc
ppCode :: Int -> [[Instr]] -> Doc
ppCode Int
l []       = Doc
empty
ppCode Int
l ([Instr]
is:[[Instr]]
iss) = Int -> Doc
forall a. Show a => a -> Doc
ppLabel Int
l Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat ((Instr -> Doc) -> [Instr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Instr -> Doc
ppInstr [Instr]
is) Doc -> Doc -> Doc
$$ Int -> [[Instr]] -> Doc
ppCode (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [[Instr]]
iss

ppInstr :: Instr -> Doc
ppInstr (CHECK_ARGS    Int
n) = String -> Doc
text String
"CHECK_ARGS " Doc -> Doc -> Doc
<+> Int -> Doc
int Int
n
ppInstr (CASE CId
id Int
l      ) = String -> Doc
text String
"CASE       " Doc -> Doc -> Doc
<+> CId -> Doc
ppCId CId
id Doc -> Doc -> Doc
<+> Int -> Doc
forall a. Show a => a -> Doc
ppLabel Int
l
ppInstr (CASE_LIT Literal
lit Int
l ) = String -> Doc
text String
"CASE_LIT   " Doc -> Doc -> Doc
<+> Literal -> Doc
ppLit Literal
lit Doc -> Doc -> Doc
<+> Int -> Doc
forall a. Show a => a -> Doc
ppLabel Int
l
ppInstr (SAVE          Int
n) = String -> Doc
text String
"SAVE       " Doc -> Doc -> Doc
<+> Int -> Doc
int Int
n
ppInstr (ALLOC         Int
n) = String -> Doc
text String
"ALLOC      " Doc -> Doc -> Doc
<+> Int -> Doc
int Int
n
ppInstr (PUT_CONSTR   CId
id) = String -> Doc
text String
"PUT_CONSTR " Doc -> Doc -> Doc
<+> CId -> Doc
ppCId CId
id
ppInstr (PUT_CLOSURE   Int
l) = String -> Doc
text String
"PUT_CLOSURE" Doc -> Doc -> Doc
<+> Int -> Doc
forall a. Show a => a -> Doc
ppLabel Int
l
ppInstr (PUT_LIT Literal
lit    ) = String -> Doc
text String
"PUT_LIT    " Doc -> Doc -> Doc
<+> Literal -> Doc
ppLit Literal
lit
ppInstr (SET           IVal
v) = String -> Doc
text String
"SET        " Doc -> Doc -> Doc
<+> IVal -> Doc
ppIVal IVal
v
ppInstr (Instr
SET_PAD        ) = String -> Doc
text String
"SET_PAD"
ppInstr (Instr
PUSH_FRAME     ) = String -> Doc
text String
"PUSH_FRAME"
ppInstr (PUSH          IVal
v) = String -> Doc
text String
"PUSH       " Doc -> Doc -> Doc
<+> IVal -> Doc
ppIVal IVal
v
ppInstr (EVAL       IVal
v TailInfo
ti) = String -> Doc
text String
"EVAL       " Doc -> Doc -> Doc
<+> IVal -> Doc
ppIVal IVal
v Doc -> Doc -> Doc
<+> TailInfo -> Doc
ppTailInfo TailInfo
ti
ppInstr (TUCK IVal
v Int
n       ) = String -> Doc
text String
"TUCK       " Doc -> Doc -> Doc
<+> IVal -> Doc
ppIVal IVal
v Doc -> Doc -> Doc
<+> Int -> Doc
int Int
n
ppInstr (DROP Int
n         ) = String -> Doc
text String
"DROP       " Doc -> Doc -> Doc
<+> Int -> Doc
int Int
n
ppInstr (JUMP Int
l         ) = String -> Doc
text String
"JUMP       " Doc -> Doc -> Doc
<+> Int -> Doc
forall a. Show a => a -> Doc
ppLabel Int
l
ppInstr (Instr
FAIL           ) = String -> Doc
text String
"FAIL"
ppInstr (PUSH_ACCUM  Literal
lit) = String -> Doc
text String
"PUSH_ACCUM " Doc -> Doc -> Doc
<+> Literal -> Doc
ppLit Literal
lit
ppInstr (Instr
POP_ACCUM      ) = String -> Doc
text String
"POP_ACCUM"
ppInstr (Instr
ADD            ) = String -> Doc
text String
"ADD"

ppIVal :: IVal -> Doc
ppIVal (HEAP     Int
n) = String -> Doc
text String
"hp"  Doc -> Doc -> Doc
<> Doc -> Doc
parens (Int -> Doc
int Int
n)
ppIVal (ARG_VAR  Int
n) = String -> Doc
text String
"stk" Doc -> Doc -> Doc
<> Doc -> Doc
parens (Int -> Doc
int Int
n)
ppIVal (FREE_VAR Int
n) = String -> Doc
text String
"env" Doc -> Doc -> Doc
<> Doc -> Doc
parens (Int -> Doc
int Int
n)
ppIVal (GLOBAL  CId
id) = CId -> Doc
ppCId CId
id

ppTailInfo :: TailInfo -> Doc
ppTailInfo TailInfo
RecCall      = Doc
empty
ppTailInfo (TailCall Int
n) = String -> Doc
text String
"tail" Doc -> Doc -> Doc
<> Doc -> Doc
parens (Int -> Doc
int Int
n)
ppTailInfo TailInfo
UpdateCall   = String -> Doc
text String
"update"

ppLabel :: a -> Doc
ppLabel a
l = String -> Doc
text (let s :: String
s = a -> String
forall a. Show a => a -> String
show a
l in Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
-String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
'0' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s)