module PGF.ByteCode(Literal(..),
CodeLabel, Instr(..), IVal(..), TailInfo(..),
ppLit, ppCode, ppInstr
) where
import Prelude hiding ((<>))
import PGF.CId
import Text.PrettyPrint
data Literal =
LStr String
| LInt Int
| LFlt Double
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)