{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}

-- | IR loosely based on Appel book.
module Kempe.IR.Type ( Stmt (..)
                     , Exp (..)
                     , RelBinOp (..)
                     , IntBinOp (..)
                     , BoolBinOp (..)
                     , Label
                     , Temp (..)
                     , WriteSt (..)
                     ) where

import           Control.DeepSeq      (NFData)
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy as BSL
import           Data.Int             (Int64, Int8)
import           Data.Semigroup       ((<>))
import           Data.Text.Encoding   (decodeUtf8)
import           Data.Word            (Word8)
import           GHC.Generics         (Generic)
import           Kempe.AST.Size
import           Prettyprinter        (Doc, Pretty (pretty), braces, brackets, colon, hardline, parens, (<+>))
import           Prettyprinter.Ext

data WriteSt = WriteSt { WriteSt -> [Label]
wlabels :: [Label]
                       , WriteSt -> [Int]
temps   :: [Int]
                       }

type Label = Word

prettyLabel :: Label -> Doc ann
prettyLabel :: Label -> Doc ann
prettyLabel Label
l = Doc ann
"kmp" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Label -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Label
l

data Temp = Temp64 !Int
          | Temp8 !Int
          | DataPointer -- RBP on x86 and x19 on aarch64?
          deriving (Temp -> Temp -> Bool
(Temp -> Temp -> Bool) -> (Temp -> Temp -> Bool) -> Eq Temp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Temp -> Temp -> Bool
$c/= :: Temp -> Temp -> Bool
== :: Temp -> Temp -> Bool
$c== :: Temp -> Temp -> Bool
Eq, (forall x. Temp -> Rep Temp x)
-> (forall x. Rep Temp x -> Temp) -> Generic Temp
forall x. Rep Temp x -> Temp
forall x. Temp -> Rep Temp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Temp x -> Temp
$cfrom :: forall x. Temp -> Rep Temp x
Generic, Temp -> ()
(Temp -> ()) -> NFData Temp
forall a. (a -> ()) -> NFData a
rnf :: Temp -> ()
$crnf :: Temp -> ()
NFData)

instance Pretty Temp where
    pretty :: Temp -> Doc ann
pretty (Temp64 Int
i)  = Doc ann
"t_" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
i
    pretty (Temp8 Int
i)   = Doc ann
"t8_" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
i
    pretty Temp
DataPointer = Doc ann
"datapointer"

instance Pretty Stmt where
    pretty :: Stmt -> Doc ann
pretty (Labeled Label
l)           = Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon
    pretty (Jump Label
l)              = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"j" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l)
    pretty (CCall MonoStackType
ty ByteString
bs)         = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"C" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> Text
decodeUtf8 (ByteString -> ByteString
BSL.toStrict ByteString
bs)) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces (MonoStackType -> Doc ann
forall a. MonoStackType -> Doc a
prettyMonoStackType  MonoStackType
ty))
    pretty (KCall Label
l)             = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"call" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l)
    pretty Stmt
Ret                   = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens Doc ann
"ret"
    pretty (MovTemp Temp
t Exp
e)         = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"movtemp" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Temp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Temp
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
    pretty (MovMem Exp
e Int64
_ Exp
e')       = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"movmem" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e') -- TODO: maybe print size?
    pretty (CJump Exp
e Label
l Label
l')        = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"cjump" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l')
    pretty (WrapKCall ABI
_ MonoStackType
ty ByteString
fn Label
l) = Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"export" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> Text
decodeUtf8 ByteString
fn) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces (MonoStackType -> Doc ann
forall a. MonoStackType -> Doc a
prettyMonoStackType MonoStackType
ty) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l
    pretty (MJump Exp
e Label
l)           = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"mjump" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l)

instance Pretty Exp where
    pretty :: Exp -> Doc ann
