diff options
Diffstat (limited to 'compiler/prelude/PrelRules.hs')
-rw-r--r-- | compiler/prelude/PrelRules.hs | 873 |
1 files changed, 727 insertions, 146 deletions
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 1ef0565ff3..80cfa20ba3 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -12,7 +12,7 @@ ToDo: (i1 + i2) only if it results in a valid Float. -} -{-# LANGUAGE CPP, RankNTypes #-} +{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} module PrelRules @@ -25,6 +25,8 @@ where #include "HsVersions.h" #include "../includes/MachDeps.h" +import GhcPrelude + import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId ) import CoreSyn @@ -35,10 +37,11 @@ import CoreOpt ( exprIsLiteral_maybe ) import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn import TysPrim -import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon - , unwrapNewTyCon_maybe, tyConDataCons ) -import DataCon ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId ) -import CoreUtils ( cheapEqExpr, exprIsHNF ) +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 ) @@ -56,9 +59,7 @@ import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) import Control.Applicative ( Alternative(..) ) import Control.Monad -#if __GLASGOW_HASKELL__ > 710 import qualified Control.Monad.Fail as MonadFail -#endif import Data.Bits as Bits import qualified Data.ByteString as BS import Data.Int @@ -90,13 +91,24 @@ primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] -- Int operations primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) - , identityDynFlags zeroi ] + , identityDynFlags zeroi + , numFoldingRules IntAddOp intPrimOps + ] primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) , rightIdentityDynFlags zeroi - , equalArgs >> retLit 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 ] + , identityDynFlags onei + , numFoldingRules IntMulOp intPrimOps + ] primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) , leftZero zeroi , rightIdentityDynFlags onei @@ -122,21 +134,32 @@ 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 [ binaryLit (intOp2 Bits.shiftL) +primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) , rightIdentityDynFlags zeroi ] -primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR) +primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) , rightIdentityDynFlags zeroi ] -primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical) +primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical , rightIdentityDynFlags zeroi ] -- Word operations primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) - , identityDynFlags zerow ] + , identityDynFlags zerow + , numFoldingRules WordAddOp wordPrimOps + ] primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) , rightIdentityDynFlags zerow - , equalArgs >> retLit 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 ] + , 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) @@ -157,8 +180,8 @@ primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) , equalArgs >> retLit zerow ] primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp , inversePrimOp NotOp ] -primOpRules nm SllOp = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ] -primOpRules nm SrlOp = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ] +primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] +primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] -- coercions primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit @@ -361,12 +384,11 @@ cmpOp dflags cmp = go -- These compares are at different types go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2) - go (MachInt i1) (MachInt i2) = done (i1 `cmp` i2) - go (MachInt64 i1) (MachInt64 i2) = done (i1 `cmp` i2) - go (MachWord i1) (MachWord i2) = done (i1 `cmp` i2) - go (MachWord64 i1) (MachWord64 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 -------------------------- @@ -376,12 +398,13 @@ negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational negOp dflags (MachFloat f) = Just (mkFloatVal dflags (-f)) negOp _ (MachDouble 0.0) = Nothing negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (-d)) -negOp dflags (MachInt i) = intResult dflags (-i) +negOp dflags (LitNumber nt i t) + | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t)) negOp _ _ = Nothing complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement -complementOp dflags (MachWord i) = wordResult dflags (complement i) -complementOp dflags (MachInt i) = intResult dflags (complement i) +complementOp dflags (LitNumber nt i t) = + Just (Lit (mkLitNumberWrap dflags nt (complement i) t)) complementOp _ _ = Nothing -------------------------- @@ -393,11 +416,18 @@ intOp2 = intOp2' . const intOp2' :: (Integral a, Integral b) => (DynFlags -> a -> b -> Integer) -> DynFlags -> Literal -> Literal -> Maybe CoreExpr -intOp2' op dflags (MachInt i1) (MachInt i2) = +intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = let o = op dflags in intResult dflags (fromInteger i1 `o` fromInteger i2) intOp2' _ _ _ _ = Nothing -- Could find LitLit +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 -- Could find LitLit + shiftRightLogical :: DynFlags -> Integer -> Int -> Integer -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do -- Do this by converting to Word and back. Obviously this won't work for big @@ -412,29 +442,45 @@ 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 (MachWord w1) (MachWord w2) +wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = wordResult dflags (fromInteger w1 `op` fromInteger w2) wordOp2 _ _ _ _ = Nothing -- Could find LitLit -wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr +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 -- Could find LitLit + +shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr -- Shifts take an Int; hence third arg of op is Int -- See Note [Guarding against silly shifts] -wordShiftRule shift_op +shiftRule shift_op = do { dflags <- getDynFlags - ; [e1, Lit (MachInt shift_len)] <- getArgs + ; [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 (MachWord x) + + -- Do the shift at type Integer, but shift length is Int + Lit (LitNumber nt x t) -> let op = shift_op dflags - in liftMaybe $ wordResult dflags (x `op` fromInteger shift_len) - -- Do the shift at type Integer, but shift length is Int + y = x `op` fromInteger shift_len + in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t)) + _ -> mzero } wordSizeInBits :: DynFlags -> Integer @@ -524,30 +570,62 @@ mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dfla mkRuleFn _ _ _ _ = Nothing isMinBound :: DynFlags -> Literal -> Bool -isMinBound _ (MachChar c) = c == minBound -isMinBound dflags (MachInt i) = i == tARGET_MIN_INT dflags -isMinBound _ (MachInt64 i) = i == toInteger (minBound :: Int64) -isMinBound _ (MachWord i) = i == 0 -isMinBound _ (MachWord64 i) = i == 0 -isMinBound _ _ = False +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 (MachInt i) = i == tARGET_MAX_INT dflags -isMaxBound _ (MachInt64 i) = i == toInteger (maxBound :: Int64) -isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags -isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64) -isMaxBound _ _ = False +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 -- | Create an Int literal expression while ensuring the given Integer is in the -- target Int range intResult :: DynFlags -> Integer -> Maybe CoreExpr -intResult dflags result = Just (Lit (mkMachIntWrap dflags result)) +intResult dflags result = Just (intResult' dflags result) + +intResult' :: DynFlags -> Integer -> CoreExpr +intResult' dflags result = Lit (mkMachIntWrap dflags result) + +-- | Create an unboxed pair of an Int literal expression, ensuring the given +-- Integer is in the target Int range and the corresponding overflow flag +-- (@0#@/@1#@) if it wasn't. +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 -- | Create a Word literal expression while ensuring the given Integer is in the -- target Word range wordResult :: DynFlags -> Integer -> Maybe CoreExpr -wordResult dflags result = Just (Lit (mkMachWordWrap dflags result)) +wordResult dflags result = Just (wordResult' dflags result) + +wordResult' :: DynFlags -> Integer -> CoreExpr +wordResult' dflags result = Lit (mkMachWordWrap dflags result) + +-- | Create an unboxed pair of a Word literal expression, ensuring the given +-- Integer is in the target Word range and the corresponding carry flag +-- (@0#@/@1#@) if it wasn't. +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 @@ -649,12 +727,10 @@ 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 _ = mzero + fail = MonadFail.fail -#if __GLASGOW_HASKELL__ > 710 instance MonadFail.MonadFail RuleM where fail _ = mzero -#endif instance Alternative RuleM where empty = RuleM $ \_ _ _ -> Nothing @@ -734,6 +810,16 @@ leftIdentityDynFlags id_lit = do guard $ l1 == id_lit dflags return e2 +-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in +-- addition to the result, we have to indicate that no carry/overflow occured. +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 @@ -741,8 +827,25 @@ rightIdentityDynFlags id_lit = do guard $ l2 == id_lit dflags return e1 +-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in +-- addition to the result, we have to indicate that no carry/overflow occured. +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 +identityDynFlags lit = + leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit + +-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition +-- to the result, we have to indicate that no carry/overflow occured. +identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +identityCDynFlags lit = + leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr leftZero zero = do @@ -831,9 +934,9 @@ trueValBool = Var trueDataConId -- see Note [What's true and false] falseValBool = Var falseDataConId ltVal, eqVal, gtVal :: Expr CoreBndr -ltVal = Var ltDataConId -eqVal = Var eqDataConId -gtVal = Var gtDataConId +ltVal = Var ordLTDataConId +eqVal = Var ordEQDataConId +gtVal = Var ordGTDataConId mkIntVal :: DynFlags -> Integer -> Expr CoreBndr mkIntVal dflags i = Lit (mkMachInt dflags i) @@ -880,7 +983,7 @@ tagToEnumRule :: RuleM CoreExpr -- If data T a = A | B | C -- then tag2Enum# (T ty) 2# --> B ty tagToEnumRule = do - [Type ty, Lit (MachInt i)] <- getArgs + [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs case splitTyConApp_maybe ty of Just (tycon, tc_args) | isEnumerationTyCon tycon -> do let tag = fromInteger i @@ -893,21 +996,35 @@ tagToEnumRule = do _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" -{- -For dataToTag#, we can reduce if either - - (a) the argument is a constructor - (b) the argument is a variable whose unfolding is a known constructor --} - +------------------------------ dataToTagRule :: RuleM CoreExpr +-- Rules for dataToTag# dataToTagRule = a `mplus` b where + -- dataToTag (tagToEnum x) ==> x 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 -- dataToTag (tagToEnum x) ==> x + return tag + + -- Why don't we simplify tagToEnum# (dataToTag# x) to x? We would + -- like to, but it seems tricky. See #14282. The trouble is that + -- we never actually see tagToEnum# (dataToTag# x). Because dataToTag# + -- is can_fail, this expression is immediately transformed into + -- + -- case dataToTag# @T x of wild + -- { __DEFAULT -> tagToEnum# @T wild } + -- + -- and wild has no unfolding. Simon Peyton Jones speculates one way around + -- might be to arrange to give unfoldings to case binders of CONLIKE + -- applications and mark dataToTag# CONLIKE, but he doubts it's really + -- worth the trouble. + + -- dataToTag (K e1 e2) ==> tag-of K + -- This also works (via exprIsConApp_maybe) for + -- dataToTag x + -- where x's unfolding is a constructor application b = do dflags <- getDynFlags [_, val_arg] <- getArgs @@ -924,12 +1041,65 @@ dataToTagRule = a `mplus` b ************************************************************************ -} --- seq# :: forall a s . a -> State# s -> (# State# s, a #) +{- Note [seq# magic] +~~~~~~~~~~~~~~~~~~~~ +The primop + seq# :: forall a s . a -> State# s -> (# State# s, a #) + +is /not/ the same as the Prelude function seq :: a -> b -> b +as you can see from its type. In fact, seq# is the implementation +mechanism for 'evaluate' + + evaluate :: a -> IO a + evaluate a = IO $ \s -> seq# a s + +The semantics of seq# is + * evaluate its first argument + * and return it + +Things to note + +* Why do we need a primop at all? That is, instead of + case seq# x s of (# x, s #) -> blah + why not instead say this? + case x of { DEFAULT -> blah) + + Reason (see Trac #5129): if we saw + catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler + + then we'd drop the 'case x' because the body of the case is bottom + anyway. But we don't want to do that; the whole /point/ of + seq#/evaluate is to evaluate 'x' first in the IO monad. + + In short, we /always/ evaluate the first argument and never + just discard it. + +* Why return the value? So that we can control sharing of seq'd + values: in + let x = e in x `seq` ... x ... + We don't want to inline x, so better to represent it as + let x = e in case seq# x RW of (# _, x' #) -> ... x' ... + also it matches the type of rseq in the Eval monad. + +Implementing seq#. The compiler has magic for SeqOp in + +- PrelRules.seqRule: eliminate (seq# <whnf> s) + +- StgCmmExpr.cgExpr, and cgCase: special case for seq# + +- CoreUtils.exprOkForSpeculation; + see Note [seq# and expr_ok] in CoreUtils + +- Simplify.addEvals records evaluated-ness for the result; see + Note [Adding evaluatedness info to pattern-bound variables] + in Simplify +-} + seqRule :: RuleM CoreExpr seqRule = do - [Type ty_a, Type ty_s, a, s] <- getArgs + [Type ty_a, Type _ty_s, a, s] <- getArgs guard $ exprIsHNF a - return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a] + return $ mkCoreUbxTup [exprType s, ty_a] [s, a] -- spark# :: forall a s . a -> State# s -> (# State# s, a #) sparkRule :: RuleM CoreExpr @@ -987,7 +1157,7 @@ builtinRules [ nonZeroLit 1 >> binaryLit (intOp2 div) , leftZero zeroi , do - [arg, Lit (MachInt d)] <- getArgs + [arg, Lit (LitNumber LitNumInt d _)] <- getArgs Just n <- return $ exactLog2 d dflags <- getDynFlags return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n @@ -996,7 +1166,7 @@ builtinRules [ nonZeroLit 1 >> binaryLit (intOp2 mod) , leftZero zeroi , do - [arg, Lit (MachInt d)] <- getArgs + [arg, Lit (LitNumber LitNumInt d _)] <- getArgs Just _ <- return $ exactLog2 d dflags <- getDynFlags return $ Var (mkPrimOpId AndIOp) @@ -1004,6 +1174,10 @@ builtinRules ] ] ++ builtinIntegerRules + ++ builtinNaturalRules +{-# NOINLINE builtinRules #-} +-- there is no benefit to inlining these yet, despite this, GHC produces +-- unfoldings for this regardless since the floated list entries look small. builtinIntegerRules :: [CoreRule] builtinIntegerRules = @@ -1082,7 +1256,7 @@ builtinIntegerRules = ru_try = match_Integer_unop op } rule_bitInteger str name = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, - ru_try = match_IntToInteger_unop (bit . fromIntegral) } + 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 } @@ -1117,6 +1291,31 @@ builtinIntegerRules = = 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 } + --------------------------------------------------- -- The rule is this: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) @@ -1208,51 +1407,68 @@ match_IntToInteger = match_IntToInteger_unop id match_WordToInteger :: RuleFun match_WordToInteger _ id_unf id [xl] - | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl + | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of Just (_, integerTy) -> - Just (Lit (LitInteger x 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 (MachInt64 x) <- exprIsLiteral_maybe id_unf xl + | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of Just (_, integerTy) -> - Just (Lit (LitInteger x 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 (MachWord64 x) <- exprIsLiteral_maybe id_unf xl + | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType id) of Just (_, integerTy) -> - Just (Lit (LitInteger x integerTy)) + Just (Lit (mkLitInteger x integerTy)) _ -> panic "match_Word64ToInteger: Id has the wrong type" match_Word64ToInteger _ _ _ _ = Nothing -------------------------------------------------- -match_Integer_convert :: Num a - => (DynFlags -> a -> Expr CoreBndr) - -> RuleFun -match_Integer_convert convert dflags id_unf _ [xl] - | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert dflags (fromInteger x)) -match_Integer_convert _ _ _ _ _ = 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_Integer_unop :: (Integer -> Integer) -> RuleFun -match_Integer_unop unop _ id_unf _ [xl] - | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl - = Just (Lit (LitInteger (unop x) i)) -match_Integer_unop _ _ _ _ _ = 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 -{- Note [Rewriting bitInteger] +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 +------------------------------------------------- +{- Note [Rewriting bitInteger] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For most types the bitInteger operation can be implemented in terms of shifts. The integer-gmp package, however, can do substantially better than this if allowed to provide its own implementation. However, in so doing it previously lost @@ -1260,68 +1476,117 @@ constant-folding (see Trac #8832). The bitInteger rule above provides constant f specifically for this function. There is, however, a bit of trickiness here when it comes to ranges. While the -AST encodes all integers (even MachInts) as Integers, `bit` expects the bit +AST encodes all integers as Integers, `bit` expects the bit index to be given as an Int. Hence we coerce to an Int in the rule definition. This will behave a bit funny for constants larger than the word size, but the user should expect some funniness given that they will have at very least ignored a warning in this case. -} +match_bitInteger :: RuleFun +-- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer +match_bitInteger dflags id_unf fn [arg] + | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg + , x >= 0 + , x <= (wordSizeInBits dflags - 1) + -- Make sure x is small enough to yield a decently small iteger + -- Attempting to construct the Integer for + -- (bitInteger 9223372036854775807#) + -- would be a bad idea (Trac #14959) + , 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 (MachInt x) <- exprIsLiteral_maybe id_unf xl + | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType fn) of Just (_, integerTy) -> - Just (Lit (LitInteger (unop x) 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 (LitInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (LitInteger (x `binop` y) i)) + | 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 + -- This helper is used for the quotRem and divMod functions match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun match_Integer_divop_both divop _ id_unf _ [xl,yl] - | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf 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 (LitInteger r t), Lit (LitInteger s t)] + = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)] match_Integer_divop_both _ _ _ _ _ = Nothing -- This helper is used for the quot and rem functions match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun match_Integer_divop_one divop _ id_unf _ [xl,yl] - | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 - = Just (Lit (LitInteger (x `divop` y) i)) + = 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 (LitInteger x i) <- exprIsLiteral_maybe id_unf xl - , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl - = Just (Lit (LitInteger (x `binop` fromIntegral y) i)) + | 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 (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf 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 (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf 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 @@ -1332,8 +1597,8 @@ match_Integer_Int_encodeFloat :: RealFloat a => (a -> Expr CoreBndr) -> RuleFun match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] - | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (MachInt y) <- exprIsLiteral_maybe id_unf 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 @@ -1351,14 +1616,14 @@ match_rationalTo :: RealFloat a => (a -> Expr CoreBndr) -> RuleFun match_rationalTo mkLit _ id_unf _ [xl, yl] - | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf 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 _ id_unf fn [xl] +match_decodeDouble dflags id_unf fn [xl] | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl = case splitFunTy_maybe (idType fn) of Just (_, res) @@ -1366,8 +1631,8 @@ match_decodeDouble _ id_unf fn [xl] -> case decodeFloat (fromRational x :: Double) of (y, z) -> Just $ mkCoreUbxTup [integerTy, intHashTy] - [Lit (LitInteger y integerTy), - Lit (MachInt (toInteger z))] + [Lit (mkLitInteger y integerTy), + Lit (mkMachInt dflags (toInteger z))] _ -> pprPanic "match_decodeDouble: Id has the wrong type" (ppr fn <+> dcolon <+> ppr (idType fn)) @@ -1388,6 +1653,275 @@ match_smallIntegerTo _ _ _ _ _ = Nothing -------------------------------------------------------- +-- Note [Constant folding through nested expressions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We use rewrites rules to perform constant folding. It means that we don't +-- have a global view of the expression we are trying to optimise. As a +-- consequence we only perform local (small-step) transformations that either: +-- 1) reduce the number of operations +-- 2) rearrange the expression to increase the odds that other rules will +-- match +-- +-- We don't try to handle more complex expression optimisation cases that would +-- require a global view. For example, rewriting expressions to increase +-- sharing (e.g., Horner's method); optimisations that require local +-- transformations increasing the number of operations; rearrangements to +-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0). +-- +-- We already have rules to perform constant folding on expressions with the +-- following shape (where a and/or b are literals): +-- +-- D) op +-- /\ +-- / \ +-- / \ +-- a b +-- +-- To support nested expressions, we match three other shapes of expression +-- trees: +-- +-- A) op1 B) op1 C) op1 +-- /\ /\ /\ +-- / \ / \ / \ +-- / \ / \ / \ +-- a op2 op2 c op2 op3 +-- /\ /\ /\ /\ +-- / \ / \ / \ / \ +-- b c a b a b c d +-- +-- +-- R1) +/- simplification: +-- ops = + or -, two literals (not siblings) +-- +-- Examples: +-- A: 5 + (10-x) ==> 15-x +-- B: (10+x) + 5 ==> 15+x +-- C: (5+a)-(5-b) ==> 0+(a+b) +-- +-- R2) * simplification +-- ops = *, two literals (not siblings) +-- +-- Examples: +-- A: 5 * (10*x) ==> 50*x +-- B: (10*x) * 5 ==> 50*x +-- C: (5*a)*(5*b) ==> 25*(a*b) +-- +-- R3) * distribution over +/- +-- op1 = *, op2 = + or -, two literals (not siblings) +-- +-- This transformation doesn't reduce the number of operations but switches +-- the outer and the inner operations so that the outer is (+) or (-) instead +-- of (*). It increases the odds that other rules will match after this one. +-- +-- Examples: +-- A: 5 * (10-x) ==> 50 - (5*x) +-- B: (10+x) * 5 ==> 50 + (5*x) +-- C: Not supported as it would increase the number of operations: +-- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b +-- +-- R4) Simple factorization +-- +-- op1 = + or -, op2/op3 = *, +-- one literal for each innermost * operation (except in the D case), +-- the two other terms are equals +-- +-- Examples: +-- A: x - (10*x) ==> (-9)*x +-- B: (10*x) + x ==> 11*x +-- C: (5*x)-(x*3) ==> 2*x +-- D: x+x ==> 2*x +-- +-- R5) +/- propagation +-- +-- ops = + or -, one literal +-- +-- This transformation doesn't reduce the number of operations but propagates +-- the constant to the outer level. It increases the odds that other rules +-- will match after this one. +-- +-- Examples: +-- A: x - (10-y) ==> (x+y) - 10 +-- B: (10+x) - y ==> 10 + (x-y) +-- C: N/A (caught by the A and B cases) +-- +-------------------------------------------------------- + +-- | Rules to perform constant folding into nested expressions +-- +--See Note [Constant folding through nested expressions] +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 + -- R1) +/- simplification + 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 (x-y) `add` v + L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v + L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v + L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v + + (y :++: v) :-: L x -> return $ mkL (y-x) `add` v + (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v + (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v + + (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v) + (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v) + (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `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 (x-y) `add` (v `sub` w) + (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v) + (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w) + (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `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 (x-y) `add` (v `sub` w) + (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `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 (y-x) `add` (w `sub` v) + (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v) + (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v) + (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w) + (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w) + (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w) + + -- R2) * simplification + x :**: (y :**: v) -> return $ mkL (x*y) `mul` v + (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v) + + -- R3) * distribution over +/- + 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) + + -- R4) Simple factorization + 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 (1-y) `mul` v + (y :**: v) :+: w + | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v + (y :**: v) :-: w + | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v + (x :**: w) :+: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v + (x :**: w) :-: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v + + -- R5) +/- propagation + 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 + + + +-- | Match the application of a binary primop +pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr +pattern BinOpApp x op y = OpVal op `App` x `App` y + +-- | Match a primop +pattern OpVal :: PrimOp -> Arg CoreBndr +pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where + OpVal op = Var (mkPrimOpId op) + + + +-- | Match a literal +pattern L :: Integer -> Arg CoreBndr +pattern L l <- Lit (isLitValue_maybe -> Just l) + +-- | Match an addition +pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :+: y <- BinOpApp x (isAddOp -> True) y + +-- | Match an addition with a literal (handle commutativity) +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 + +-- | Match a multiplication +pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :*: y <- BinOpApp x (isMulOp -> True) y + +-- | Match a multiplication with a literal (handle commutativity) +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 + + +-- | Match a subtraction +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 + +-- | Explicit "type-class"-like dictionary for numeric primops +-- +-- Depends on DynFlags because creating a literal value depends on DynFlags +data PrimOps = PrimOps + { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers + , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers + , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers + , mkL :: Integer -> CoreExpr -- ^ Create a literal value + } + +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 + } + + +-------------------------------------------------------- -- Constant folding through case-expressions -- -- cf Scrutinee Constant Folding in simplCore/SimplUtils @@ -1396,11 +1930,13 @@ match_smallIntegerTo _ _ _ _ _ = Nothing -- | Match the scrutinee of a case and potentially return a new scrutinee and a -- function to apply to each literal alternative. caseRules :: DynFlags - -> CoreExpr -- Scrutinee - -> Maybe ( CoreExpr -- New scrutinee - , AltCon -> AltCon -- How to fix up the alt pattern - , Id -> CoreExpr) -- How to reconstruct the original scrutinee - -- from the new case-binder + -> CoreExpr -- Scrutinee + -> Maybe ( CoreExpr -- New scrutinee + , AltCon -> Maybe AltCon -- How to fix up the alt pattern + -- Nothing <=> Unreachable + -- See Note [Unreachable caseRules alternatives] + , Id -> CoreExpr) -- How to reconstruct the original scrutinee + -- from the new case-binder -- e.g case e of b { -- ...; -- con bs -> rhs; @@ -1423,7 +1959,7 @@ caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v , Just x <- isLitValue_maybe l , Just adjust_lit <- adjustDyadicLeft x op = Just (v, tx_lit_con dflags adjust_lit - , \v -> (App (App (Var f) (Var v)) (Lit l))) + , \v -> (App (App (Var f) (Lit l)) (Var v))) caseRules dflags (App (Var f) v ) -- op v @@ -1441,15 +1977,17 @@ caseRules dflags (App (App (Var f) type_arg) v) -- See Note [caseRules for dataToTag] caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x | 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 -> AltCon -tx_lit_con _ _ DEFAULT = DEFAULT -tx_lit_con dflags adjust (LitAlt l) = LitAlt (mapLitValue dflags adjust l) +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) -- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the -- literal alternatives remain in Word/Int target ranges @@ -1489,22 +2027,28 @@ adjustUnary op IntNegOp -> Just (\y -> negate y ) _ -> Nothing -tx_con_tte :: DynFlags -> AltCon -> AltCon -tx_con_tte _ DEFAULT = DEFAULT -tx_con_tte dflags (DataAlt dc) - | tag == 0 = DEFAULT -- See Note [caseRules for tagToEnum] - | otherwise = LitAlt (mkMachInt dflags (toInteger tag)) - where - tag = dataConTagZ dc -tx_con_tte _ alt = pprPanic "caseRules" (ppr alt) +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) -- See Note [caseRules for tagToEnum] + = 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)) -- tag is zero-indexed, as is (!!) + | 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) -tx_con_dtt :: Type -> AltCon -> AltCon -tx_con_dtt _ DEFAULT = DEFAULT -tx_con_dtt ty (LitAlt (MachInt i)) = DataAlt (get_con ty (fromInteger i)) -tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) - -get_con :: Type -> ConTagZ -> DataCon -get_con ty tag = tyConDataCons (tyConAppTyCon ty) !! tag {- Note [caseRules for tagToEnum] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1515,18 +2059,34 @@ We want to transform into case x of 0# -> e1 - 1# -> e1 + 1# -> e2 -This rule elimiantes a lot of boilerplate. For - if (x>y) then e1 else e2 +This rule eliminates a lot of boilerplate. For + if (x>y) then e2 else e1 we generate case tagToEnum (x ># y) of - False -> e2 - True -> e1 + False -> e1 + True -> e2 and it is nice to then get rid of the tagToEnum. -NB: in SimplUtils, where we invoke caseRules, - we convert that 0# to DEFAULT +Beware (Trac #14768): avoid the temptation to map constructor 0 to +DEFAULT, in the hope of getting this + case (x ># y) of + DEFAULT -> e1 + 1# -> e2 +That fails utterly in the case of + data Colour = Red | Green | Blue + case tagToEnum x of + DEFAULT -> e1 + Red -> e2 + +We don't want to get this! + case x of + DEFAULT -> e1 + DEFAULT -> e2 + +Instead, we deal with turning one branch into DEFAULT in SimplUtils +(add_default in mkCase3). Note [caseRules for dataToTag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1541,4 +2101,25 @@ into Note the need for some wildcard binders in the 'cons' case. + +For the time, we only apply this transformation when the type of `x` is a type +headed by a normal tycon. In particular, we do not apply this in the case of a +data family tycon, since that would require carefully applying coercion(s) +between the data family and the data family instance's representation type, +which caseRules isn't currently engineered to handle (#14680). + +Note [Unreachable caseRules alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Take care if we see something like + case dataToTag x of + DEFAULT -> e1 + -1# -> e2 + 100 -> e3 +because there isn't a data constructor with tag -1 or 100. In this case the +out-of-range alterantive is dead code -- we know the range of tags for x. + +Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating +an alternative that is unreachable. + +You may wonder how this can happen: check out Trac #15436. -} |