ajhc-0.8.0.1: drift_processed/Cmm/Op.hs
{- Generated by DrIFT (Automatic class derivations for Haskell) -}
{-# LINE 1 "src/Cmm/Op.hs" #-}
{-# OPTIONS -funbox-strict-fields #-}
module Cmm.Op where
import Data.Binary
import Util.Gen
import Text.ParserCombinators.ReadP as P
import Text.Read.Lex
{-
Basic operations. These are chosen to be roughly equivalent to c-- operations,
but can be effectively used to generate C or assembly code as well.
An operation consists of the operation itself, the type of the arguments and
return value, and a hint attached to each argument.
A condition is that the operation must be fully determined by the operation
name and the type of its arguments. this specifically does not include the
hint. For instance, since whether a number is signed or unsigned is in the
hint, so the operation itself must say whether it is signed or unsigned.
Also, distinct algorithms should be given different operations, for instance
floating point and integer comparison are so different that they should be
separate opcodes, even if it could be determined by the type they operate on.
-}
-- these take 2 arguments of the same type, and return one of the same type.
-- an exception are the mulx routines, which may return a type exactly
-- double in size of the original, and the shift and rotate routines, where the
-- second argument may be of any width and is interpreted as an unsigned
-- number.
--
-- the invarient is that the return type is always exactly determined by the
-- argument types
data BinOp
= Add
| Sub
| Mul
| Mulx
| UMulx
| Div -- ^ round to -Infinity
| Mod -- ^ mod rounding to -Infinity
| Quot -- ^ round to 0
| Rem -- ^ rem rounding to 0
| UDiv -- ^ round to zero (unsigned)
| UMod -- ^ unsigned mod
-- bitwise
| And
| Or
| Xor
| Shl
| Shr -- ^ shift right logical
| Shra -- ^ shift right arithmetic
| Rotl
| Rotr
-- floating
| FAdd
| FSub
| FDiv
| FMul
| FPwr
| FAtan2
-- These all compare two things of the same type, and return a boolean.
| Eq
| NEq
| Gt
| Gte
| Lt
| Lte
-- unsigned versions
| UGt
| UGte
| ULt
| ULte
-- floating point comparasons
| FEq
| FNEq
| FGt
| FGte
| FLt
| FLte
-- whether two values can be compared at all.
| FOrdered
deriving(Eq,Show,Ord,Read,Enum,Bounded)
{-! derive: Binary !-}
data UnOp
= Neg -- ^ 2s compliment negation
| Com -- ^ bitwise compliment
-- floating
| FAbs -- ^ floating absolute value
| FNeg -- ^ floating point negation
| Sin
| Cos
| Tan
| Sinh
| Cosh
| Tanh
| Asin
| Acos
| Atan
| Log
| Exp
| Sqrt
-- exotic bit operations
| Bswap -- ^ Switch the order of the bytes in a word
| Ffs -- ^ Returns one plus the index of the least
-- significant 1-bit of x, 0 if x is zero.
| Clz -- ^ number of leading (from MSB) zeros, undefined if zero
| Ctz -- ^ number of trailing (from LSB) zeros, undefined if zero.
| Popcount -- ^ number of bits set to 1 in word
| Parity -- ^ number of bits set to 1 mod 2
deriving(Eq,Show,Ord,Read,Enum,Bounded)
{-! derive: Binary !-}
-- conversion ops
data ConvOp
= F2I -- ^ convert a floating point to an integral value via truncation
| F2U -- ^ convert a floating point to an unsigned integral value via truncation, negative values become zero
| U2F -- ^ convert an unsigned integral value to a floating point number
| I2F -- ^ convert an integral value to a floating point number
| F2F -- ^ convert a float from one precision to another, preserving value as much as possible
| Lobits -- ^ extract the low order bits
| Sx -- ^ sign extend a value (signed)
| Zx -- ^ zero extend a value (unsigned)
| I2I -- ^ perform a 'Lobits' or a 'Sx' depending on the sizes of the arguments
| U2U -- ^ perform a 'Lobits' or a 'Zx' depending on the sizes of the arguments
| B2B -- ^ a nop, useful for coercing hints (bits 2 bits)
deriving(Eq,Show,Ord,Read,Enum,Bounded)
{-! derive: Binary !-}
data ValOp
= NaN
| PInf
| NInf
| PZero
| NZero
deriving(Eq,Show,Ord,Read,Bounded)
{-! derive: Binary !-}
data ArchBits = BitsMax | BitsPtr | BitsUnknown
deriving(Eq,Ord)
{-! derive: Binary !-}
data TyBits = Bits {-# UNPACK #-} !Int | BitsArch !ArchBits | BitsExt String
deriving(Eq,Ord)
{-! derive: Binary !-}
data TyHint
= HintSigned
| HintUnsigned
| HintFloat -- an IEEE floating point value
| HintCharacter -- a unicode character, implies unsigned
| HintNone -- no hint
deriving(Eq,Ord)
{-! derive: Binary !-}
data Ty
= TyBits !TyBits !TyHint
| TyBool
| TyComplex Ty
| TyVector !Int Ty
deriving(Eq,Ord)
{-! derive: Binary !-}
--runReadP :: ReadP a -> String -> Maybe a
--runReadP rp s = case readP_to_S rp s of
-- [(x,"")] -> Just x
-- _ -> Nothing
preadTy :: ReadP Ty
preadTy = choice cs where
cs = [ do string "bool"; return TyBool
, do char 's'; TyBits x _ <- preadTy; return $ TyBits x HintSigned
, do char 'u'; TyBits x _ <- preadTy; return $ TyBits x HintUnsigned
, do char 'f'; TyBits x _ <- preadTy; return $ TyBits x HintFloat
, do char 'c'; TyBits x _ <- preadTy; return $ TyBits x HintCharacter
, do string "bits<"; x <- manyTill P.get (char '>'); return $ TyBits (f x) HintNone
, do string "bits"; x <- readDecP; return $ TyBits (Bits x) HintNone
, do n <- readDecP; char '*'; t <- preadTy; return (TyVector n t)
, do 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)
{-! derive: Binary !-}
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
{-* Generated by DrIFT : Look, but Don't Touch. *-}
instance Data.Binary.Binary BinOp where
put Add = do
Data.Binary.putWord8 0
put Sub = do
Data.Binary.putWord8 1
put Mul = do
Data.Binary.putWord8 2
put Mulx = do
Data.Binary.putWord8 3
put UMulx = do
Data.Binary.putWord8 4
put Div = do
Data.Binary.putWord8 5
put Mod = do
Data.Binary.putWord8 6
put Quot = do
Data.Binary.putWord8 7
put Rem = do
Data.Binary.putWord8 8
put UDiv = do
Data.Binary.putWord8 9
put UMod = do
Data.Binary.putWord8 10
put And = do
Data.Binary.putWord8 11
put Or = do
Data.Binary.putWord8 12
put Xor = do
Data.Binary.putWord8 13
put Shl = do
Data.Binary.putWord8 14
put Shr = do
Data.Binary.putWord8 15
put Shra = do
Data.Binary.putWord8 16
put Rotl = do
Data.Binary.putWord8 17
put Rotr = do
Data.Binary.putWord8 18
put FAdd = do
Data.Binary.putWord8 19
put FSub = do
Data.Binary.putWord8 20
put FDiv = do
Data.Binary.putWord8 21
put FMul = do
Data.Binary.putWord8 22
put FPwr = do
Data.Binary.putWord8 23
put FAtan2 = do
Data.Binary.putWord8 24
put Eq = do
Data.Binary.putWord8 25
put NEq = do
Data.Binary.putWord8 26
put Gt = do
Data.Binary.putWord8 27
put Gte = do
Data.Binary.putWord8 28
put Lt = do
Data.Binary.putWord8 29
put Lte = do
Data.Binary.putWord8 30
put UGt = do
Data.Binary.putWord8 31
put UGte = do
Data.Binary.putWord8 32
put ULt = do
Data.Binary.putWord8 33
put ULte = do
Data.Binary.putWord8 34
put FEq = do
Data.Binary.putWord8 35
put FNEq = do
Data.Binary.putWord8 36
put FGt = do
Data.Binary.putWord8 37
put FGte = do
Data.Binary.putWord8 38
put FLt = do
Data.Binary.putWord8 39
put FLte = do
Data.Binary.putWord8 40
put FOrdered = do
Data.Binary.putWord8 41
get = do
h <- Data.Binary.getWord8
case h of
0 -> do
return Add
1 -> do
return Sub
2 -> do
return Mul
3 -> do
return Mulx
4 -> do
return UMulx
5 -> do
return Div
6 -> do
return Mod
7 -> do
return Quot
8 -> do
return Rem
9 -> do
return UDiv
10 -> do
return UMod
11 -> do
return And
12 -> do
return Or
13 -> do
return Xor
14 -> do
return Shl
15 -> do
return Shr
16 -> do
return Shra
17 -> do
return Rotl
18 -> do
return Rotr
19 -> do
return FAdd
20 -> do
return FSub
21 -> do
return FDiv
22 -> do
return FMul
23 -> do
return FPwr
24 -> do
return FAtan2
25 -> do
return Eq
26 -> do
return NEq
27 -> do
return Gt
28 -> do
return Gte
29 -> do
return Lt
30 -> do
return Lte
31 -> do
return UGt
32 -> do
return UGte
33 -> do
return ULt
34 -> do
return ULte
35 -> do
return FEq
36 -> do
return FNEq
37 -> do
return FGt
38 -> do
return FGte
39 -> do
return FLt
40 -> do
return FLte
41 -> do
return FOrdered
_ -> fail "invalid binary data found"
instance Data.Binary.Binary UnOp where
put Neg = do
Data.Binary.putWord8 0
put Com = do
Data.Binary.putWord8 1
put FAbs = do
Data.Binary.putWord8 2
put FNeg = do
Data.Binary.putWord8 3
put Sin = do
Data.Binary.putWord8 4
put Cos = do
Data.Binary.putWord8 5
put Tan = do
Data.Binary.putWord8 6
put Sinh = do
Data.Binary.putWord8 7
put Cosh = do
Data.Binary.putWord8 8
put Tanh = do
Data.Binary.putWord8 9
put Asin = do
Data.Binary.putWord8 10
put Acos = do
Data.Binary.putWord8 11
put Atan = do
Data.Binary.putWord8 12
put Log = do
Data.Binary.putWord8 13
put Exp = do
Data.Binary.putWord8 14
put Sqrt = do
Data.Binary.putWord8 15
put Bswap = do
Data.Binary.putWord8 16
put Ffs = do
Data.Binary.putWord8 17
put Clz = do
Data.Binary.putWord8 18
put Ctz = do
Data.Binary.putWord8 19
put Popcount = do
Data.Binary.putWord8 20
put Parity = do
Data.Binary.putWord8 21
get = do
h <- Data.Binary.getWord8
case h of
0 -> do
return Neg
1 -> do
return Com
2 -> do
return FAbs
3 -> do
return FNeg
4 -> do
return Sin
5 -> do
return Cos
6 -> do
return Tan
7 -> do
return Sinh
8 -> do
return Cosh
9 -> do
return Tanh
10 -> do
return Asin
11 -> do
return Acos
12 -> do
return Atan
13 -> do
return Log
14 -> do
return Exp
15 -> do
return Sqrt
16 -> do
return Bswap
17 -> do
return Ffs
18 -> do
return Clz
19 -> do
return Ctz
20 -> do
return Popcount
21 -> do
return Parity
_ -> fail "invalid binary data found"
instance Data.Binary.Binary ConvOp where
put F2I = do
Data.Binary.putWord8 0
put F2U = do
Data.Binary.putWord8 1
put U2F = do
Data.Binary.putWord8 2
put I2F = do
Data.Binary.putWord8 3
put F2F = do
Data.Binary.putWord8 4
put Lobits = do
Data.Binary.putWord8 5
put Sx = do
Data.Binary.putWord8 6
put Zx = do
Data.Binary.putWord8 7
put I2I = do
Data.Binary.putWord8 8
put U2U = do
Data.Binary.putWord8 9
put B2B = do
Data.Binary.putWord8 10
get = do
h <- Data.Binary.getWord8
case h of
0 -> do
return F2I
1 -> do
return F2U
2 -> do
return U2F
3 -> do
return I2F
4 -> do
return F2F
5 -> do
return Lobits
6 -> do
return Sx
7 -> do
return Zx
8 -> do
return I2I
9 -> do
return U2U
10 -> do
return B2B
_ -> fail "invalid binary data found"
instance Data.Binary.Binary ValOp where
put NaN = do
Data.Binary.putWord8 0
put PInf = do
Data.Binary.putWord8 1
put NInf = do
Data.Binary.putWord8 2
put PZero = do
Data.Binary.putWord8 3
put NZero = do
Data.Binary.putWord8 4
get = do
h <- Data.Binary.getWord8
case h of
0 -> do
return NaN
1 -> do
return PInf
2 -> do
return NInf
3 -> do
return PZero
4 -> do
return NZero
_ -> fail "invalid binary data found"
instance Data.Binary.Binary ArchBits where
put BitsMax = do
Data.Binary.putWord8 0
put BitsPtr = do
Data.Binary.putWord8 1
put BitsUnknown = do
Data.Binary.putWord8 2
get = do
h <- Data.Binary.getWord8
case h of
0 -> do
return BitsMax
1 -> do
return BitsPtr
2 -> do
return BitsUnknown
_ -> fail "invalid binary data found"
instance Data.Binary.Binary TyBits where
put (Bits aa) = do
Data.Binary.putWord8 0
Data.Binary.put aa
put (BitsArch ab) = do
Data.Binary.putWord8 1
Data.Binary.put ab
put (BitsExt ac) = do
Data.Binary.putWord8 2
Data.Binary.put ac
get = do
h <- Data.Binary.getWord8
case h of
0 -> do
aa <- Data.Binary.get
return (Bits aa)
1 -> do
ab <- Data.Binary.get
return (BitsArch ab)
2 -> do
ac <- Data.Binary.get
return (BitsExt ac)
_ -> fail "invalid binary data found"
instance Data.Binary.Binary TyHint where
put HintSigned = do
Data.Binary.putWord8 0
put HintUnsigned = do
Data.Binary.putWord8 1
put HintFloat = do
Data.Binary.putWord8 2
put HintCharacter = do
Data.Binary.putWord8 3
put HintNone = do
Data.Binary.putWord8 4
get = do
h <- Data.Binary.getWord8
case h of
0 -> do
return HintSigned
1 -> do
return HintUnsigned
2 -> do
return HintFloat
3 -> do
return HintCharacter
4 -> do
return HintNone
_ -> fail "invalid binary data found"
instance Data.Binary.Binary Ty where
put (TyBits aa ab) = do
Data.Binary.putWord8 0
Data.Binary.put aa
Data.Binary.put ab
put TyBool = do
Data.Binary.putWord8 1
put (TyComplex ac) = do
Data.Binary.putWord8 2
Data.Binary.put ac
put (TyVector ad ae) = do
Data.Binary.putWord8 3
Data.Binary.put ad
Data.Binary.put ae
get = do
h <- Data.Binary.getWord8
case h of
0 -> do
aa <- Data.Binary.get
ab <- Data.Binary.get
return (TyBits aa ab)
1 -> do
return TyBool
2 -> do
ac <- Data.Binary.get
return (TyComplex ac)
3 -> do
ad <- Data.Binary.get
ae <- Data.Binary.get
return (TyVector ad ae)
_ -> fail "invalid binary data found"
instance (Data.Binary.Binary v) => Data.Binary.Binary (Op v) where
put (BinOp aa ab ac) = do
Data.Binary.putWord8 0
Data.Binary.put aa
Data.Binary.put ab
Data.Binary.put ac
put (UnOp ad ae) = do
Data.Binary.putWord8 1
Data.Binary.put ad
Data.Binary.put ae
put (ValOp af) = do
Data.Binary.putWord8 2
Data.Binary.put af
put (ConvOp ag ah) = do
Data.Binary.putWord8 3
Data.Binary.put ag
Data.Binary.put ah
get = do
h <- Data.Binary.getWord8
case h of
0 -> do
aa <- Data.Binary.get
ab <- Data.Binary.get
ac <- Data.Binary.get
return (BinOp aa ab ac)
1 -> do
ad <- Data.Binary.get
ae <- Data.Binary.get
return (UnOp ad ae)
2 -> do
af <- Data.Binary.get
return (ValOp af)
3 -> do
ag <- Data.Binary.get
ah <- Data.Binary.get
return (ConvOp ag ah)
_ -> fail "invalid binary data found"
-- Imported from other files :-