module Cmm.OpEval(
Expression(..),
convOp,
convNumber,
convCombine,
binOp,
binOp',
unOp
) where
import Data.Maybe
import qualified Data.Map as Map
import Cmm.Number
import Cmm.Op
class Expression t e | e -> t where
toConstant :: e -> Maybe (Number,t)
toExpression :: Number -> t -> e
toBool :: Bool -> e
createBinOp :: BinOp -> Ty -> Ty -> Ty -> e -> e -> t -> e
createUnOp :: UnOp -> Ty -> Ty -> e -> t -> e
fromUnOp :: e -> Maybe (UnOp,Ty,Ty,e,t)
fromBinOp :: e -> Maybe (BinOp,Ty,Ty,Ty,e,e,t)
caseEquals :: e -> (Number,t) -> e -> e -> e
equalsExpression :: e -> e -> Bool
toConstant _ = Nothing
fromBinOp _ = Nothing
fromUnOp _ = Nothing
equalsExpression _ _ = False
TyBool `tyLte` _ = True
TyBits (Bits x) _ `tyLte` TyBits (Bits y) _ = x <= y
_ `tyLte` TyBits (BitsArch BitsMax) _ = True
TyBits (Bits x) _ `tyLte` TyBits (BitsArch BitsPtr) _ = x <= 32
x `tyLte` y = x == y
x `tyEq` y = (x `tyLte` y) && (y `tyLte` x)
convOp :: ConvOp -> Ty -> Ty -> Maybe ConvOp
convOp F2I _ _ = Just F2I
convOp I2F _ _ = Just I2F
convOp F2U _ _ = Just F2U
convOp U2F _ _ = Just U2F
convOp _ t1 t2 | t1 == t2 = Nothing
convOp U2U t1 t2 | t2 `tyLte` t1 = Just Lobits
convOp I2I t1 t2 | t2 `tyLte` t1 = Just Lobits
convOp U2U t1 t2 | t1 `tyLte` t2 = Just Zx
convOp I2I t1 t2 | t1 `tyLte` t2 = Just Sx
convOp n _ _ = Just n
convNumber :: ConvOp -> Ty -> Ty -> Number -> Number
convNumber _ _ _ n = n
convCombine :: Ty -> ConvOp -> Ty -> ConvOp -> Ty -> Maybe ConvOp
convCombine _ c1 _ c2 _ | c1 `elem` [F2I,I2F,U2F,F2U] || c2 `elem` [F2I,I2F,U2F,F2U] = Nothing
convCombine _ c1 t2 c2 t3 | tyEq t2 t3 && c1 == c2 = Just c2
convCombine _ _ _ _ _ = Nothing
binOp :: Expression t e => BinOp -> Ty -> Ty -> Ty -> e -> e -> t -> Maybe e
binOp bop t1 t2 tr e1 e2 str | Just (v1,t1) <- toConstant e1, Just (v2,t2) <- toConstant e2 = f bop v1 v2 where
f Add v1 v2 = return $ toExpression (v1 + v2) str
f Sub v1 v2 = return $ toExpression (v1 v2) str
f Mul v1 v2 = return $ toExpression (v1 * v2) str
f op v1 v2 | v2 /= 0, isJust ans = ans where
ans = case op of
Div -> return $ toExpression (v1 `div` v2) str
Mod -> return $ toExpression (v1 `mod` v2) str
Quot -> return $ toExpression (v1 `quot` v2) str
Rem -> return $ toExpression (v1 `rem` v2) str
UDiv -> return $ toExpression (v1 `div` v2) str
UMod -> return $ toExpression (v1 `mod` v2) str
FDiv -> return $ toExpression (v1 / v2) str
_ -> Nothing
f FMul v1 v2 = return $ toExpression (v1 * v2) str
f FAdd v1 v2 = return $ toExpression (v1 + v2) str
f FSub v1 v2 = return $ toExpression (v1 v2) str
f FPwr v1 v2 = return $ toExpression (realToFrac (realToFrac v1 ** realToFrac v2 :: Double)) str
f op v1 v2 | Just v <- Map.lookup op ops = return $ toBool (v1 `v` v2) where
ops = Map.fromList [(Lt,(<)), (Gt,(>)), (Lte,(<=)), (Gte,(>=)),
(FLt,(<)), (FGt,(>)), (FLte,(<=)), (FGte,(>=)), (Eq,(==)),(NEq,(/=))]
f op v1 v2 | Just v <- Map.lookup op ops, v1 >= 0 && v2 >= 0 = return $ toBool (v1 `v` v2) where
ops = Map.fromList [(ULt,(<)), (UGt,(>)), (ULte,(<=)), (UGte,(>=))]
f _ _ _ = Nothing
binOp bop t1 t2 tr e1 e2 str | Just _ <- toConstant e2, Just bop' <- commuteBinOp bop = Just $ createBinOp bop' t2 t1 tr e2 e1 str
binOp bop t1 t2 tr e1 e2 str = f bop e1 e2 where
zero = toExpression 0 str
one = toExpression 1 str
true = toBool True
false = toBool False
f op e1 e2 | Just (v,_) <- toConstant e2 = ans v where
ans 0 = case op of
Shr -> return e1
Shra -> return e1
Shl -> return e1
Rotl -> return e1
Rotr -> return e1
Sub -> return e1
FSub -> return e1
FPwr -> return one
_ -> Nothing
ans 1 = case op of
Div -> return e1
Mod -> return zero
UDiv -> return e1
UMod -> return zero
Quot -> return e1
Rem -> return zero
FPwr -> return e1
FDiv -> return e1
Mul -> return e1
FMul -> return e1
_ -> Nothing
ans _ = Nothing
f op e1 e2 | Just (v,t1) <- toConstant e1 = eans t1 v where
eans t1 v1 = case op of
Eq -> return $ caseEquals e2 (v1,t1) true false
NEq -> return $ caseEquals e2 (v1,t1) false true
_ -> ans t1 v1
ans t1 0 = case op of
Shr -> return zero
Shra -> return zero
Shl -> return zero
Rotl -> return zero
Rotr -> return zero
And -> return zero
Or -> return e2
Xor -> return e2
Add -> return e2
Mul -> return zero
UGt -> return false
ULte -> return true
FAdd -> return e2
UGte -> return $ caseEquals e2 (0,t1) true false
ULt -> return $ caseEquals e2 (0,t1) false true
_ -> Nothing
ans t1 1 = case op of
Mul -> return e2
FMul -> return e2
UGt -> return $ caseEquals e2 (0,t1) true false
_ -> Nothing
ans _ _ = Nothing
f op e1 e2 | e1 `equalsExpression` e2, isJust ans = ans where
ans = case op of
Eq -> return true
NEq -> return false
Lte -> return true
Gte -> return true
Lt -> return false
Gt -> return false
ULte -> return true
UGte -> return true
ULt -> return false
UGt -> return false
Sub -> return zero
Xor -> return zero
And -> return e1
Or -> return e1
_ -> Nothing
f bop e1 e2 | isAssociative bop, Just (bop',t1',t2',tr',e1',e2',str') <- fromBinOp e1, bop == bop' = Just $
createBinOp bop tr tr tr e1' (createBinOp bop tr tr tr e2' e2 str) str
f bop e1 e2 = Nothing
binOp' :: Expression t e => BinOp -> Ty -> Ty -> Ty -> e -> e -> t -> e
binOp' bop t1 t2 tr e1 e2 str = case binOp bop t1 t2 tr e1 e2 str of
Just e -> e
Nothing -> createBinOp bop t1 t2 tr e1 e2 str
unOp :: Expression t e => UnOp -> Ty -> Ty -> e -> t -> Maybe e
unOp op t1 tr e str | Just (v,t) <- toConstant e = f op v where
f Neg v = return $ toExpression (negate v) str
f FNeg v = return $ toExpression (negate v) str
f FAbs v = return $ toExpression (abs v) str
f Sin v = return $ toExpression (realToFrac $ sin (realToFrac v :: Double)) str
f Cos v = return $ toExpression (realToFrac $ cos (realToFrac v :: Double)) str
f Tan v = return $ toExpression (realToFrac $ tan (realToFrac v :: Double)) str
f Sqrt v = return $ toExpression (realToFrac $ sqrt (realToFrac v :: Double)) str
f _ _ = Nothing
unOp op t1 tr e str = Nothing