pretty (ConstInt Int64
i)           = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"int" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int64
i)
    pretty (ConstInt8 Int8
i)          = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"int8" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int8 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int8
i)
    pretty (ConstWord Label
n)          = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"word" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Label
n)
    pretty (ConstBool Bool
False)      = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens Doc ann
"bool false"
    pretty (ConstBool Bool
True)       = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens Doc ann
"bool true"
    pretty (Reg Temp
t)                = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"reg" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Temp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Temp
t)
    pretty (Mem Int64
sz Exp
e)             = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"mem" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Int64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int64
sz) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
    pretty (ExprIntBinOp IntBinOp
op Exp
e Exp
e') = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (IntBinOp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntBinOp
op Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e')
    pretty (ExprIntRel RelBinOp
op Exp
e Exp
e')   = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (RelBinOp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty RelBinOp
op Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e')
    pretty (ConstTag Word8
b)           = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"tag" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Word8 -> Doc ann
forall a ann. (Integral a, Show a) => a -> Doc ann
prettyHex Word8
b)
    pretty (BoolBinOp BoolBinOp
op Exp
e Exp
e')    = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (BoolBinOp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BoolBinOp
op Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e')
    pretty (IntNegIR Exp
e)           = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"~" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
    pretty (PopcountIR Exp
e)         = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"popcount" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
    pretty (EqByte Exp
e Exp
e')          = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"=b" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e')

data Stmt = Labeled Label
          | Jump Label
          -- conditional jump for ifs
          | CJump Exp Label Label
          | MJump Exp Label
          | CCall MonoStackType BSL.ByteString
          | KCall Label -- KCall is a jump to a Kempe procedure
          | WrapKCall ABI MonoStackType BS.ByteString Label
          | MovTemp Temp Exp -- put e in temp
          | MovMem Exp Int64 Exp -- store e2 at address given by e1
          | Ret
          deriving ((forall x. Stmt -> Rep Stmt x)
-> (forall x. Rep Stmt x -> Stmt) -> Generic Stmt
forall x. Rep Stmt x -> Stmt
forall x. Stmt -> Rep Stmt x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Stmt x -> Stmt
$cfrom :: forall x. Stmt -> Rep Stmt x
Generic, Stmt -> ()
(Stmt -> ()) -> NFData Stmt
forall a. (a -> ()) -> NFData a
rnf :: Stmt -> ()
$crnf :: Stmt -> ()
NFData)

data Exp = ConstInt Int64
         | ConstInt8 Int8
         | ConstTag Word8
         | ConstWord Word
         | ConstBool Bool
         | Reg Temp -- TODO: size?
         | Mem Int64 Exp -- fetch from address
         | ExprIntBinOp IntBinOp Exp Exp
         | ExprIntRel RelBinOp Exp Exp
         | BoolBinOp BoolBinOp Exp Exp
         | IntNegIR Exp
         | PopcountIR Exp
         | EqByte Exp Exp
         deriving (Exp -> Exp -> Bool
(Exp -> Exp -> Bool) -> (Exp -> Exp -> Bool) -> Eq Exp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exp -> Exp -> Bool
$c/= :: Exp -> Exp -> Bool
== :: Exp -> Exp -> Bool
$c== :: Exp -> Exp -> Bool
Eq, (forall x. Exp -> Rep Exp x)
-> (forall x. Rep Exp x -> Exp) -> Generic Exp
forall x. Rep Exp x -> Exp
forall x. Exp -> Rep Exp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Exp x -> Exp
$cfrom :: forall x. Exp -> Rep Exp x
Generic, Exp -> ()
(Exp -> ()) -> NFData Exp
forall a. (a -> ()) -> NFData a
rnf :: Exp -> ()
$crnf :: Exp -> ()
NFData)
           -- TODO: one for data, one for C ABI

data BoolBinOp = BoolAnd
               | BoolOr
               | BoolXor
               deriving (BoolBinOp -> BoolBinOp -> Bool
(BoolBinOp -> BoolBinOp -> Bool)
-> (BoolBinOp -> BoolBinOp -> Bool) -> Eq BoolBinOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BoolBinOp -> BoolBinOp -> Bool
$c/= :: BoolBinOp -> BoolBinOp -> Bool
== :: BoolBinOp -> BoolBinOp -> Bool
$c== :: BoolBinOp -> BoolBinOp -> Bool
Eq, (forall x. BoolBinOp -> Rep BoolBinOp x)
-> (forall x. Rep BoolBinOp x -> BoolBinOp) -> Generic BoolBinOp
forall x. Rep BoolBinOp x -> BoolBinOp
forall x. BoolBinOp -> Rep BoolBinOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BoolBinOp x -> BoolBinOp
$cfrom :: forall x. BoolBinOp -> Rep BoolBinOp x
Generic, BoolBinOp -> ()
(BoolBinOp -> ()) -> NFData BoolBinOp
forall a. (a -> ()) -> NFData a
rnf :: BoolBinOp -> ()
$crnf :: BoolBinOp -> ()
NFData)

instance Pretty BoolBinOp where
    pretty :: BoolBinOp -> Doc ann
pretty BoolBinOp
BoolAnd = Doc ann
"&"
    pretty BoolBinOp
BoolOr  = Doc ann
"||"
    pretty BoolBinOp
BoolXor = Doc ann
"xor"

data RelBinOp = IntEqIR
              | IntNeqIR
              | IntLtIR
              | IntGtIR
              | IntLeqIR
              | IntGeqIR
              deriving (RelBinOp -> RelBinOp -> Bool
(RelBinOp -> RelBinOp -> Bool)
-> (RelBinOp -> RelBinOp -> Bool) -> Eq RelBinOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelBinOp -> RelBinOp -> Bool
$c/= :: RelBinOp -> RelBinOp -> Bool
== :: RelBinOp -> RelBinOp -> Bool
$c== :: RelBinOp -> RelBinOp -> Bool
Eq, (forall x. RelBinOp -> Rep RelBinOp x)
-> (forall x. Rep RelBinOp x -> RelBinOp) -> Generic RelBinOp
forall x. Rep RelBinOp x -> RelBinOp
forall x. RelBinOp -> Rep RelBinOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelBinOp x -> RelBinOp
$cfrom :: forall x. RelBinOp -> Rep RelBinOp x
Generic, RelBinOp -> ()
(RelBinOp -> ()) -> NFData RelBinOp
forall a. (a -> ()) -> NFData a
rnf :: RelBinOp -> ()
$crnf :: RelBinOp -> ()
NFData)

instance Pretty RelBinOp where
    pretty :: RelBinOp -> Doc ann
pretty RelBinOp
IntEqIR  = Doc ann
"="
    pretty RelBinOp
IntNeqIR = Doc ann
"!="
    pretty RelBinOp
IntLtIR  = Doc ann
"<"
    pretty RelBinOp
IntGtIR  = Doc ann
">"
    pretty RelBinOp
IntLeqIR = Doc ann
"<="
    pretty RelBinOp
IntGeqIR = Doc ann
">="

data IntBinOp = IntPlusIR
              | IntTimesIR
              | IntDivIR
              | IntMinusIR
              | IntModIR -- rem?
              | IntXorIR
              | WordShiftRIR -- compiles to shr on x86
              | WordShiftLIR
              -- int/word mod are different, see: https://stackoverflow.com/questions/8231882/how-to-implement-the-mod-operator-in-assembly
              | WordModIR
              | WordDivIR
              deriving (IntBinOp -> IntBinOp -> Bool
(IntBinOp -> IntBinOp -> Bool)
-> (IntBinOp -> IntBinOp -> Bool) -> Eq IntBinOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntBinOp -> IntBinOp -> Bool
$c/= :: IntBinOp -> IntBinOp -> Bool
== :: IntBinOp -> IntBinOp -> Bool
$c== :: IntBinOp -> IntBinOp -> Bool
Eq, (forall x. IntBinOp -> Rep IntBinOp x)
-> (forall x. Rep IntBinOp x -> IntBinOp) -> Generic IntBinOp
forall x. Rep IntBinOp x -> IntBinOp
forall x. IntBinOp -> Rep IntBinOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IntBinOp x -> IntBinOp
$cfrom :: forall x. IntBinOp -> Rep IntBinOp x
Generic, IntBinOp -> ()
(IntBinOp -> ()) -> NFData IntBinOp
forall a. (a -> ()) -> NFData a
rnf :: IntBinOp -> ()
$crnf :: IntBinOp -> ()
NFData)

instance Pretty IntBinOp where
    pretty :: IntBinOp -> Doc ann
pretty IntBinOp
IntPlusIR    = Doc ann
"+"
    pretty IntBinOp
IntTimesIR   = Doc ann
"*"
    pretty IntBinOp
IntDivIR     = Doc ann
"/"
    pretty IntBinOp
IntMinusIR   = Doc ann
"-"
    pretty IntBinOp
IntModIR     = Doc ann
"%"
    pretty IntBinOp
IntXorIR     = Doc ann
"xor"
    pretty IntBinOp
WordShiftRIR = Doc ann
">>"
    pretty IntBinOp
WordShiftLIR = Doc ann
"<<"
    pretty IntBinOp
WordModIR    = Doc ann
"%~"
    pretty IntBinOp
WordDivIR    = Doc ann
"/~"