Re-engineer caseRules to add tagToEnum/dataToTag

See Note [Scrutinee Constant Folding] in SimplUtils

* Add cases for tagToEnum and dataToTag. This is the main new
  bit.  It allows the simplifier to remove the pervasive uses
  of     case tagToEnum (a > b) of
            False -> e1
            True  -> e2
  and replace it by the simpler
         case a > b of
            DEFAULT -> e1
            1#      -> e2
  See Note [caseRules for tagToEnum]
  and Note [caseRules for dataToTag] in PrelRules.

* This required some changes to the API of caseRules, and hence
  to code in SimplUtils.  See Note [Scrutinee Constant Folding]
  in SimplUtils.

* Avoid duplication of work in the (unusual) case of
     case BIG + 3# of b
       DEFAULT -> e1
       6#      -> e2

  Previously we got
     case BIG of
       DEFAULT -> let b = BIG + 3# in e1
       3#      -> let b = 6#       in e2

  Now we get
     case BIG of b#
       DEFAULT -> let b = b' + 3# in e1
       3#      -> let b = 6#      in e2

* Avoid duplicated code in caseRules

A knock-on refactoring:

* Move Note [Word/Int underflow/overflow] to Literal, as
  documentation to accompany mkMachIntWrap etc; and get
  rid of PrelRuls.intResult' in favour of mkMachIntWrap

7 files changed, 391 insertions, 232 deletions

diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs
index cc53b47833..f14606e8cf 100644
--- a/compiler/basicTypes/Literal.hs
+++ b/compiler/basicTypes/Literal.hs
@@ -222,6 +222,24 @@ instance Ord Literal where
         ~~~~~~~~~~~~
 -}
 
+{- Note [Word/Int underflow/overflow]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and
+unsigned integral types): "All arithmetic is performed modulo 2^n, where n is
+the number of bits in the type."
+
+GHC stores Word# and Int# constant values as Integer. Core optimizations such
+as constant folding must ensure that the Integer value remains in the valid
+target Word/Int range (see #13172). The following functions are used to
+ensure this.
+
+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))
+doesn't yield a warning. Instead we simply squash the value into the *target*
+Int/Word range.
+-}
+
 -- | Creates a 'Literal' of type @Int#@
 mkMachInt :: DynFlags -> Integer -> Literal
 mkMachInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
@@ -229,6 +247,7 @@ mkMachInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
 
 -- | Creates a 'Literal' of type @Int#@.
 --   If the argument is out of the (target-dependent) range, it is wrapped.
+--   See Note [Word/Int underflow/overflow]
 mkMachIntWrap :: DynFlags -> Integer -> Literal
 mkMachIntWrap dflags i
  = MachInt $ case platformWordSize (targetPlatform dflags) of
@@ -243,6 +262,7 @@ mkMachWord dflags x   = ASSERT2( inWordRange dflags x, integer x )
 
 -- | Creates a 'Literal' of type @Word#@.
 --   If the argument is out of the (target-dependent) range, it is wrapped.
+--   See Note [Word/Int underflow/overflow]
 mkMachWordWrap :: DynFlags -> Integer -> Literal
 mkMachWordWrap dflags i
  = MachWord $ case platformWordSize (targetPlatform dflags) of
@@ -336,6 +356,7 @@ isLitValue_maybe _                = Nothing
 -- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For
 -- fixed-size integral literals, the result will be wrapped in
 -- accordance with the semantics of the target type.
+-- See Note [Word/Int underflow/overflow]
 mapLitValue  :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
 mapLitValue _      f (MachChar   c)   = mkMachChar (fchar c)
    where fchar = chr . fromInteger . f . toInteger . ord
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index bee6289ca9..b5e97f7fa7 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -1682,6 +1682,8 @@ ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
 
 cmpAltCon :: AltCon -> AltCon -> Ordering
 -- ^ Compares 'AltCon's within a single list of alternatives
