module PrelRules
( primOpRules
, builtinRules
, caseRules
)
where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
import GhcPrelude
import MkId ( mkPrimOpId, magicDictId )
import CoreSyn
import MkCore
import Id
import Literal
import CoreOpt ( exprIsLiteral_maybe )
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn
import TysPrim
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon
, isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons
, tyConFamilySize )
import DataCon ( dataConTagZ, dataConTyCon, dataConWorkId )
import CoreUtils ( cheapEqExpr, exprIsHNF, exprType )
import CoreUnfold ( exprIsConApp_maybe )
import Type
import OccName ( occNameFS )
import PrelNames
import Maybes ( orElse )
import Name ( Name, nameOccName )
import Outputable
import FastString
import BasicTypes
import DynFlags
import Platform
import Util
import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..))
import Control.Applicative ( Alternative(..) )
import Control.Monad
import qualified Control.Monad.Fail as MonadFail
import Data.Bits as Bits
import qualified Data.ByteString as BS
import Data.Int
import Data.Ratio
import Data.Word
primOpRules :: Name -> PrimOp -> Maybe CoreRule
primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]
primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
, identityDynFlags zeroi
, numFoldingRules IntAddOp intPrimOps
]
primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 ())
, rightIdentityDynFlags zeroi
, equalArgs >> retLit zeroi
, numFoldingRules IntSubOp intPrimOps
]
primOpRules nm IntAddCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))
, identityCDynFlags zeroi ]
primOpRules nm IntSubCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 ())
, rightIdentityCDynFlags zeroi
, equalArgs >> retLitNoC zeroi ]
primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
, zeroElem zeroi
, identityDynFlags onei
, numFoldingRules IntMulOp intPrimOps
]
primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
, leftZero zeroi
, rightIdentityDynFlags onei
, equalArgs >> retLit onei ]
primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
, leftZero zeroi
, do l <- getLiteral 1
dflags <- getDynFlags
guard (l == onei dflags)
retLit zeroi
, equalArgs >> retLit zeroi
, equalArgs >> retLit zeroi ]
primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))
, idempotent
, zeroElem zeroi ]
primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))
, idempotent
, identityDynFlags zeroi ]
primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)
, identityDynFlags zeroi
, equalArgs >> retLit zeroi ]
primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp
, inversePrimOp NotIOp ]
primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
, inversePrimOp IntNegOp ]
primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL)
, rightIdentityDynFlags zeroi ]
primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR)
, rightIdentityDynFlags zeroi ]
primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical
, rightIdentityDynFlags zeroi ]
primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
, identityDynFlags zerow
, numFoldingRules WordAddOp wordPrimOps
]
primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 ())
, rightIdentityDynFlags zerow
, equalArgs >> retLit zerow
, numFoldingRules WordSubOp wordPrimOps
]
primOpRules nm WordAddCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))
, identityCDynFlags zerow ]
primOpRules nm WordSubCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 ())
, rightIdentityCDynFlags zerow
, equalArgs >> retLitNoC zerow ]
primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
, identityDynFlags onew
, numFoldingRules WordMulOp wordPrimOps
]
primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
, rightIdentityDynFlags onew ]
primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
, leftZero zerow
, do l <- getLiteral 1
dflags <- getDynFlags
guard (l == onew dflags)
retLit zerow
, equalArgs >> retLit zerow ]
primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
, idempotent
, zeroElem zerow ]
primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
, idempotent
, identityDynFlags zerow ]
primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
, identityDynFlags zerow
, equalArgs >> retLit zerow ]
primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp
, inversePrimOp NotOp ]
primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ]
primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ]
primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
, inversePrimOp Int2WordOp ]
primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit
, inversePrimOp Word2IntOp ]
primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit
, subsumedByPrimOp Narrow8IntOp
, Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
, Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ]
primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit
, subsumedByPrimOp Narrow8IntOp
, subsumedByPrimOp Narrow16IntOp
, Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ]
primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
, subsumedByPrimOp Narrow8IntOp
, subsumedByPrimOp Narrow16IntOp
, subsumedByPrimOp Narrow32IntOp
, removeOp32 ]
primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit
, subsumedByPrimOp Narrow8WordOp
, Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
, Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ]
primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit
, subsumedByPrimOp Narrow8WordOp
, subsumedByPrimOp Narrow16WordOp
, Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ]
primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
, subsumedByPrimOp Narrow8WordOp
, subsumedByPrimOp Narrow16WordOp
, subsumedByPrimOp Narrow32WordOp
, removeOp32 ]
primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit
, inversePrimOp ChrOp ]
primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs
guard (litFitsInChar lit)
liftLit int2CharLit
, inversePrimOp OrdOp ]
primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ]
primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ]
primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ]
primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]
primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]
primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ]
primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
, identity zerof ]
primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 ())
, rightIdentity zerof ]
primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
, identity onef
, strengthReduction twof FloatAddOp ]
primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
, rightIdentity onef ]
primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
, inversePrimOp FloatNegOp ]
primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
, identity zerod ]
primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 ())
, rightIdentity zerod ]
primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
, identity oned
, strengthReduction twod DoubleAddOp ]
primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
, rightIdentity oned ]
primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
, inversePrimOp DoubleNegOp ]
primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ]
primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ]
primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ]
primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ]
primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>)
primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=)
primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=)
primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<)
primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==)
primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=)
primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)
primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=)
primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=)
primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)
primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==)
primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=)
primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ]
primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ]
primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ]
primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ]
primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ]
primOpRules _ _ = Nothing
mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
-> [RuleM CoreExpr] -> Maybe CoreRule
mkRelOpRule nm cmp extra
= mkPrimOpRule nm 2 $
binaryCmpLit cmp : equal_rule : extra
where
equal_rule = do { equalArgs
; dflags <- getDynFlags
; return (if cmp True True
then trueValInt dflags
else falseValInt dflags) }
mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
-> Maybe CoreRule
mkFloatingRelOpRule nm cmp
= mkPrimOpRule nm 2 [binaryCmpLit cmp]
zeroi, onei, zerow, onew :: DynFlags -> Literal
zeroi dflags = mkMachInt dflags 0
onei dflags = mkMachInt dflags 1
zerow dflags = mkMachWord dflags 0
onew dflags = mkMachWord dflags 1
zerof, onef, twof, zerod, oned, twod :: Literal
zerof = mkMachFloat 0.0
onef = mkMachFloat 1.0
twof = mkMachFloat 2.0
zerod = mkMachDouble 0.0
oned = mkMachDouble 1.0
twod = mkMachDouble 2.0
cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
-> Literal -> Literal -> Maybe CoreExpr
cmpOp dflags cmp = go
where
done True = Just $ trueValInt dflags
done False = Just $ falseValInt dflags
go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2)
go (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2)
go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _)
| nt1 /= nt2 = Nothing
| otherwise = done (i1 `cmp` i2)
go _ _ = Nothing
negOp :: DynFlags -> Literal -> Maybe CoreExpr
negOp _ (MachFloat 0.0) = Nothing
negOp dflags (MachFloat f) = Just (mkFloatVal dflags (f))
negOp _ (MachDouble 0.0) = Nothing
negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (d))
negOp dflags (LitNumber nt i t)
| litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (i) t))
negOp _ _ = Nothing
complementOp :: DynFlags -> Literal -> Maybe CoreExpr
complementOp dflags (LitNumber nt i t) =
Just (Lit (mkLitNumberWrap dflags nt (complement i) t))
complementOp _ _ = Nothing
intOp2 :: (Integral a, Integral b)
=> (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2 = intOp2' . const
intOp2' :: (Integral a, Integral b)
=> (DynFlags -> a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) =
let o = op dflags
in intResult dflags (fromInteger i1 `o` fromInteger i2)
intOp2' _ _ _ _ = Nothing
intOpC2 :: (Integral a, Integral b)
=> (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do
intCResult dflags (fromInteger i1 `op` fromInteger i2)
intOpC2 _ _ _ _ = Nothing
shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
shiftRightLogical dflags x n
| wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32)
| wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64)
| otherwise = panic "shiftRightLogical: unsupported word size"
retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
retLit l = do dflags <- getDynFlags
return $ Lit $ l dflags
retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr
retLitNoC l = do dflags <- getDynFlags
let lit = l dflags
let ty = literalType lit
return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)]
wordOp2 :: (Integral a, Integral b)
=> (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _)
= wordResult dflags (fromInteger w1 `op` fromInteger w2)
wordOp2 _ _ _ _ = Nothing
wordOpC2 :: (Integral a, Integral b)
=> (a -> b -> Integer)
-> DynFlags -> Literal -> Literal -> Maybe CoreExpr
wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) =
wordCResult dflags (fromInteger w1 `op` fromInteger w2)
wordOpC2 _ _ _ _ = Nothing
shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
shiftRule shift_op
= do { dflags <- getDynFlags
; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs
; case e1 of
_ | shift_len == 0
-> return e1
| shift_len < 0 || wordSizeInBits dflags < shift_len
-> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
("Bad shift length" ++ show shift_len))
Lit (LitNumber nt x t)
-> let op = shift_op dflags
y = x `op` fromInteger shift_len
in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t))
_ -> mzero }
wordSizeInBits :: DynFlags -> Integer
wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3)
floatOp2 :: (Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal
-> Maybe (Expr CoreBndr)
floatOp2 op dflags (MachFloat f1) (MachFloat f2)
= Just (mkFloatVal dflags (f1 `op` f2))
floatOp2 _ _ _ _ = Nothing
doubleOp2 :: (Rational -> Rational -> Rational)
-> DynFlags -> Literal -> Literal
-> Maybe (Expr CoreBndr)
doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
= Just (mkDoubleVal dflags (f1 `op` f2))
doubleOp2 _ _ _ _ = Nothing
litEq :: Bool
-> RuleM CoreExpr
litEq is_eq = msum
[ do [Lit lit, expr] <- getArgs
dflags <- getDynFlags
do_lit_eq dflags lit expr
, do [expr, Lit lit] <- getArgs
dflags <- getDynFlags
do_lit_eq dflags lit expr ]
where
do_lit_eq dflags lit expr = do
guard (not (litIsLifted lit))
return (mkWildCase expr (literalType lit) intPrimTy
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
where
val_if_eq | is_eq = trueValInt dflags
| otherwise = falseValInt dflags
val_if_neq | is_eq = falseValInt dflags
| otherwise = trueValInt dflags
boundsCmp :: Comparison -> RuleM CoreExpr
boundsCmp op = do
dflags <- getDynFlags
[a, b] <- getArgs
liftMaybe $ mkRuleFn dflags op a b
data Comparison = Gt | Ge | Lt | Le
mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags
mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags
mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags
mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags
mkRuleFn _ _ _ _ = Nothing
isMinBound :: DynFlags -> Literal -> Bool
isMinBound _ (MachChar c) = c == minBound
isMinBound dflags (LitNumber nt i _) = case nt of
LitNumInt -> i == tARGET_MIN_INT dflags
LitNumInt64 -> i == toInteger (minBound :: Int64)
LitNumWord -> i == 0
LitNumWord64 -> i == 0
LitNumNatural -> i == 0
LitNumInteger -> False
isMinBound _ _ = False
isMaxBound :: DynFlags -> Literal -> Bool
isMaxBound _ (MachChar c) = c == maxBound
isMaxBound dflags (LitNumber nt i _) = case nt of
LitNumInt -> i == tARGET_MAX_INT dflags
LitNumInt64 -> i == toInteger (maxBound :: Int64)
LitNumWord -> i == tARGET_MAX_WORD dflags
LitNumWord64 -> i == toInteger (maxBound :: Word64)
LitNumNatural -> False
LitNumInteger -> False
isMaxBound _ _ = False
intResult :: DynFlags -> Integer -> Maybe CoreExpr
intResult dflags result = Just (intResult' dflags result)
intResult' :: DynFlags -> Integer -> CoreExpr
intResult' dflags result = Lit (mkMachIntWrap dflags result)
intCResult :: DynFlags -> Integer -> Maybe CoreExpr
intCResult dflags result = Just (mkPair [Lit lit, Lit c])
where
mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]
(lit, b) = mkMachIntWrapC dflags result
c = if b then onei dflags else zeroi dflags
wordResult :: DynFlags -> Integer -> Maybe CoreExpr
wordResult dflags result = Just (wordResult' dflags result)
wordResult' :: DynFlags -> Integer -> CoreExpr
wordResult' dflags result = Lit (mkMachWordWrap dflags result)
wordCResult :: DynFlags -> Integer -> Maybe CoreExpr
wordCResult dflags result = Just (mkPair [Lit lit, Lit c])
where
mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]
(lit, b) = mkMachWordWrapC dflags result
c = if b then onei dflags else zeroi dflags
inversePrimOp :: PrimOp -> RuleM CoreExpr
inversePrimOp primop = do
[Var primop_id `App` e] <- getArgs
matchPrimOpId primop primop_id
return e
subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
this `subsumesPrimOp` that = do
[Var primop_id `App` e] <- getArgs
matchPrimOpId that primop_id
return (Var (mkPrimOpId this) `App` e)
subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
subsumedByPrimOp primop = do
[e@(Var primop_id `App` _)] <- getArgs
matchPrimOpId primop primop_id
return e
idempotent :: RuleM CoreExpr
idempotent = do [e1, e2] <- getArgs
guard $ cheapEqExpr e1 e2
return e1
mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
mkBasicRule op_name n_args rm
= BuiltinRule { ru_name = occNameFS (nameOccName op_name),
ru_fn = op_name,
ru_nargs = n_args,
ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
newtype RuleM r = RuleM
{ runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
instance Functor RuleM where
fmap = liftM
instance Applicative RuleM where
pure x = RuleM $ \_ _ _ -> Just x
(<*>) = ap
instance Monad RuleM where
RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
Nothing -> Nothing
Just r -> runRuleM (g r) dflags iu e
fail = MonadFail.fail
instance MonadFail.MonadFail RuleM where
fail _ = mzero
instance Alternative RuleM where
empty = RuleM $ \_ _ _ -> Nothing
RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args ->
f1 dflags iu args <|> f2 dflags iu args
instance MonadPlus RuleM
instance HasDynFlags RuleM where
getDynFlags = RuleM $ \dflags _ _ -> Just dflags
liftMaybe :: Maybe a -> RuleM a
liftMaybe Nothing = mzero
liftMaybe (Just x) = return x
liftLit :: (Literal -> Literal) -> RuleM CoreExpr
liftLit f = liftLitDynFlags (const f)
liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
liftLitDynFlags f = do
dflags <- getDynFlags
[Lit lit] <- getArgs
return $ Lit (f dflags lit)
removeOp32 :: RuleM CoreExpr
removeOp32 = do
dflags <- getDynFlags
if wordSizeInBits dflags == 32
then do
[e] <- getArgs
return e
else mzero
getArgs :: RuleM [CoreExpr]
getArgs = RuleM $ \_ _ args -> Just args
getInScopeEnv :: RuleM InScopeEnv
getInScopeEnv = RuleM $ \_ iu _ -> Just iu
getLiteral :: Int -> RuleM Literal
getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of
(Lit l:_) -> Just l
_ -> Nothing
unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
unaryLit op = do
dflags <- getDynFlags
[Lit l] <- getArgs
liftMaybe $ op dflags (convFloating dflags l)
binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
binaryLit op = do
dflags <- getDynFlags
[Lit l1, Lit l2] <- getArgs
liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
binaryCmpLit op = do
dflags <- getDynFlags
binaryLit (\_ -> cmpOp dflags op)
leftIdentity :: Literal -> RuleM CoreExpr
leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
rightIdentity :: Literal -> RuleM CoreExpr
rightIdentity id_lit = rightIdentityDynFlags (const id_lit)
identity :: Literal -> RuleM CoreExpr
identity lit = leftIdentity lit `mplus` rightIdentity lit
leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityDynFlags id_lit = do
dflags <- getDynFlags
[Lit l1, e2] <- getArgs
guard $ l1 == id_lit dflags
return e2
leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
leftIdentityCDynFlags id_lit = do
dflags <- getDynFlags
[Lit l1, e2] <- getArgs
guard $ l1 == id_lit dflags
let no_c = Lit (zeroi dflags)
return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])
rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityDynFlags id_lit = do
dflags <- getDynFlags
[e1, Lit l2] <- getArgs
guard $ l2 == id_lit dflags
return e1
rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
rightIdentityCDynFlags id_lit = do
dflags <- getDynFlags
[e1, Lit l2] <- getArgs
guard $ l2 == id_lit dflags
let no_c = Lit (zeroi dflags)
return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])
identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
identityDynFlags lit =
leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
identityCDynFlags lit =
leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit
leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
leftZero zero = do
dflags <- getDynFlags
[Lit l1, _] <- getArgs
guard $ l1 == zero dflags
return $ Lit l1
rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
rightZero zero = do
dflags <- getDynFlags
[_, Lit l2] <- getArgs
guard $ l2 == zero dflags
return $ Lit l2
zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
zeroElem lit = leftZero lit `mplus` rightZero lit
equalArgs :: RuleM ()
equalArgs = do
[e1, e2] <- getArgs
guard $ e1 `cheapEqExpr` e2
nonZeroLit :: Int -> RuleM ()
nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
convFloating :: DynFlags -> Literal -> Literal
convFloating dflags (MachFloat f) | not (gopt Opt_ExcessPrecision dflags) =
MachFloat (toRational (fromRational f :: Float ))
convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =
MachDouble (toRational (fromRational d :: Double))
convFloating _ l = l
guardFloatDiv :: RuleM ()
guardFloatDiv = do
[Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
guard $ (f1 /=0 || f2 > 0)
&& f2 /= 0
guardDoubleDiv :: RuleM ()
guardDoubleDiv = do
[Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
guard $ (d1 /=0 || d2 > 0)
&& d2 /= 0
strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
strengthReduction two_lit add_op = do
arg <- msum [ do [arg, Lit mult_lit] <- getArgs
guard (mult_lit == two_lit)
return arg
, do [Lit mult_lit, arg] <- getArgs
guard (mult_lit == two_lit)
return arg ]
return $ Var (mkPrimOpId add_op) `App` arg `App` arg
trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
trueValInt dflags = Lit $ onei dflags
falseValInt dflags = Lit $ zeroi dflags
trueValBool, falseValBool :: Expr CoreBndr
trueValBool = Var trueDataConId
falseValBool = Var falseDataConId
ltVal, eqVal, gtVal :: Expr CoreBndr
ltVal = Var ltDataConId
eqVal = Var eqDataConId
gtVal = Var gtDataConId
mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
mkIntVal dflags i = Lit (mkMachInt dflags i)
mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f))
mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d))
matchPrimOpId :: PrimOp -> Id -> RuleM ()
matchPrimOpId op id = do
op' <- liftMaybe $ isPrimOpId_maybe id
guard $ op == op'
tagToEnumRule :: RuleM CoreExpr
tagToEnumRule = do
[Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs
case splitTyConApp_maybe ty of
Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
let tag = fromInteger i
correct_tag dc = (dataConTagZ dc) == tag
(dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
ASSERT(null rest) return ()
return $ mkTyApps (Var (dataConWorkId dc)) tc_args
_ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )
return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
dataToTagRule :: RuleM CoreExpr
dataToTagRule = a `mplus` b
where
a = do
[Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
guard $ tag_to_enum `hasKey` tagToEnumKey
guard $ ty1 `eqType` ty2
return tag
b = do
dflags <- getDynFlags
[_, val_arg] <- getArgs
in_scope <- getInScopeEnv
(dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
return $ mkIntVal dflags (toInteger (dataConTagZ dc))
seqRule :: RuleM CoreExpr
seqRule = do
[Type ty_a, Type _ty_s, a, s] <- getArgs
guard $ exprIsHNF a
return $ mkCoreUbxTup [exprType s, ty_a] [s, a]
sparkRule :: RuleM CoreExpr
sparkRule = seqRule
builtinRules :: [CoreRule]
builtinRules
= [BuiltinRule { ru_name = fsLit "AppendLitString",
ru_fn = unpackCStringFoldrName,
ru_nargs = 4, ru_try = match_append_lit },
BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
ru_nargs = 2, ru_try = match_eq_string },
BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },
mkBasicRule divIntName 2 $ msum
[ nonZeroLit 1 >> binaryLit (intOp2 div)
, leftZero zeroi
, do
[arg, Lit (LitNumber LitNumInt d _)] <- getArgs
Just n <- return $ exactLog2 d
dflags <- getDynFlags
return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n
],
mkBasicRule modIntName 2 $ msum
[ nonZeroLit 1 >> binaryLit (intOp2 mod)
, leftZero zeroi
, do
[arg, Lit (LitNumber LitNumInt d _)] <- getArgs
Just _ <- return $ exactLog2 d
dflags <- getDynFlags
return $ Var (mkPrimOpId AndIOp)
`App` arg `App` mkIntVal dflags (d 1)
]
]
++ builtinIntegerRules
++ builtinNaturalRules
builtinIntegerRules :: [CoreRule]
builtinIntegerRules =
[rule_IntToInteger "smallInteger" smallIntegerName,
rule_WordToInteger "wordToInteger" wordToIntegerName,
rule_Int64ToInteger "int64ToInteger" int64ToIntegerName,
rule_Word64ToInteger "word64ToInteger" word64ToIntegerName,
rule_convert "integerToWord" integerToWordName mkWordLitWord,
rule_convert "integerToInt" integerToIntName mkIntLitInt,
rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64),
rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64),
rule_binop "plusInteger" plusIntegerName (+),
rule_binop "minusInteger" minusIntegerName (),
rule_binop "timesInteger" timesIntegerName (*),
rule_unop "negateInteger" negateIntegerName negate,
rule_binop_Prim "eqInteger#" eqIntegerPrimName (==),
rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=),
rule_unop "absInteger" absIntegerName abs,
rule_unop "signumInteger" signumIntegerName signum,
rule_binop_Prim "leInteger#" leIntegerPrimName (<=),
rule_binop_Prim "gtInteger#" gtIntegerPrimName (>),
rule_binop_Prim "ltInteger#" ltIntegerPrimName (<),
rule_binop_Prim "geInteger#" geIntegerPrimName (>=),
rule_binop_Ordering "compareInteger" compareIntegerName compare,
rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat),
rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName,
rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble),
rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr,
rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr,
rule_binop "gcdInteger" gcdIntegerName gcd,
rule_binop "lcmInteger" lcmIntegerName lcm,
rule_binop "andInteger" andIntegerName (.&.),
rule_binop "orInteger" orIntegerName (.|.),
rule_binop "xorInteger" xorIntegerName xor,
rule_unop "complementInteger" complementIntegerName complement,
rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL,
rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR,
rule_bitInteger "bitInteger" bitIntegerName,
rule_divop_one "quotInteger" quotIntegerName quot,
rule_divop_one "remInteger" remIntegerName rem,
rule_divop_one "divInteger" divIntegerName div,
rule_divop_one "modInteger" modIntegerName mod,
rule_divop_both "divModInteger" divModIntegerName divMod,
rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName,
rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName,
rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName,
rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp,
rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp,
rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
]
where rule_convert str name convert
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_Integer_convert convert }
rule_IntToInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_IntToInteger }
rule_WordToInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_WordToInteger }
rule_Int64ToInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_Int64ToInteger }
rule_Word64ToInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_Word64ToInteger }
rule_unop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_Integer_unop op }
rule_bitInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_bitInteger }
rule_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop op }
rule_divop_both str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_divop_both op }
rule_divop_one str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_divop_one op }
rule_Int_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_Int_binop op }
rule_binop_Prim str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop_Prim op }
rule_binop_Ordering str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_binop_Ordering op }
rule_encodeFloat str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Integer_Int_encodeFloat op }
rule_decodeDouble str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_decodeDouble }
rule_XToIntegerToX str name toIntegerName
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_XToIntegerToX toIntegerName }
rule_smallIntegerTo str name primOp
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_smallIntegerTo primOp }
rule_rationalTo str name mkLit
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_rationalTo mkLit }
builtinNaturalRules :: [CoreRule]
builtinNaturalRules =
[rule_binop "plusNatural" plusNaturalName (+)
,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a b) else Nothing)
,rule_binop "timesNatural" timesNaturalName (*)
,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName
,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName
,rule_WordToNatural "wordToNatural" wordToNaturalName
]
where rule_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Natural_binop op }
rule_partial_binop str name op
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
ru_try = match_Natural_partial_binop op }
rule_NaturalToInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_NaturalToInteger }
rule_NaturalFromInteger str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_NaturalFromInteger }
rule_WordToNatural str name
= BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
ru_try = match_WordToNatural }
match_append_lit :: RuleFun
match_append_lit _ id_unf _
[ Type ty1
, lit1
, c1
, Var unpk `App` Type ty2
`App` lit2
`App` c2
`App` n
]
| unpk `hasKey` unpackCStringFoldrIdKey &&
c1 `cheapEqExpr` c2
, Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
, Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
= ASSERT( ty1 `eqType` ty2 )
Just (Var unpk `App` Type ty1
`App` Lit (MachStr (s1 `BS.append` s2))
`App` c1
`App` n)
match_append_lit _ _ _ _ = Nothing
match_eq_string :: RuleFun
match_eq_string _ id_unf _
[Var unpk1 `App` lit1, Var unpk2 `App` lit2]
| unpk1 `hasKey` unpackCStringIdKey
, unpk2 `hasKey` unpackCStringIdKey
, Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
, Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
= Just (if s1 == s2 then trueValBool else falseValBool)
match_eq_string _ _ _ _ = Nothing
match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_inline (Type _ : e : _)
| (Var f, args1) <- collectArgs e,
Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
= Just (mkApps unf args1)
match_inline _ = Nothing
match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
| Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap
, Just (dictTy, _) <- splitFunTy_maybe fieldTy
, Just dictTc <- tyConAppTyCon_maybe dictTy
, Just (_,_,co) <- unwrapNewTyCon_maybe dictTc
= Just
$ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))
`App` y
match_magicDict _ = Nothing
match_IntToInteger :: RuleFun
match_IntToInteger = match_IntToInteger_unop id
match_WordToInteger :: RuleFun
match_WordToInteger _ id_unf id [xl]
| Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, integerTy) ->
Just (Lit (mkLitInteger x integerTy))
_ ->
panic "match_WordToInteger: Id has the wrong type"
match_WordToInteger _ _ _ _ = Nothing
match_Int64ToInteger :: RuleFun
match_Int64ToInteger _ id_unf id [xl]
| Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, integerTy) ->
Just (Lit (mkLitInteger x integerTy))
_ ->
panic "match_Int64ToInteger: Id has the wrong type"
match_Int64ToInteger _ _ _ _ = Nothing
match_Word64ToInteger :: RuleFun
match_Word64ToInteger _ id_unf id [xl]
| Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, integerTy) ->
Just (Lit (mkLitInteger x integerTy))
_ ->
panic "match_Word64ToInteger: Id has the wrong type"
match_Word64ToInteger _ _ _ _ = Nothing
match_NaturalToInteger :: RuleFun
match_NaturalToInteger _ id_unf id [xl]
| Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, naturalTy) ->
Just (Lit (LitNumber LitNumInteger x naturalTy))
_ ->
panic "match_NaturalToInteger: Id has the wrong type"
match_NaturalToInteger _ _ _ _ = Nothing
match_NaturalFromInteger :: RuleFun
match_NaturalFromInteger _ id_unf id [xl]
| Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
, x >= 0
= case splitFunTy_maybe (idType id) of
Just (_, naturalTy) ->
Just (Lit (LitNumber LitNumNatural x naturalTy))
_ ->
panic "match_NaturalFromInteger: Id has the wrong type"
match_NaturalFromInteger _ _ _ _ = Nothing
match_WordToNatural :: RuleFun
match_WordToNatural _ id_unf id [xl]
| Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType id) of
Just (_, naturalTy) ->
Just (Lit (LitNumber LitNumNatural x naturalTy))
_ ->
panic "match_WordToNatural: Id has the wrong type"
match_WordToNatural _ _ _ _ = Nothing
match_bitInteger :: RuleFun
match_bitInteger dflags id_unf fn [arg]
| Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg
, x >= 0
, x <= (wordSizeInBits dflags 1)
, let x_int = fromIntegral x :: Int
= case splitFunTy_maybe (idType fn) of
Just (_, integerTy)
-> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy))
_ -> panic "match_IntToInteger_unop: Id has the wrong type"
match_bitInteger _ _ _ _ = Nothing
match_Integer_convert :: Num a
=> (DynFlags -> a -> Expr CoreBndr)
-> RuleFun
match_Integer_convert convert dflags id_unf _ [xl]
| Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
= Just (convert dflags (fromInteger x))
match_Integer_convert _ _ _ _ _ = Nothing
match_Integer_unop :: (Integer -> Integer) -> RuleFun
match_Integer_unop unop _ id_unf _ [xl]
| Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
= Just (Lit (LitNumber LitNumInteger (unop x) i))
match_Integer_unop _ _ _ _ _ = Nothing
match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
match_IntToInteger_unop unop _ id_unf fn [xl]
| Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType fn) of
Just (_, integerTy) ->
Just (Lit (LitNumber LitNumInteger (unop x) integerTy))
_ ->
panic "match_IntToInteger_unop: Id has the wrong type"
match_IntToInteger_unop _ _ _ _ _ = Nothing
match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_binop binop _ id_unf _ [xl,yl]
| Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just (Lit (mkLitInteger (x `binop` y) i))
match_Integer_binop _ _ _ _ _ = Nothing
match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
match_Natural_binop binop _ id_unf _ [xl,yl]
| Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
= Just (Lit (mkLitNatural (x `binop` y) i))
match_Natural_binop _ _ _ _ _ = Nothing
match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun
match_Natural_partial_binop binop _ id_unf _ [xl,yl]
| Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
, Just z <- x `binop` y
= Just (Lit (mkLitNatural z i))
match_Natural_partial_binop _ _ _ _ _ = Nothing
match_Integer_divop_both
:: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
match_Integer_divop_both divop _ id_unf _ [xl,yl]
| Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
, (r,s) <- x `divop` y
= Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)]
match_Integer_divop_both _ _ _ _ _ = Nothing
match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
match_Integer_divop_one divop _ id_unf _ [xl,yl]
| Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
= Just (Lit (mkLitInteger (x `divop` y) i))
match_Integer_divop_one _ _ _ _ _ = Nothing
match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
match_Integer_Int_binop binop _ id_unf _ [xl,yl]
| Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
= Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))
match_Integer_Int_binop _ _ _ _ _ = Nothing
match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
| Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
match_Integer_binop_Prim _ _ _ _ _ = Nothing
match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
| Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
= Just $ case x `binop` y of
LT -> ltVal
EQ -> eqVal
GT -> gtVal
match_Integer_binop_Ordering _ _ _ _ _ = Nothing
match_Integer_Int_encodeFloat :: RealFloat a
=> (a -> Expr CoreBndr)
-> RuleFun
match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
| Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
= Just (mkLit $ encodeFloat x (fromInteger y))
match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
match_rationalTo :: RealFloat a
=> (a -> Expr CoreBndr)
-> RuleFun
match_rationalTo mkLit _ id_unf _ [xl, yl]
| Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
, Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
= Just (mkLit (fromRational (x % y)))
match_rationalTo _ _ _ _ _ = Nothing
match_decodeDouble :: RuleFun
match_decodeDouble dflags id_unf fn [xl]
| Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
= case splitFunTy_maybe (idType fn) of
Just (_, res)
| Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res
-> case decodeFloat (fromRational x :: Double) of
(y, z) ->
Just $ mkCoreUbxTup [integerTy, intHashTy]
[Lit (mkLitInteger y integerTy),
Lit (mkMachInt dflags (toInteger z))]
_ ->
pprPanic "match_decodeDouble: Id has the wrong type"
(ppr fn <+> dcolon <+> ppr (idType fn))
match_decodeDouble _ _ _ _ = Nothing
match_XToIntegerToX :: Name -> RuleFun
match_XToIntegerToX n _ _ _ [App (Var x) y]
| idName x == n
= Just y
match_XToIntegerToX _ _ _ _ _ = Nothing
match_smallIntegerTo :: PrimOp -> RuleFun
match_smallIntegerTo primOp _ _ _ [App (Var x) y]
| idName x == smallIntegerName
= Just $ App (Var (mkPrimOpId primOp)) y
match_smallIntegerTo _ _ _ _ _ = Nothing
numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
numFoldingRules op dict = do
[e1,e2] <- getArgs
dflags <- getDynFlags
let PrimOps{..} = dict dflags
if not (gopt Opt_NumConstantFolding dflags)
then mzero
else case BinOpApp e1 op e2 of
x :++: (y :++: v) -> return $ mkL (x+y) `add` v
x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v
x :++: (v :-: L y) -> return $ mkL (xy) `add` v
L x :-: (y :++: v) -> return $ mkL (xy) `sub` v
L x :-: (L y :-: v) -> return $ mkL (xy) `add` v
L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v
(y :++: v) :-: L x -> return $ mkL (yx) `add` v
(L y :-: v) :-: L x -> return $ mkL (yx) `sub` v
(v :-: L y) :-: L x -> return $ mkL (0yx) `add` v
(x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v)
(w :-: L x) :+: (L y :-: v) -> return $ mkL (yx) `add` (w `sub` v)
(w :-: L x) :+: (v :-: L y) -> return $ mkL (0xy) `add` (w `add` v)
(L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v)
(L x :-: w) :+: (v :-: L y) -> return $ mkL (xy) `add` (v `sub` w)
(w :-: L x) :+: (y :++: v) -> return $ mkL (yx) `add` (w `add` v)
(L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w)
(y :++: v) :+: (w :-: L x) -> return $ mkL (yx) `add` (w `add` v)
(y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w)
(v :-: L y) :-: (w :-: L x) -> return $ mkL (xy) `add` (v `sub` w)
(v :-: L y) :-: (L x :-: w) -> return $ mkL (0xy) `add` (v `add` w)
(L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w)
(L y :-: v) :-: (L x :-: w) -> return $ mkL (yx) `add` (w `sub` v)
(x :++: w) :-: (y :++: v) -> return $ mkL (xy) `add` (w `sub` v)
(w :-: L x) :-: (y :++: v) -> return $ mkL (0yx) `add` (w `sub` v)
(L x :-: w) :-: (y :++: v) -> return $ mkL (xy) `sub` (v `add` w)
(y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w)
(y :++: v) :-: (L x :-: w) -> return $ mkL (yx) `add` (v `add` w)
x :**: (y :**: v) -> return $ mkL (x*y) `mul` v
(x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v)
x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v)
x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v)
x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y)
v :+: w
| w `cheapEqExpr` v -> return $ mkL 2 `mul` v
w :+: (y :**: v)
| w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v
w :-: (y :**: v)
| w `cheapEqExpr` v -> return $ mkL (1y) `mul` v
(y :**: v) :+: w
| w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v
(y :**: v) :-: w
| w `cheapEqExpr` v -> return $ mkL (y1) `mul` v
(x :**: w) :+: (y :**: v)
| w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v
(x :**: w) :-: (y :**: v)
| w `cheapEqExpr` v -> return $ mkL (xy) `mul` v
w :+: (y :++: v) -> return $ mkL y `add` (w `add` v)
(y :++: v) :+: w -> return $ mkL y `add` (w `add` v)
w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y
(y :++: v) :-: w -> return $ mkL y `add` (v `sub` w)
w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y
(L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v)
w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v)
w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y
(L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v)
(v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y
_ -> mzero
pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr
pattern BinOpApp x op y = OpVal op `App` x `App` y
pattern OpVal :: PrimOp -> Arg CoreBndr
pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where
OpVal op = Var (mkPrimOpId op)
pattern L :: Integer -> Arg CoreBndr
pattern L l <- Lit (isLitValue_maybe -> Just l)
pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
pattern x :+: y <- BinOpApp x (isAddOp -> True) y
pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr
pattern l :++: x <- (isAdd -> Just (l,x))
isAdd :: CoreExpr -> Maybe (Integer,CoreExpr)
isAdd e = case e of
L l :+: x -> Just (l,x)
x :+: L l -> Just (l,x)
_ -> Nothing
pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
pattern x :*: y <- BinOpApp x (isMulOp -> True) y
pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr
pattern l :**: x <- (isMul -> Just (l,x))
isMul :: CoreExpr -> Maybe (Integer,CoreExpr)
isMul e = case e of
L l :*: x -> Just (l,x)
x :*: L l -> Just (l,x)
_ -> Nothing
pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
pattern x :-: y <- BinOpApp x (isSubOp -> True) y
isSubOp :: PrimOp -> Bool
isSubOp IntSubOp = True
isSubOp WordSubOp = True
isSubOp _ = False
isAddOp :: PrimOp -> Bool
isAddOp IntAddOp = True
isAddOp WordAddOp = True
isAddOp _ = False
isMulOp :: PrimOp -> Bool
isMulOp IntMulOp = True
isMulOp WordMulOp = True
isMulOp _ = False
data PrimOps = PrimOps
{ add :: CoreExpr -> CoreExpr -> CoreExpr
, sub :: CoreExpr -> CoreExpr -> CoreExpr
, mul :: CoreExpr -> CoreExpr -> CoreExpr
, mkL :: Integer -> CoreExpr
}
intPrimOps :: DynFlags -> PrimOps
intPrimOps dflags = PrimOps
{ add = \x y -> BinOpApp x IntAddOp y
, sub = \x y -> BinOpApp x IntSubOp y
, mul = \x y -> BinOpApp x IntMulOp y
, mkL = intResult' dflags
}
wordPrimOps :: DynFlags -> PrimOps
wordPrimOps dflags = PrimOps
{ add = \x y -> BinOpApp x WordAddOp y
, sub = \x y -> BinOpApp x WordSubOp y
, mul = \x y -> BinOpApp x WordMulOp y
, mkL = wordResult' dflags
}
caseRules :: DynFlags
-> CoreExpr
-> Maybe ( CoreExpr
, AltCon -> Maybe AltCon
, Id -> CoreExpr)
caseRules dflags (App (App (Var f) v) (Lit l))
| Just op <- isPrimOpId_maybe f
, Just x <- isLitValue_maybe l
, Just adjust_lit <- adjustDyadicRight op x
= Just (v, tx_lit_con dflags adjust_lit
, \v -> (App (App (Var f) (Var v)) (Lit l)))
caseRules dflags (App (App (Var f) (Lit l)) v)
| Just op <- isPrimOpId_maybe f
, Just x <- isLitValue_maybe l
, Just adjust_lit <- adjustDyadicLeft x op
= Just (v, tx_lit_con dflags adjust_lit
, \v -> (App (App (Var f) (Lit l)) (Var v)))
caseRules dflags (App (Var f) v )
| Just op <- isPrimOpId_maybe f
, Just adjust_lit <- adjustUnary op
= Just (v, tx_lit_con dflags adjust_lit
, \v -> App (Var f) (Var v))
caseRules dflags (App (App (Var f) type_arg) v)
| Just TagToEnumOp <- isPrimOpId_maybe f
= Just (v, tx_con_tte dflags
, \v -> (App (App (Var f) type_arg) (Var v)))
caseRules _ (App (App (Var f) (Type ty)) v)
| Just DataToTagOp <- isPrimOpId_maybe f
, Just (tc, _) <- tcSplitTyConApp_maybe ty
, isAlgTyCon tc
= Just (v, tx_con_dtt ty
, \v -> App (App (Var f) (Type ty)) (Var v))
caseRules _ _ = Nothing
tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
tx_lit_con _ _ DEFAULT = Just DEFAULT
tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l)
tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt)
adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
adjustDyadicRight op lit
= case op of
WordAddOp -> Just (\y -> ylit )
IntAddOp -> Just (\y -> ylit )
WordSubOp -> Just (\y -> y+lit )
IntSubOp -> Just (\y -> y+lit )
XorOp -> Just (\y -> y `xor` lit)
XorIOp -> Just (\y -> y `xor` lit)
_ -> Nothing
adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)
adjustDyadicLeft lit op
= case op of
WordAddOp -> Just (\y -> ylit )
IntAddOp -> Just (\y -> ylit )
WordSubOp -> Just (\y -> lity )
IntSubOp -> Just (\y -> lity )
XorOp -> Just (\y -> y `xor` lit)
XorIOp -> Just (\y -> y `xor` lit)
_ -> Nothing
adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
adjustUnary op
= case op of
NotOp -> Just (\y -> complement y)
NotIOp -> Just (\y -> complement y)
IntNegOp -> Just (\y -> negate y )
_ -> Nothing
tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon
tx_con_tte _ DEFAULT = Just DEFAULT
tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)
tx_con_tte dflags (DataAlt dc)
= Just $ LitAlt $ mkMachInt dflags $ toInteger $ dataConTagZ dc
tx_con_dtt :: Type -> AltCon -> Maybe AltCon
tx_con_dtt _ DEFAULT = Just DEFAULT
tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))
| tag >= 0
, tag < n_data_cons
= Just (DataAlt (data_cons !! tag))
| otherwise
= Nothing
where
tag = fromInteger i :: ConTagZ
tc = tyConAppTyCon ty
n_data_cons = tyConFamilySize tc
data_cons = tyConDataCons tc
tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)