PrelRules: Handle Int left shifts of more than word-size bits
[ghc.git] / compiler / prelude / PrelRules.hs
index 919a1d5..810fd2b 100644 (file)
@@ -15,27 +15,34 @@ ToDo:
 {-# 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 )
@@ -48,13 +55,10 @@ import Platform
 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
@@ -118,11 +122,11 @@ 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
@@ -136,7 +140,12 @@ primOpRules nm WordMulOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
 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 ]
@@ -148,8 +157,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
@@ -410,10 +419,10 @@ wordOp2 op dflags (MachWord w1) (MachWord w2)
     = 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
@@ -422,10 +431,16 @@ wordShiftRule shift_op
              | 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
@@ -530,25 +545,15 @@ isMaxBound dflags (MachWord i)   = i == tARGET_MAX_WORD dflags
 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
@@ -647,20 +652,20 @@ instance Applicative RuleM where
     (<*>) = ap
 
 instance Monad RuleM where
-  return = pure
   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
@@ -836,8 +841,6 @@ gtVal = Var gtDataConId
 
 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
@@ -885,13 +888,13 @@ tagToEnumRule = do
   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"
 
 {-
@@ -915,7 +918,7 @@ dataToTagRule = a `mplus` b
       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))
 
 {-
 ************************************************************************
@@ -928,10 +931,9 @@ dataToTagRule = a `mplus` b
 -- 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
@@ -978,15 +980,37 @@ builtinRules :: [CoreRule]
 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 =
@@ -1105,37 +1129,42 @@ 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
 
 
 ---------------------------------------------------
@@ -1170,7 +1199,7 @@ match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
   , 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
@@ -1187,8 +1216,8 @@ match_IntToInteger = match_IntToInteger_unop id
 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"
@@ -1197,8 +1226,8 @@ match_WordToInteger _ _ _ _ = Nothing
 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"
@@ -1207,8 +1236,8 @@ match_Int64ToInteger _ _ _ _ = Nothing
 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"
@@ -1248,8 +1277,8 @@ warning in this case.
 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"
@@ -1270,11 +1299,7 @@ match_Integer_divop_both divop _ id_unf _ [xl,yl]
   , 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
@@ -1342,17 +1367,17 @@ match_rationalTo _ _ _ _ _ = Nothing
 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
@@ -1366,3 +1391,161 @@ match_smallIntegerTo primOp _ _ _ [App (Var x) y]
   | 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.
+-}