module Cmm.Op where
import Data.Binary
import Data.DeriveTH
import Util.Gen
import qualified Text.ParserCombinators.ReadP as P
import Text.Read.Lex
data BinOp
= Add
| Sub
| Mul
| Mulx
| UMulx
| Div
| Mod
| Quot
| Rem
| UDiv
| UMod
| And
| Or
| Xor
| Shl
| Shr
| Shra
| Rotl
| Rotr
| FAdd
| FSub
| FDiv
| FMul
| FPwr
| FAtan2
| Eq
| NEq
| Gt
| Gte
| Lt
| Lte
| UGt
| UGte
| ULt
| ULte
| FEq
| FNEq
| FGt
| FGte
| FLt
| FLte
| FOrdered
deriving(Eq,Show,Ord,Read,Enum,Bounded)
data UnOp
= Neg
| Com
| FAbs
| FNeg
| Sin
| Cos
| Tan
| Sinh
| Cosh
| Tanh
| Asin
| Acos
| Atan
| Log
| Exp
| Sqrt
| Bswap
| Ffs
| Clz
| Ctz
| Popcount
| Parity
deriving(Eq,Show,Ord,Read,Enum,Bounded)
data ConvOp
= F2I
| F2U
| U2F
| I2F
| F2F
| Lobits
| Sx
| Zx
| I2I
| U2U
| B2B
deriving(Eq,Show,Ord,Read,Enum,Bounded)
data ValOp
= NaN
| PInf
| NInf
| PZero
| NZero
deriving(Eq,Show,Ord,Read,Bounded)
data ArchBits = BitsMax | BitsPtr | BitsUnknown
deriving(Eq,Ord)
data TyBits = Bits !Int | BitsArch !ArchBits | BitsExt String
deriving(Eq,Ord)
data TyHint
= HintSigned
| HintUnsigned
| HintFloat
| HintCharacter
| HintNone
deriving(Eq,Ord)
data Ty
= TyBits !TyBits !TyHint
| TyBool
| TyComplex Ty
| TyVector !Int Ty
deriving(Eq,Ord)
preadTy :: P.ReadP Ty
preadTy = P.choice cs where
cs = [ do P.string "bool"; return TyBool
, do P.char 's'; TyBits x _ <- preadTy; return $ TyBits x HintSigned
, do P.char 'u'; TyBits x _ <- preadTy; return $ TyBits x HintUnsigned
, do P.char 'f'; TyBits x _ <- preadTy; return $ TyBits x HintFloat
, do P.char 'c'; TyBits x _ <- preadTy; return $ TyBits x HintCharacter
, do P.string "bits<"; x <- P.manyTill P.get (P.char '>'); return $ TyBits (f x) HintNone
, do P.string "bits"; x <- readDecP; return $ TyBits (Bits x) HintNone
, do n <- readDecP; P.char '*'; t <- preadTy; return (TyVector n t)
, do P.string "i"; t <- preadTy; return (TyComplex t)
]
f "ptr" = BitsArch BitsPtr
f "max" = BitsArch BitsMax
f "?" = BitsArch BitsUnknown
f x = BitsExt x
readTy :: Monad m => String -> m Ty
readTy s = case runReadP preadTy s of
Nothing -> fail "readTy: not type"
Just x -> return x
stringToOpTy :: String -> Ty
stringToOpTy s = case readTy s of
Just t -> t
_ -> error $ "stringToOpTy: " ++ show s
bool = TyBool
bits_ptr = TyBits (BitsArch BitsPtr) HintNone
bits_max = TyBits (BitsArch BitsMax) HintNone
bits8 = TyBits (Bits 8) HintNone
bits16 = TyBits (Bits 16) HintNone
bits32 = TyBits (Bits 32) HintNone
bits64 = TyBits (Bits 64) HintNone
class ToCmmTy a where
toCmmTy :: a -> Maybe Ty
instance ToCmmTy Ty where
toCmmTy a = Just a
instance ToCmmTy String where
toCmmTy s = readTy s
cmmTyBits :: ToCmmTy a => a -> Maybe Int
cmmTyBits x = do TyBits (Bits b) _ <- toCmmTy x; return b
cmmTyHint x = do TyBits _ hint <- toCmmTy x; return hint
instance Show TyHint where
showsPrec _ HintSigned = ('s':)
showsPrec _ HintUnsigned = ('u':)
showsPrec _ HintFloat = ('f':)
showsPrec _ HintCharacter = ('c':)
showsPrec _ HintNone = id
instance Show Ty where
showsPrec _ TyBool = showString "bool"
showsPrec _ (TyBits b h) = shows h . showString "bits" . shows b
showsPrec _ (TyVector n t) = shows n . showChar '*' . shows t
showsPrec _ (TyComplex t) = showChar 'i' . shows t
instance Show TyBits where
showsPrec _ (Bits n) = shows n
showsPrec _ (BitsExt s) = showChar '<' . showString s . showChar '>'
showsPrec _ (BitsArch s) = showChar '<' . shows s . showChar '>'
instance Show ArchBits where
show BitsMax = "max"
show BitsPtr = "ptr"
show BitsUnknown = "?"
data Op v
= BinOp BinOp v v
| UnOp UnOp v
| ValOp ValOp
| ConvOp ConvOp v
deriving(Eq,Show,Ord)
binopType :: BinOp -> Ty -> Ty -> Ty
binopType Mulx (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h
binopType UMulx (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h
binopType Eq _ _ = TyBool
binopType NEq _ _ = TyBool
binopType Gt _ _ = TyBool
binopType Gte _ _ = TyBool
binopType Lt _ _ = TyBool
binopType Lte _ _ = TyBool
binopType UGt _ _ = TyBool
binopType UGte _ _ = TyBool
binopType ULt _ _ = TyBool
binopType ULte _ _ = TyBool
binopType FEq _ _ = TyBool
binopType FNEq _ _ = TyBool
binopType FGt _ _ = TyBool
binopType FGte _ _ = TyBool
binopType FLt _ _ = TyBool
binopType FLte _ _ = TyBool
binopType FOrdered _ _ = TyBool
binopType _ t1 _ = t1
isCommutable :: BinOp -> Bool
isCommutable x = f x where
f Add = True
f Mul = True
f And = True
f Or = True
f Xor = True
f Eq = True
f NEq = True
f FAdd = True
f FMul = True
f FEq = True
f FNEq = True
f FOrdered = True
f _ = False
commuteBinOp :: BinOp -> Maybe BinOp
commuteBinOp x | isCommutable x = return x
commuteBinOp Lt = return Gt
commuteBinOp Gt = return Lt
commuteBinOp Lte = return Gte
commuteBinOp Gte = return Lte
commuteBinOp ULt = return UGt
commuteBinOp UGt = return ULt
commuteBinOp ULte = return UGte
commuteBinOp UGte = return ULte
commuteBinOp FLt = return FGt
commuteBinOp FGt = return FLt
commuteBinOp FLte = return FGte
commuteBinOp FGte = return FLte
commuteBinOp _ = Nothing
isAssociative :: BinOp -> Bool
isAssociative x = f x where
f Add = True
f Mul = True
f And = True
f Or = True
f Xor = True
f _ = False
unopFloat :: Ty -> UnOp -> Maybe String
unopFloat (TyBits b HintFloat) op = g b =<< f op where
g (Bits 64) x = return x
g (Bits 32) x = return $ x ++ "f"
g _ _ = Nothing
f FAbs = return "fabs"
f Sin = return "sin"
f Cos = return "cos"
f Tan = return "tan"
f Sinh = return "sinh"
f Cosh = return "cosh"
f Tanh = return "tanh"
f Asin = return "asin"
f Acos = return "acos"
f Atan = return "atan"
f Sqrt = return "sqrt"
f Log = return "log"
f Exp = return "exp"
f _ = Nothing
unopFloat _ _ = Nothing
binopFunc :: Ty -> Ty -> BinOp -> Maybe String
binopFunc (TyBits b _) _ bop = g b =<< f bop where
g (Bits 64) x = return x
g (Bits 32) x = return $ x ++ "f"
g _ _ = Nothing
f FPwr = Just "pow"
f FAtan2 = Just "atan2"
f _ = Nothing
binopFunc TyBool _ bop = Nothing
binopFunc _ _ _ = error "Op.binopFunc: bad."
binopInfix :: BinOp -> Maybe (String,Int)
binopInfix UDiv = Just ("/",8)
binopInfix Mul = Just ("*",8)
binopInfix UMod = Just ("%",8)
binopInfix Sub = Just ("-",7)
binopInfix Add = Just ("+",7)
binopInfix Shr = Just (">>",6)
binopInfix Shl = Just ("<<",6)
binopInfix And = Just ("&",5)
binopInfix Xor = Just ("^",4)
binopInfix Or = Just ("|",3)
binopInfix UGte = Just (">=",2)
binopInfix UGt = Just (">",2)
binopInfix ULte = Just ("<=",2)
binopInfix ULt = Just ("<",2)
binopInfix Eq = Just ("==",2)
binopInfix NEq = Just ("!=",2)
binopInfix _ = Nothing
class IsOperator o where
isCheap :: o -> Bool
isEagerSafe :: o -> Bool
instance IsOperator BinOp where
isCheap FAtan2 = False
isCheap _ = True
isEagerSafe Div = False
isEagerSafe Mod = False
isEagerSafe Quot = False
isEagerSafe Rem = False
isEagerSafe UDiv = False
isEagerSafe UMod = False
isEagerSafe _ = True
instance IsOperator UnOp where
isCheap _ = True
isEagerSafe _ = True
instance IsOperator ConvOp where
isCheap _ = True
isEagerSafe _ = True
instance IsOperator (Op v) where
isCheap (BinOp o _ _) = isCheap o
isCheap (UnOp o _) = isCheap o
isCheap (ConvOp o _) = isCheap o
isCheap _ = False
isEagerSafe (BinOp o _ _) = isEagerSafe o
isEagerSafe (UnOp o _) = isEagerSafe o
isEagerSafe (ConvOp o _) = isEagerSafe o
isEagerSafe _ = False
$(derive makeBinary ''BinOp)
$(derive makeBinary ''UnOp)
$(derive makeBinary ''ConvOp)
$(derive makeBinary ''ValOp)
$(derive makeBinary ''ArchBits)
$(derive makeBinary ''TyBits)
$(derive makeBinary ''TyHint)
$(derive makeBinary ''Ty)
$(derive makeBinary ''Op)