{-# LANGUAGE CPP, RankNTypes #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
-module PrelRules ( primOpRules, builtinRules ) where
+module PrelRules
+ ( primOpRules
+ , builtinRules
+ , caseRules
+ )
+where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
+import GhcPrelude
+
import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )
import CoreSyn
import MkCore
import Id
import Literal
-import CoreSubst ( exprIsLiteral_maybe )
+import CoreOpt ( exprIsLiteral_maybe )
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn
import TysPrim
-import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe )
-import DataCon ( dataConTag, dataConTyCon, dataConWorkId )
+import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon
+ , unwrapNewTyCon_maybe, tyConDataCons )
+import DataCon ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId )
import CoreUtils ( cheapEqExpr, exprIsHNF )
import CoreUnfold ( exprIsConApp_maybe )
import Type
-import TypeRep
import OccName ( occNameFS )
import PrelNames
import Maybes ( orElse )
import Util
import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..))
-#if __GLASGOW_HASKELL__ >= 709
import Control.Applicative ( Alternative(..) )
-#else
-import Control.Applicative ( Applicative(..), Alternative(..) )
-#endif
import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
import Data.Bits as Bits
import qualified Data.ByteString as BS
import Data.Int
, 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 WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
, rightIdentityDynFlags onew ]
primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
- , rightIdentityDynFlags onew ]
+ , 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 ]
, 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
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 (==) [ litEq True ]
-primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
+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 (==) [ litEq True ]
-primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
+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 ]
mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
-> [RuleM CoreExpr] -> Maybe CoreRule
mkRelOpRule nm cmp extra
- = mkPrimOpRule nm 2 $ rules ++ extra
+ = mkPrimOpRule nm 2 $
+ binaryCmpLit cmp : equal_rule : extra
where
- rules = [ binaryCmpLit cmp
- , do equalArgs
- -- x `cmp` x does not depend on x, so
- -- compute it for the arbitrary value 'True'
- -- and use that result
- dflags <- getDynFlags
- return (if cmp True True
- then trueValInt dflags
- else falseValInt dflags) ]
-
--- Note [Rules for floating-point comparisons]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- We need different rules for floating-point values because for floats
--- it is not true that x = x. The special case when this does not occur
--- are NaNs.
+ -- x `cmp` x does not depend on x, so
+ -- compute it for the arbitrary value 'True'
+ -- and use that result
+ equal_rule = do { equalArgs
+ ; dflags <- getDynFlags
+ ; return (if cmp True True
+ then trueValInt dflags
+ else falseValInt dflags) }
+
+{- Note [Rules for floating-point comparisons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need different rules for floating-point values because for floats
+it is not true that x = x (for NaNs); so we do not want the equal_rule
+rule that mkRelOpRule uses.
+
+Note also that, in the case of equality/inequality, we do /not/
+want to switch to a case-expression. For example, we do not want
+to convert
+ case (eqFloat# x 3.8#) of
+ True -> this
+ False -> that
+to
+ case x of
+ 3.8#::Float# -> this
+ _ -> that
+See Trac #9238. Reason: comparing floating-point values for equality
+delicate, and we don't want to implement that delicacy in the code for
+case expressions. So we make it an invariant of Core that a case
+expression never scrutinises a Float# or Double#.
+
+This transformation is what the litEq rule does;
+see Note [The litEq rule: converting equality to case].
+So we /refrain/ from using litEq for mkFloatingRelOpRule.
+-}
mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
- -> [RuleM CoreExpr] -> Maybe CoreRule
-mkFloatingRelOpRule nm cmp extra -- See Note [Rules for floating-point comparisons]
- = mkPrimOpRule nm 2 $ binaryCmpLit cmp : extra
+ -> Maybe CoreRule
+-- See Note [Rules for floating-point comparisons]
+mkFloatingRelOpRule nm cmp
+ = mkPrimOpRule nm 2 [binaryCmpLit cmp]
-- common constants
zeroi, onei, zerow, onew :: DynFlags -> Literal
= wordResult dflags (fromInteger w1 `op` fromInteger w2)
wordOp2 _ _ _ _ = Nothing -- Could find LitLit
-wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
+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
; case e1 of
| shift_len < 0 || wordSizeInBits dflags < shift_len
-> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
("Bad shift length" ++ show shift_len))
+
+ -- Do the shift at type Integer, but shift length is Int
+ Lit (MachInt x)
+ -> let op = shift_op dflags
+ in liftMaybe $ intResult dflags (x `op` fromInteger shift_len)
+
Lit (MachWord x)
-> 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
+
_ -> mzero }
wordSizeInBits :: DynFlags -> Integer
doubleOp2 _ _ _ _ = Nothing
--------------------------
--- This stuff turns
--- n ==# 3#
--- into
--- case n of
--- 3# -> True
--- m -> False
---
--- This is a Good Thing, because it allows case-of case things
--- to happen, and case-default absorption to happen. For
--- example:
---
--- if (n ==# 3#) || (n ==# 4#) then e1 else e2
--- will transform to
--- case n of
--- 3# -> e1
--- 4# -> e1
--- m -> e2
--- (modulo the usual precautions to avoid duplicating e1)
+{- Note [The litEq rule: converting equality to case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This stuff turns
+ n ==# 3#
+into
+ case n of
+ 3# -> True
+ m -> False
+
+This is a Good Thing, because it allows case-of case things
+to happen, and case-default absorption to happen. For
+example:
+
+ if (n ==# 3#) || (n ==# 4#) then e1 else e2
+will transform to
+ case n of
+ 3# -> e1
+ 4# -> e1
+ m -> e2
+(modulo the usual precautions to avoid duplicating e1)
+-}
litEq :: Bool -- True <=> equality, False <=> inequality
-> RuleM CoreExpr
isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64)
isMaxBound _ _ = False
-
--- Note that we *don't* warn the user about overflow. It's not done at
--- runtime either, and compilation of completely harmless things like
--- ((124076834 :: Word32) + (2147483647 :: Word32))
--- would yield a warning. Instead we simply squash the value into the
--- *target* Int/Word range.
+-- | 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 (mkIntVal dflags result')
- where result' = case platformWordSize (targetPlatform dflags) of
- 4 -> toInteger (fromInteger result :: Int32)
- 8 -> toInteger (fromInteger result :: Int64)
- w -> panic ("intResult: Unknown platformWordSize: " ++ show w)
+intResult dflags result = Just (Lit (mkMachIntWrap dflags result))
+-- | 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 (mkWordVal dflags result')
- where result' = case platformWordSize (targetPlatform dflags) of
- 4 -> toInteger (fromInteger result :: Word32)
- 8 -> toInteger (fromInteger result :: Word64)
- w -> panic ("wordResult: Unknown platformWordSize: " ++ show w)
+wordResult dflags result = Just (Lit (mkMachWordWrap dflags result))
inversePrimOp :: PrimOp -> RuleM CoreExpr
inversePrimOp primop = do
fmap = liftM
instance Applicative RuleM where
- pure = return
+ pure x = RuleM $ \_ _ _ -> Just x
(<*>) = ap
instance Monad RuleM where
- return x = RuleM $ \_ _ _ -> Just x
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
+
+instance MonadFail.MonadFail RuleM where
+ fail _ = mzero
instance Alternative RuleM where
- empty = mzero
- (<|>) = mplus
+ empty = RuleM $ \_ _ _ -> Nothing
+ RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args ->
+ f1 dflags iu args <|> f2 dflags iu args
-instance MonadPlus RuleM where
- mzero = RuleM $ \_ _ _ -> Nothing
- mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args ->
- f1 dflags iu args `mplus` f2 dflags iu args
+instance MonadPlus RuleM
instance HasDynFlags RuleM where
getDynFlags = RuleM $ \dflags _ _ -> Just dflags
mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
mkIntVal dflags i = Lit (mkMachInt dflags i)
-mkWordVal :: DynFlags -> Integer -> Expr CoreBndr
-mkWordVal dflags w = Lit (mkMachWord dflags w)
mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f))
mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
case splitTyConApp_maybe ty of
Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
let tag = fromInteger i
- correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
+ 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
-- See Note [tagToEnum#]
- _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
+ _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )
return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
{-
in_scope <- getInScopeEnv
(dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
- return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))
+ return $ mkIntVal dflags (toInteger (dataConTagZ dc))
{-
************************************************************************
-- seq# :: forall a s . a -> State# s -> (# State# s, a #)
seqRule :: RuleM CoreExpr
seqRule = do
- [ty_a, Type ty_s, a, s] <- getArgs
+ [Type ty_a, Type ty_s, a, s] <- getArgs
guard $ exprIsHNF a
- return $ mkConApp (tupleDataCon Unboxed 2)
- [Type (mkStatePrimTy ty_s), ty_a, s, a]
+ return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a]
-- spark# :: forall a s . a -> State# s -> (# State# s, a #)
sparkRule :: RuleM CoreExpr
builtinRules
= [BuiltinRule { ru_name = fsLit "AppendLitString",
ru_fn = unpackCStringFoldrName,
- ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
+ ru_nargs = 4, ru_try = match_append_lit },
BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
- ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
+ 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 }
+ ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },
+ mkBasicRule divIntName 2 $ msum
+ [ nonZeroLit 1 >> binaryLit (intOp2 div)
+ , leftZero zeroi
+ , do
+ [arg, Lit (MachInt 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 (MachInt d)] <- getArgs
+ Just _ <- return $ exactLog2 d
+ dflags <- getDynFlags
+ return $ Var (mkPrimOpId AndIOp)
+ `App` arg `App` mkIntVal dflags (d - 1)
+ ]
]
++ builtinIntegerRules
+{-# 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 =
-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
-- = unpackFoldrCString# "foobaz" c n
-match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_append_lit [Type ty1,
- Lit (MachStr s1),
- c1,
- Var unpk `App` Type ty2
- `App` Lit (MachStr s2)
- `App` c2
- `App` n
- ]
+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_append_lit _ _ _ _ = Nothing
---------------------------------------------------
-- The rule is this:
--- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
-
-match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
- Var unpk2 `App` Lit (MachStr s2)]
- | unpk1 `hasKey` unpackCStringIdKey,
- unpk2 `hasKey` unpackCStringIdKey
+-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
+
+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_eq_string _ _ _ _ = Nothing
---------------------------------------------------
, Just dictTc <- tyConAppTyCon_maybe dictTy
, Just (_,_,co) <- unwrapNewTyCon_maybe dictTc
= Just
- $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a]))
+ $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))
`App` y
match_magicDict _ = Nothing
match_WordToInteger :: RuleFun
match_WordToInteger _ id_unf id [xl]
| Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
- = case idType id of
- FunTy _ integerTy ->
+ = case splitFunTy_maybe (idType id) of
+ Just (_, integerTy) ->
Just (Lit (LitInteger x integerTy))
_ ->
panic "match_WordToInteger: Id has the wrong type"
match_Int64ToInteger :: RuleFun
match_Int64ToInteger _ id_unf id [xl]
| Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
- = case idType id of
- FunTy _ integerTy ->
+ = case splitFunTy_maybe (idType id) of
+ Just (_, integerTy) ->
Just (Lit (LitInteger x integerTy))
_ ->
panic "match_Int64ToInteger: Id has the wrong type"
match_Word64ToInteger :: RuleFun
match_Word64ToInteger _ id_unf id [xl]
| Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
- = case idType id of
- FunTy _ integerTy ->
+ = case splitFunTy_maybe (idType id) of
+ Just (_, integerTy) ->
Just (Lit (LitInteger x integerTy))
_ ->
panic "match_Word64ToInteger: Id has the wrong type"
match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
match_IntToInteger_unop unop _ id_unf fn [xl]
| Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
- = case idType fn of
- FunTy _ integerTy ->
+ = case splitFunTy_maybe (idType fn) of
+ Just (_, integerTy) ->
Just (Lit (LitInteger (unop x) integerTy))
_ ->
panic "match_IntToInteger_unop: Id has the wrong type"
, Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
, y /= 0
, (r,s) <- x `divop` y
- = Just $ mkConApp (tupleDataCon Unboxed 2)
- [Type t,
- Type t,
- Lit (LitInteger r t),
- Lit (LitInteger s t)]
+ = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)]
match_Integer_divop_both _ _ _ _ _ = Nothing
-- This helper is used for the quot and rem functions
match_decodeDouble :: RuleFun
match_decodeDouble _ id_unf fn [xl]
| Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
- = case idType fn of
- FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
- case decodeFloat (fromRational x :: Double) of
- (y, z) ->
- Just $ mkConApp (tupleDataCon Unboxed 2)
- [Type integerTy,
- Type intHashTy,
- Lit (LitInteger y integerTy),
- Lit (MachInt (toInteger z))]
+ = 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 (LitInteger y integerTy),
+ Lit (MachInt (toInteger z))]
_ ->
- panic "match_decodeDouble: Id has the wrong type"
+ pprPanic "match_decodeDouble: Id has the wrong type"
+ (ppr fn <+> dcolon <+> ppr (idType fn))
match_decodeDouble _ _ _ _ = Nothing
match_XToIntegerToX :: Name -> RuleFun
| idName x == smallIntegerName
= Just $ App (Var (mkPrimOpId primOp)) y
match_smallIntegerTo _ _ _ _ _ = Nothing
+
+
+
+--------------------------------------------------------
+-- Constant folding through case-expressions
+--
+-- cf Scrutinee Constant Folding in simplCore/SimplUtils
+--------------------------------------------------------
+
+-- | 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
+-- e.g case e of b {
+-- ...;
+-- con bs -> rhs;
+-- ... }
+-- ==>
+-- case e' of b' {
+-- ...;
+-- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;
+-- ... }
+
+caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x#
+ | 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) -- x# `op` 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 ) -- op 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))
+
+-- See Note [caseRules for tagToEnum]
+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)))
+
+-- See Note [caseRules for dataToTag]
+caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x
+ | Just DataToTagOp <- isPrimOpId_maybe f
+ = 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 _ _ alt = pprPanic "caseRules" (ppr alt)
+ -- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the
+ -- literal alternatives remain in Word/Int target ranges
+ -- (See Note [Word/Int underflow/overflow] in Literal and #13172).
+
+adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
+-- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x
+adjustDyadicRight op lit
+ = case op of
+ WordAddOp -> Just (\y -> y-lit )
+ IntAddOp -> Just (\y -> y-lit )
+ 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)
+-- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x
+adjustDyadicLeft lit op
+ = case op of
+ WordAddOp -> Just (\y -> y-lit )
+ IntAddOp -> Just (\y -> y-lit )
+ WordSubOp -> Just (\y -> lit-y )
+ IntSubOp -> Just (\y -> lit-y )
+ XorOp -> Just (\y -> y `xor` lit)
+ XorIOp -> Just (\y -> y `xor` lit)
+ _ -> Nothing
+
+
+adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
+-- Given (op x) return a function 'f' s.t. f (op x) = x
+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 -> 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_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]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to transform
+ case tagToEnum x of
+ False -> e1
+ True -> e2
+into
+ case x of
+ 0# -> e1
+ 1# -> e1
+
+This rule eliminates a lot of boilerplate. For
+ if (x>y) then e1 else e2
+we generate
+ case tagToEnum (x ># y) of
+ False -> e2
+ True -> e1
+and it is nice to then get rid of the tagToEnum.
+
+NB: in SimplUtils, where we invoke caseRules,
+ we convert that 0# to DEFAULT
+
+Note [caseRules for dataToTag]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to transform
+ case dataToTag x of
+ DEFAULT -> e1
+ 1# -> e2
+into
+ case x of
+ DEFAULT -> e1
+ (:) _ _ -> e2
+
+Note the need for some wildcard binders in
+the 'cons' case.
+-}
git.haskell.org / ghc.git / blobdiff