+-- DEFAULT comes out smallest, so that sorting by AltCon
+-- puts alternatives in the order required by #case_invariants#
 cmpAltCon DEFAULT      DEFAULT     = EQ
 cmpAltCon DEFAULT      _           = LT
 
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 5406b0d494..1ef0565ff3 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -35,8 +35,9 @@ 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
@@ -538,51 +539,15 @@ isMaxBound dflags (MachWord i)   = i == tARGET_MAX_WORD dflags
 isMaxBound _      (MachWord64 i) = i == toInteger (maxBound :: Word64)
 isMaxBound _      _              = False
 
-
--- Note [Word/Int underflow/overflow]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and
--- unsigned integral types): "All arithmetic is performed modulo 2^n, where n is
--- the number of bits in the type."
---
--- GHC stores Word# and Int# constant values as Integer. Core optimizations such
--- as constant folding must ensure that the Integer value remains in the valid
--- target Word/Int range (see #13172). The following functions are used to
--- ensure this.
---
--- 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))
--- doesn't yield a warning. Instead we simply squash the value into the *target*
--- Int/Word range.
-
--- | Ensure the given Integer is in the target Int range
-intResult' :: DynFlags -> Integer -> Integer
-intResult' dflags result = case platformWordSize (targetPlatform dflags) of
-   4 -> toInteger (fromInteger result :: Int32)
-   8 -> toInteger (fromInteger result :: Int64)
-   w -> panic ("intResult: Unknown platformWordSize: " ++ show w)
-
--- | Ensure the given Integer is in the target Word range
-wordResult' :: DynFlags -> Integer -> Integer
-wordResult' dflags result = case platformWordSize (targetPlatform dflags) of
-   4 -> toInteger (fromInteger result :: Word32)
-   8 -> toInteger (fromInteger result :: Word64)
-   w -> panic ("wordResult: Unknown platformWordSize: " ++ show w)
-
 -- | 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 (intResult' dflags result))
+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 (wordResult' dflags result))
-
-
-
+wordResult dflags result = Just (Lit (mkMachWordWrap dflags result))
 
 inversePrimOp :: PrimOp -> RuleM CoreExpr
 inversePrimOp primop = do
@@ -872,8 +837,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
@@ -921,7 +884,7 @@ 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
@@ -951,7 +914,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))
 
 {-
 ************************************************************************
@@ -1183,7 +1146,7 @@ match_append_lit _ _ _ _ = Nothing
 
 ---------------------------------------------------
 -- The rule is this:
---      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
+--      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
 
 match_eq_string :: RuleFun
 match_eq_string _ id_unf _
@@ -1432,46 +1395,150 @@ 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 -> Maybe (CoreExpr, Integer -> Integer)
-caseRules dflags scrut = case scrut of
-
-   -- We need to call wordResult' and intResult' to ensure that the literal
-   -- alternatives remain in Word/Int target ranges (cf Note [Word/Int
-   -- underflow/overflow] and #13172).
-
-   -- v `op` x#
-   App (App (Var f) v) (Lit l)
-      | Just op <- isPrimOpId_maybe f
-      , Just x  <- isLitValue_maybe l ->
-      case op of
-         WordAddOp -> Just (v, \y -> wordResult' dflags $ y-x      )
-         IntAddOp  -> Just (v, \y -> intResult'  dflags $ y-x      )
-         WordSubOp -> Just (v, \y -> wordResult' dflags $ y+x      )
-         IntSubOp  -> Just (v, \y -> intResult'  dflags $ y+x      )
-         XorOp     -> Just (v, \y -> wordResult' dflags $ y `xor` x)
-         XorIOp    -> Just (v, \y -> intResult'  dflags $ y `xor` x)
+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) (Var v)) (Lit l)))
+
+
+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
 
-   -- x# `op` v
-   App (App (Var f) (Lit l)) v
-      | Just op <- isPrimOpId_maybe f
-      , Just x  <- isLitValue_maybe l ->
-      case op of
-         WordAddOp -> Just (v, \y -> wordResult' dflags $ y-x      )
-         IntAddOp  -> Just (v, \y -> intResult'  dflags $ y-x      )
-         WordSubOp -> Just (v, \y -> wordResult' dflags $ x-y      )
-         IntSubOp  -> Just (v, \y -> intResult'  dflags $ x-y      )
-         XorOp     -> Just (v, \y -> wordResult' dflags $ y `xor` x)
-         XorIOp    -> Just (v, \y -> intResult'  dflags $ y `xor` x)
+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
 
-   -- op v
-   App (Var f) v
-      | Just op <- isPrimOpId_maybe f ->
-      case op of
-         NotOp     -> Just (v, \y -> wordResult' dflags $ complement y)
-         NotIOp    -> Just (v, \y -> intResult'  dflags $ complement y)
-         IntNegOp  -> Just (v, \y -> intResult'  dflags $ negate y    )
+
+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
 
-   _ -> 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 elimiantes 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.
+-}
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index a2c7b8b855..db754282d5 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -53,7 +53,7 @@ import Demand
 import SimplMonad
 import Type     hiding( substTy )
 import Coercion hiding( substCo )
-import DataCon          ( dataConWorkId )
+import DataCon          ( dataConWorkId, isNullaryRepDataCon )
 import VarEnv
 import VarSet
 import BasicTypes
@@ -62,7 +62,7 @@ import MonadUtils
 import Outputable
 import Pair
 import PrelRules
-import Literal
+import FastString       ( fsLit )
 
 import Control.Monad    ( when )
 import Data.List        ( sortBy )
@@ -1779,8 +1779,12 @@ prepareAlts scrut case_bndr' alts
 
 mkCase tries these things
 
-1.  Merge Nested Cases
+* Note [Nerge nested cases]
+* Note [Elimiante identity case]
+* Note [Scrutinee constant folding]
 
+Note [Merge Nested Cases]
+~~~~~~~~~~~~~~~~~~~~~~~~~
        case e of b {             ==>   case e of b {
          p1 -> rhs1                      p1 -> rhs1
          ...                             ...
@@ -1792,21 +1796,21 @@ mkCase tries these things
                      _  -> rhsd
        }
 
-    which merges two cases in one case when -- the default alternative of
-    the outer case scrutises the same variable as the outer case. This
-    transformation is called Case Merging.  It avoids that the same
-    variable is scrutinised multiple times.
-
-2.  Eliminate Identity Case
+which merges two cases in one case when -- the default alternative of
+the outer case scrutises the same variable as the outer case. This
+transformation is called Case Merging.  It avoids that the same
+variable is scrutinised multiple times.
 
+Note [Eliminate Identity Case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         case e of               ===> e
                 True  -> True;
                 False -> False
 
-    and similar friends.
-
-3.  Scrutinee Constant Folding
+and similar friends.
 
+Note [Scrutinee Constant Folding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      case x op# k# of _ {  ===> case x of _ {
         a1# -> e1                  (a1# inv_op# k#) -> e1
         a2# -> e2                  (a2# inv_op# k#) -> e2
@@ -1815,32 +1819,66 @@ mkCase tries these things
 
      where (x op# k#) inv_op# k# == x
 
-    And similarly for commuted arguments and for some unary operations.
-
-    The purpose of this transformation is not only to avoid an arithmetic
-    operation at runtime but to allow other transformations to apply in cascade.
-
-    Example with the "Merge Nested Cases" optimization (from #12877):
-
-          main = case t of t0
-             0##     -> ...
-             DEFAULT -> case t0 `minusWord#` 1## of t1
-                0##    -> ...
-                DEFAUT -> case t1 `minusWord#` 1## of t2
-                   0##     -> ...
-                   DEFAULT -> case t2 `minusWord#` 1## of _
-                      0##     -> ...
-                      DEFAULT -> ...
-
-      becomes:
-
-          main = case t of _
-          0##     -> ...
-          1##     -> ...
-          2##     -> ...
-          3##     -> ...
-          DEFAULT -> ...
-
+And similarly for commuted arguments and for some unary operations.
+
+The purpose of this transformation is not only to avoid an arithmetic
+operation at runtime but to allow other transformations to apply in cascade.
+
+Example with the "Merge Nested Cases" optimization (from #12877):
+
+      main = case t of t0
+         0##     -> ...
+         DEFAULT -> case t0 `minusWord#` 1## of t1
+            0##    -> ...
+            DEFAUT -> case t1 `minusWord#` 1## of t2
+               0##     -> ...
+               DEFAULT -> case t2 `minusWord#` 1## of _
+                  0##     -> ...
+                  DEFAULT -> ...
+
+  becomes:
+
+      main = case t of _
+      0##     -> ...
+      1##     -> ...
+      2##     -> ...
+      3##     -> ...
+      DEFAULT -> ...
+
+There are some wrinkles
+
+* Do not apply caseRules if there is just a single DEFAULT alternative
+     case e +# 3# of b { DEFAULT -> rhs }
+  If we applied the transformation here we would (stupidly) get
+     case a of b' { DEFAULT -> let b = e +# 3# in rhs }
+  and now the process may repeat, because that let will really
+  be a case.
+
+* The type of the scrutinee might change.  E.g.
+        case tagToEnum (x :: Int#) of (b::Bool)
+          False -> e1
+          True -> e2
+  ==>
+        case x of (b'::Int#)
+          DEFAULT -> e1
+          1#      -> e2
+
+* The case binder may be used in the right hand sides, so we need
+  to make a local binding for it, if it is alive.  e.g.
+         case e +# 10# of b
+           DEFAULT -> blah...b...
+           44#     -> blah2...b...
+  ===>
+         case e of b'
+           DEFAULT -> let b = b' +# 10# in blah...b...
+           34#     -> let b = 44# in blah2...b...
+
+  Note that in the non-DEFAULT cases we know what to bind 'b' to,
+  whereas in the DEFAULT case we must reconstruct the original value.
+  But NB: we use b'; we do not duplicate 'e'.
+
+* In dataToTag we might need to make up some fake binders;
+  see Note [caseRules for dataToTag] in PrelRules
 -}
 
 mkCase, mkCase1, mkCase2, mkCase3
@@ -1941,9 +1979,18 @@ mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
 --------------------------------------------------
 
 mkCase2 dflags scrut bndr alts_ty alts
-  | gopt Opt_CaseFolding dflags
-  , Just (scrut',f) <- caseRules dflags scrut
-  = mkCase3 dflags scrut' bndr alts_ty (new_alts f)
+  | -- See Note [Scrutinee Constant Folding]
+    case alts of  -- Not if there is just a DEFAULT alterantive
+      [(DEFAULT,_,_)] -> False
+      _               -> True
+  , gopt Opt_CaseFolding dflags
+  , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut
+  = do { bndr' <- newId (fsLit "lwild") (exprType scrut')
+       ; alts' <- mapM  (tx_alt tx_con mk_orig bndr') alts
+       ; mkCase3 dflags scrut' bndr' alts_ty $
+         add_default (re_sort alts')
+       }
+
   | otherwise
   = mkCase3 dflags scrut bndr alts_ty alts
   where
@@ -1959,19 +2006,41 @@ mkCase2 dflags scrut bndr alts_ty alts
     --                                      10      -> let y = 20      in e1
     --                                      DEFAULT -> let y = y' + 10 in e2
     --
-    wrap_rhs l rhs
-      | isDeadBinder bndr = rhs
-      | otherwise         = Let (NonRec bndr l) rhs
-
-    -- We need to re-sort the alternatives to preserve the #case_invariants#
-    new_alts f = sortBy cmpAlt (map (mapAlt f) alts)
-
-    mapAlt f alt@(c,bs,e) = case c of
-      DEFAULT          -> (c, bs, wrap_rhs scrut e)
-      LitAlt l
-        | isLitValue l -> (LitAlt (mapLitValue dflags f l),
-                           bs, wrap_rhs (Lit l) e)
-      _ -> pprPanic "Unexpected alternative (mkCase2)" (ppr alt)
+    -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules,
+    -- to construct an expression equivalent to the original one, for use
+    -- in the DEFAULT case
+
+    tx_alt tx_con mk_orig new_bndr (con, bs, rhs)
+      | DataAlt dc <- con', not (isNullaryRepDataCon dc)
+      = -- For non-nullary data cons we must invent some fake binders
+        -- See Note [caseRules for dataToTag] in PrelRules
+        do { us <- getUniquesM
+           ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc
+                                         (tyConAppArgs (idType new_bndr))
+           ; return (con', ex_tvs ++ arg_ids, rhs') }
+      | otherwise
+      = return (con', [], rhs')
+      where
+        con' = tx_con con
+
+        rhs' | isDeadBinder bndr = rhs
+             | otherwise         = bindNonRec bndr orig_val rhs
+
+        orig_val = case con of
+                      DEFAULT    -> mk_orig new_bndr
+                      LitAlt l   -> Lit l
+                      DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs
+
+
+    re_sort :: [CoreAlt] -> [CoreAlt]  -- Re-sort the alternatives to
+    re_sort alts = sortBy cmpAlt alts  -- preserve the #case_invariants#
+
+    add_default :: [CoreAlt] -> [CoreAlt]
+    -- TagToEnum may change a boolean True/False set of alternatives
+    -- to LitAlt 0#/1# alterantives.  But literal alternatives always
+    -- have a DEFAULT (I think).  So add it.
+    add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts
+    add_default alts                          = alts
 
 --------------------------------------------------
 --      Catch-all
diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout
index 44aee7b69e..a4ab97da38 100644
--- a/testsuite/tests/simplCore/should_compile/T3772.stdout
+++ b/testsuite/tests/simplCore/should_compile/T3772.stdout
@@ -1,7 +1,7 @@
 
 ==================== Tidy Core ====================
 Result size of Tidy Core
-  = {terms: 44, types: 19, coercions: 0, joins: 0/0}
+  = {terms: 43, types: 18, coercions: 0, joins: 0/0}
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 T3772.$trModule4 :: GHC.Prim.Addr#
@@ -59,14 +59,14 @@ $wxs
       }
 end Rec }
 
--- RHS size: {terms: 11, types: 3, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0}
 T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> ()
 [GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>]
 T3772.$wfoo
   = \ (ww :: GHC.Prim.Int#) ->
-      case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# 0# ww) of {
-        False -> GHC.Tuple.();
-        True -> $wxs ww
+      case GHC.Prim.<# 0# ww of {
+        __DEFAULT -> GHC.Tuple.();
+        1# -> $wxs ww
       }
 
 -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index 9db97a5e1f..4d569485b3 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -1,7 +1,7 @@
 
 ==================== Tidy Core ====================
 Result size of Tidy Core
-  = {terms: 44, types: 17, coercions: 0, joins: 0/0}
+  = {terms: 43, types: 16, coercions: 0, joins: 0/0}
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 T4930.$trModule4 :: GHC.Prim.Addr#
@@ -44,20 +44,20 @@ T4930.$trModule :: GHC.Types.Module
  Str=m,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-T4930.$trModule =
-  GHC.Types.Module T4930.$trModule3 T4930.$trModule1
+T4930.$trModule
+  = GHC.Types.Module T4930.$trModule3 T4930.$trModule1
 
 Rec {
--- RHS size: {terms: 18, types: 4, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 17, types: 3, coercions: 0, joins: 0/0}
 T4930.$wfoo [InlPrag=[0], Occ=LoopBreaker]
   :: GHC.Prim.Int# -> GHC.Prim.Int#
 [GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>]
-T4930.$wfoo =
-  \ (ww :: GHC.Prim.Int#) ->
-    case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# ww 5#) of {
-      False -> GHC.Prim.+# ww 5#;
-      True -> case T4930.$wfoo ww of { __DEFAULT -> GHC.Prim.+# ww 5# }
-    }
+T4930.$wfoo
+  = \ (ww :: GHC.Prim.Int#) ->
+      case GHC.Prim.<# ww 5# of {
+        __DEFAULT -> GHC.Prim.+# ww 5#;
+        1# -> case T4930.$wfoo ww of { __DEFAULT -> GHC.Prim.+# ww 5# }
+      }
 end Rec }
 
 -- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0}
@@ -73,11 +73,11 @@ foo [InlPrag=INLINE[0]] :: Int -> Int
                  case w of { GHC.Types.I# ww1 [Occ=Once] ->
                  case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
                  }}]
-foo =
-  \ (w :: Int) ->
-    case w of { GHC.Types.I# ww1 ->
-    case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
-    }
+foo
+  = \ (w :: Int) ->
+      case w of { GHC.Types.I# ww1 ->
+      case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
+      }
 
 
 
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index dda28c8926..53b315dc9c 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -1,7 +1,7 @@
 
 ==================== Tidy Core ====================
 Result size of Tidy Core
-  = {terms: 178, types: 68, coercions: 0, joins: 0/2}
+  = {terms: 172, types: 62, coercions: 0, joins: 0/2}
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 Roman.$trModule4 :: GHC.Prim.Addr#
@@ -44,8 +44,8 @@ Roman.$trModule :: GHC.Types.Module
  Str=m,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-Roman.$trModule =
-  GHC.Types.Module Roman.$trModule3 Roman.$trModule1
+Roman.$trModule
+  = GHC.Types.Module Roman.$trModule3 Roman.$trModule1
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 lvl :: GHC.Prim.Addr#
@@ -55,83 +55,83 @@ lvl = "spec-inline.hs:(19,5)-(29,25)|function go"#
 -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0}
 Roman.foo3 :: Int
 [GblId, Str=x]
-Roman.foo3 =
-  Control.Exception.Base.patError @ 'GHC.Types.LiftedRep @ Int lvl
+Roman.foo3
+  = Control.Exception.Base.patError @ 'GHC.Types.LiftedRep @ Int lvl
 
 Rec {
--- RHS size: {terms: 55, types: 9, coercions: 0, joins: 0/1}
+-- RHS size: {terms: 52, types: 6, coercions: 0, joins: 0/1}
 Roman.foo_$s$wgo [Occ=LoopBreaker]
   :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int#
 [GblId, Arity=2, Caf=NoCafRefs, Str=<S,U><S,U>]
-Roman.foo_$s$wgo =
-  \ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) ->
-    let {
-      m :: GHC.Prim.Int#
-      [LclId]
-      m =
-        GHC.Prim.+#
-          (GHC.Prim.+#
-             (GHC.Prim.+#
-                (GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# sc sc) sc) sc) sc)
-             sc)
-          sc } in
-    case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# sc1 0#) of {
-      False ->
-        case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc1 100#) of {
-          False ->
-            case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# sc1 500#) of {
-              False -> Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# sc1 1#);
-              True -> Roman.foo_$s$wgo m (GHC.Prim.-# sc1 3#)
-            };
-          True -> Roman.foo_$s$wgo sc (GHC.Prim.-# sc1 2#)
-        };
-      True -> 0#
-    }
+Roman.foo_$s$wgo
+  = \ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) ->
+      let {
+        m :: GHC.Prim.Int#
+        [LclId]
+        m = GHC.Prim.+#
+              (GHC.Prim.+#
+                 (GHC.Prim.+#
+                    (GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# sc sc) sc) sc) sc)
+                 sc)
+              sc } in
+      case GHC.Prim.<=# sc1 0# of {
+        __DEFAULT ->
+          case GHC.Prim.<# sc1 100# of {
+            __DEFAULT ->
+              case GHC.Prim.<# sc1 500# of {
+                __DEFAULT ->
+                  Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# sc1 1#);
+                1# -> Roman.foo_$s$wgo m (GHC.Prim.-# sc1 3#)
+              };
+            1# -> Roman.foo_$s$wgo sc (GHC.Prim.-# sc1 2#)
+          };
+        1# -> 0#
+      }
 end Rec }
 
--- RHS size: {terms: 74, types: 22, coercions: 0, joins: 0/1}
+-- RHS size: {terms: 71, types: 19, coercions: 0, joins: 0/1}
 Roman.$wgo [InlPrag=[0]] :: Maybe Int -> Maybe Int -> GHC.Prim.Int#
 [GblId,
  Arity=2,
  Str=<S,1*U><S,1*U>,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 30] 256 0}]
-Roman.$wgo =
-  \ (w :: Maybe Int) (w1 :: Maybe Int) ->
-    case w1 of {
-      Nothing -> case Roman.foo3 of wild1 { };
-      Just x ->
-        case x of { GHC.Types.I# ipv ->
-        let {
-          m :: GHC.Prim.Int#
-          [LclId]
-          m =
-            GHC.Prim.+#
-              (GHC.Prim.+#
-                 (GHC.Prim.+#
-                    (GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# ipv ipv) ipv) ipv) ipv)
-                 ipv)
-              ipv } in
-        case w of {
-          Nothing -> Roman.foo_$s$wgo m 10#;
-          Just n ->
-            case n of { GHC.Types.I# x2 ->
-            case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<=# x2 0#) of {
-              False ->
-                case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 100#) of {
-                  False ->
-                    case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# x2 500#) of {
-                      False -> Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# x2 1#);
-                      True -> Roman.foo_$s$wgo m (GHC.Prim.-# x2 3#)
-                    };
-                  True -> Roman.foo_$s$wgo ipv (GHC.Prim.-# x2 2#)
-                };
-              True -> 0#
-            }
-            }
-        }
-        }
-    }
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 30] 253 0}]
+Roman.$wgo
+  = \ (w :: Maybe Int) (w1 :: Maybe Int) ->
+      case w1 of {
+        Nothing -> case Roman.foo3 of wild1 { };
+        Just x ->
+          case x of { GHC.Types.I# ipv ->
+          let {
+            m :: GHC.Prim.Int#
+            [LclId]
+            m = GHC.Prim.+#
+                  (GHC.Prim.+#
+                     (GHC.Prim.+#
+                        (GHC.Prim.+# (GHC.Prim.+# (GHC.Prim.+# ipv ipv) ipv) ipv) ipv)
+                     ipv)
+                  ipv } in
+          case w of {
+            Nothing -> Roman.foo_$s$wgo m 10#;
+            Just n ->
+              case n of { GHC.Types.I# x2 ->
+              case GHC.Prim.<=# x2 0# of {
+                __DEFAULT ->
+                  case GHC.Prim.<# x2 100# of {
+                    __DEFAULT ->
+                      case GHC.Prim.<# x2 500# of {
+                        __DEFAULT ->
+                          Roman.foo_$s$wgo (GHC.Prim.+# m m) (GHC.Prim.-# x2 1#);
+                        1# -> Roman.foo_$s$wgo m (GHC.Prim.-# x2 3#)
+                      };
+                    1# -> Roman.foo_$s$wgo ipv (GHC.Prim.-# x2 2#)
+                  };
+                1# -> 0#
+              }
+              }
+          }
+          }
+      }
 
 -- RHS size: {terms: 9, types: 5, coercions: 0, joins: 0/0}
 Roman.foo_go [InlPrag=INLINE[0]] :: Maybe Int -> Maybe Int -> Int
@@ -143,9 +143,9 @@ Roman.foo_go [InlPrag=INLINE[0]] :: Maybe Int -> Maybe Int -> Int
          Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
          Tmpl= \ (w [Occ=Once] :: Maybe Int) (w1 [Occ=Once] :: Maybe Int) ->
                  case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }}]
-Roman.foo_go =
-  \ (w :: Maybe Int) (w1 :: Maybe Int) ->
-    case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }
+Roman.foo_go
+  = \ (w :: Maybe Int) (w1 :: Maybe Int) ->
+      case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww }
 
 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
 Roman.foo2 :: Int
@@ -178,11 +178,11 @@ foo :: Int -> Int
                  case n of n1 { GHC.Types.I# _ [Occ=Dead] ->
                  Roman.foo_go (GHC.Base.Just @ Int n1) Roman.foo1
                  }}]
-foo =
-  \ (n :: Int) ->
-    case n of { GHC.Types.I# ipv ->
-    case Roman.foo_$s$wgo 6# ipv of ww { __DEFAULT -> GHC.Types.I# ww }
-    }
+foo
+  = \ (n :: Int) ->
+      case n of { GHC.Types.I# ipv ->
+      case Roman.foo_$s$wgo 6# ipv of ww { __DEFAULT -> GHC.Types.I# ww }
+      }
 
 
 ------ Local rules for imported ids --------