Make constructor wrappers inline only during the final phase

For case-of-known constructor to continue triggering early,
exprIsConApp_maybe is now capable of looking through lets and cases.

See #15840

14 files changed, 289 insertions, 61 deletions

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 5e91d26c2f..01b648ee89 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -66,7 +66,8 @@ module Id (
         isClassOpId_maybe, isDFunId,
         isPrimOpId, isPrimOpId_maybe,
         isFCallId, isFCallId_maybe,
-        isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
+        isDataConWorkId, isDataConWorkId_maybe, isDataConWrapId, isDataConId_maybe,
+        idDataCon,
         isConLikeId, isBottomingId, idIsFrom,
         hasNoBinding,
 
@@ -419,6 +420,7 @@ isDataConRecordSelector  :: Id -> Bool
 isPrimOpId              :: Id -> Bool
 isFCallId               :: Id -> Bool
 isDataConWorkId         :: Id -> Bool
+isDataConWrapId         :: Id -> Bool
 isDFunId                :: Id -> Bool
 
 isClassOpId_maybe       :: Id -> Maybe Class
@@ -474,6 +476,10 @@ isDataConWorkId_maybe id = case Var.idDetails id of
                         DataConWorkId con -> Just con
                         _                 -> Nothing
 
+isDataConWrapId id = case Var.idDetails id of
+                       DataConWrapId _ -> True
+                       _               -> False
+
 isDataConId_maybe :: Id -> Maybe DataCon
 isDataConId_maybe id = case Var.idDetails id of
                          DataConWorkId con -> Just con
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 616454ff7e..98ff0b0c3d 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -409,8 +409,8 @@ dictSelRule :: Int -> Arity -> RuleFun
 --
 dictSelRule val_index n_ty_args _ id_unf _ args
   | (dict_arg : _) <- drop n_ty_args args
-  , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
-  = Just (getNth con_args val_index)
+  , Just (floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
+  = Just (wrapFloats floats $ getNth con_args val_index)
   | otherwise
   = Nothing
 
@@ -596,7 +596,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
                         | otherwise           = topDmd
 
              wrap_prag = alwaysInlinePragma `setInlinePragmaActivation`
-                         activeAfterInitial
+                         activeDuringFinal
                          -- See Note [Activation for data constructor wrappers]
 
              -- The wrapper will usually be inlined (see wrap_unf), so its
@@ -706,16 +706,24 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
 
 {- Note [Activation for data constructor wrappers]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The Activation on a data constructor wrapper allows it to inline in
-Phase 2 and later (1, 0).  But not in the InitialPhase.  That gives
-rewrite rules a chance to fire (in the InitialPhase) if they mention
-a data constructor on the left
+The Activation on a data constructor wrapper allows it to inline only in Phase
+0. This way rules have a chance to fire if they mention a data constructor on
+the left
    RULE "foo"  f (K a b) = ...
 Since the LHS of rules are simplified with InitialPhase, we won't
 inline the wrapper on the LHS either.
 
-People have asked for this before, but now that even the InitialPhase
-does some inlining, it has become important.
+On the other hand, this means that exprIsConApp_maybe must be able to deal
+with wrappers so that case-of-constructor is not delayed; see
+Note [exprIsConApp_maybe on data constructors with wrappers] for details.
+
+It used to activate in phases 2 (afterInitial) and later, but it makes it
+awkward to write a RULE[1] with a constructor on the left: it would work if a
+constructor has no wrapper, but whether a constructor has a wrapper depends, for
+instance, on the order of type argument of that constructors. Therefore changing
+the order of type argument could make previously working RULEs fail.
+
+See also https://ghc.haskell.org/trac/ghc/ticket/15840 .
 
 
 Note [Bangs on imported data constructors]
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index ca82d9ab23..dc74acf8f0 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -28,6 +28,7 @@ import CoreSyn
 import CoreSubst
 import CoreUtils
 import CoreFVs
+import MkCore ( FloatBind(..) )
 import PprCore  ( pprCoreBindings, pprRules )
 import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
 import Literal  ( Literal(LitString) )
@@ -231,7 +232,8 @@ simple_opt_expr env expr
     go (Case e b ty as)
        -- See Note [Getting the map/coerce RULE to work]
       | isDeadBinder b
-      , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
+      , Just ([], con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
+        -- We don't need to be concerned about floats when looking for coerce.
       , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
       = case altcon of
           DEFAULT -> go rhs
@@ -756,52 +758,153 @@ To get this to come out we need to simplify on the fly
    ((/\a b. K e1 e2) |> g) @t1 @t2
 
 Hence the use of pushCoArgs.
+
+Note [exprIsConApp_maybe on data constructors with wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem:
+- some data constructors have wrappers
+- these wrappers inline late (see MkId Note [Activation for data constructor wrappers])
+- but we still want case-of-known-constructor to fire early.
+
+Example:
+   data T = MkT !Int
+   $WMkT n = case n of n' -> MkT n'   -- Wrapper for MkT
+   foo x = case $WMkT e of MkT y -> blah
+
+Here we want the case-of-known-constructor transformation to fire, giving
+   foo x = case e of x' -> let y = x' in blah
+
+Here's how exprIsConApp_maybe achieves this:
+
+0.  Start with scrutinee = $WMkT e
+
+1.  Inline $WMkT on-the-fly.  That's why data-constructor wrappers are marked
+    as expandable. (See CoreUtils.isExpandableApp.) Now we have
+      scrutinee = (\n. case n of n' -> MkT n') e
+
+2.  Beta-reduce the application, generating a floated 'let'.
+    See Note [beta-reduction in exprIsConApp_maybe] below.  Now we have
+      scrutinee = case n of n' -> MkT n'
+      with floats {Let n = e}
+
+3.  Float the "case x of x' ->" binding out.  Now we have
+      scrutinee = MkT n'
+      with floats {Let n = e; case n of n' ->}
+
+And now we have a known-constructor MkT that we can return.
+
+Notice that both (2) and (3) require exprIsConApp_maybe to gather and return
+a bunch of floats, both let and case bindings.
+
+Note [beta-reduction in exprIsConApp_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is
+typically a function. For instance, take the wrapper for MkT in Note
+[exprIsConApp_maybe on data constructors with wrappers]:
+
+    $WMkT n = case n of { n' -> T n' }
+
+If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT,
+it will see
+
+   (\n -> case n of { n' -> T n' }) arg
+
+In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction.
+
+We don't want to blindly substitute `arg` in the body of the function, because
+it duplicates work. We can (and, in fact, used to) substitute `arg` in the body,
+but only when `arg` is a variable (or something equally work-free).
+
+But, because of Note [exprIsConApp_maybe on data constructors with wrappers],
+'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce
+_always_:
+
+    (\x -> body) arg
+
+Is transformed into
+
+   let x = arg in body
+
+Which, effectively, means emitting a float `let x = arg` and recursively
+analysing the body.
+
 -}
 
 data ConCont = CC [CoreExpr] Coercion
                   -- Substitution already applied
 
--- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
--- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
--- where t1..tk are the *universally-quantified* type args of 'dc'
-exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
+-- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument
+-- expression is a *saturated* constructor application of the form @let b1 in
+-- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the
+-- *universally-quantified* type args of 'dc'. Floats can also be (and most
+-- likely are) single-alternative case expressions. Why does
+-- 'exprIsConApp_maybe' return floats? We may have to look through lets and
+-- cases to detect that we are in the presence of a data constructor wrapper. In
+-- this case, we need to return the lets and cases that we traversed. See Note
+-- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers
+-- are unfolded late, but we really want to trigger case-of-known-constructor as
+-- early as possible. See also Note [Activation for data constructor wrappers]
+-- in MkId.
+exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe ([FloatBind], DataCon, [Type], [CoreExpr])
 exprIsConApp_maybe (in_scope, id_unf) expr
-  = go (Left in_scope) expr (CC [] (mkRepReflCo (exprType expr)))
+  = do
+    (floats, con, ty, args) <- go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr)))
+    return $ (reverse floats, con, ty, args)
   where
     go :: Either InScopeSet Subst
              -- Left in-scope  means "empty substitution"
              -- Right subst    means "apply this substitution to the CoreExpr"
-       -> CoreExpr -> ConCont
-       -> Maybe (DataCon, [Type], [CoreExpr])
-    go subst (Tick t expr) cont
-       | not (tickishIsCode t) = go subst expr cont
-    go subst (Cast expr co1) (CC args co2)
+       -> [FloatBind] -> CoreExpr -> ConCont
+             -- Notice that the floats here are in reverse order
+       -> Maybe ([FloatBind], DataCon, [Type], [CoreExpr])
+    go subst floats (Tick t expr) cont
+       | not (tickishIsCode t) = go subst floats expr cont
+    go subst floats (Cast expr co1) (CC args co2)
        | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args
             -- See Note [Push coercions in exprIsConApp_maybe]
        = case m_co1' of
-           MCo co1' -> go subst expr (CC args' (co1' `mkTransCo` co2))
-           MRefl    -> go subst expr (CC args' co2)
-    go subst (App fun arg) (CC args co)
-       = go subst fun (CC (subst_arg subst arg : args) co)
-    go subst (Lam var body) (CC (arg:args) co)
+           MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2))
+           MRefl    -> go subst floats expr (CC args' co2)
+    go subst floats (App fun arg) (CC args co)
+       = go subst floats fun (CC (subst_arg subst arg : args) co)
+    go subst floats (Lam var body) (CC (arg:args) co)
        | exprIsTrivial arg          -- Don't duplicate stuff!
-       = go (extend subst var arg) body (CC args co)
-    go (Right sub) (Var v) cont
+       = go (extend subst var arg) floats body (CC args co)
+    go subst floats (Let bndr@(NonRec b _) expr) cont
+       = let (subst', bndr') = subst_bind subst bndr in
+           go subst' (FloatLet bndr' : floats) expr cont
+    go subst floats (Case scrut b _ [(con, vars, expr)]) cont
+       = let
+          (subst', b') = subst_bndr subst b
+          (subst'', vars') = subst_bndrs subst' vars
+         in
+           go subst'' (FloatCase (subst_arg subst scrut) b' con vars' : floats) expr cont
+    go (Right sub) floats (Var v) cont
        = go (Left (substInScope sub))
+            floats
             (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v)
             cont
 
-    go (Left in_scope) (Var fun) cont@(CC args co)
+    go (Left in_scope) floats (Var fun) cont@(CC args co)
 
         | Just con <- isDataConWorkId_maybe fun
         , count isValArg args == idArity fun
-        = pushCoDataCon con args co
+        = pushFloats floats $ pushCoDataCon con args co
+
+        -- Look through data constructor wrappers: they inline late (See Note
+        -- [Activation for data constructor wrappers]) but we want to do
+        -- case-of-known-constructor optimisation eagerly.
+        | isDataConWrapId fun
+        , let rhs = uf_tmpl (realIdUnfolding fun)
+        = go (Left in_scope) floats rhs cont
 
         -- Look through dictionary functions; see Note [Unfolding DFuns]
         | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding
         , bndrs `equalLength` args    -- See Note [DFun arity check]
         , let subst = mkOpenSubst in_scope (bndrs `zip` args)
-        = pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co
+        = pushFloats floats $
+          pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co
 
         -- Look through unfoldings, but only arity-zero one;
         -- if arity > 0 we are effectively inlining a function call,
@@ -811,18 +914,23 @@ exprIsConApp_maybe (in_scope, id_unf) expr
         | idArity fun == 0
         , Just rhs <- expandUnfolding_maybe unfolding
         , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)
-        = go (Left in_scope') rhs cont
+        = go (Left in_scope') floats rhs cont
 
         -- See Note [exprIsConApp_maybe on literal strings]
         | (fun `hasKey` unpackCStringIdKey) ||
           (fun `hasKey` unpackCStringUtf8IdKey)
-        , [arg]                <- args
+        , [arg]              <- args
         , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg
-        = dealWithStringLiteral fun str co
+        = pushFloats floats $ dealWithStringLiteral fun str co
         where
           unfolding = id_unf fun
 
-    go _ _ _ = Nothing
+    go _ _ _ _ = Nothing
+
+    pushFloats :: [FloatBind] -> Maybe (DataCon, [Type], [CoreExpr]) -> Maybe ([FloatBind], DataCon, [Type], [CoreExpr])
+    pushFloats floats x = do
+      (c, tys, args) <- x
+      return (floats, c, tys, args)
 
     ----------------------------
     -- Operations on the (Either InScopeSet CoreSubst)
@@ -833,6 +941,22 @@ exprIsConApp_maybe (in_scope, id_unf) expr
     subst_arg (Left {}) e = e
     subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e
 
+    subst_bind (Left in_scope) bndr@(NonRec b _) =
+      (Left (extendInScopeSet in_scope b), bndr)
+    subst_bind (Left _) _ =
+      error "CoreOpt.exprIsConApp_maybe: recursive float."
+    subst_bind (Right subst) bndr =
+      let (subst', bndr') = substBind subst bndr in
+      (Right subst', bndr')
+
+    subst_bndr (Left in_scope) b =
+      (Left (extendInScopeSet in_scope b), b)
+    subst_bndr (Right subst) b =
+      let (subst', b') = substBndr subst b in
+      (Right subst', b')
+
+    subst_bndrs subst bs = mapAccumL subst_bndr subst bs
+
     extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
     extend (Right s)       v e = Right (extendSubst s v e)
 
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 8de684bced..1583c59148 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -17,7 +17,7 @@ module MkCore (
         mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,
 
         -- * Floats
-        FloatBind(..), wrapFloat,
+        FloatBind(..), wrapFloat, wrapFloats, floatBindings,
 
         -- * Constructing small tuples
         mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup,
@@ -560,6 +560,19 @@ wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
 wrapFloat (FloatLet defns)       body = Let defns body
 wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
 
+-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn]
+-- u = let b1 in let b2 in … in let bn in u@
+wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr
+wrapFloats floats expr = foldr wrapFloat expr floats
+
+bindBindings :: CoreBind -> [Var]
+bindBindings (NonRec b _) = [b]
+bindBindings (Rec bnds) = map fst bnds
+
+floatBindings :: FloatBind -> [Var]
+floatBindings (FloatLet bnd) = bindBindings bnd
+floatBindings (FloatCase _ b _ bs) = b:bs
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 7111c7b07a..a6d7bcc425 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -1039,9 +1039,9 @@ dataToTagRule = a `mplus` b
       dflags <- getDynFlags
       [_, val_arg] <- getArgs
       in_scope <- getInScopeEnv
-      (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
+      (floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
       ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
-      return $ mkIntVal dflags (toInteger (dataConTagZ dc))
+      return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))
 
 {- Note [dataToTag# magic]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs
index e8c7ef2460..07f05493eb 100644
--- a/compiler/simplCore/FloatIn.hs
+++ b/compiler/simplCore/FloatIn.hs
@@ -22,7 +22,7 @@ module FloatIn ( floatInwards ) where
 import GhcPrelude
 
 import CoreSyn
-import MkCore
+import MkCore hiding    ( wrapFloats )
 import HscTypes         ( ModGuts(..) )
 import CoreUtils
 import CoreFVs
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 8418ce1c7d..2bb177d25b 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -22,7 +22,8 @@ import FamInstEnv       ( FamInstEnv )
 import Literal          ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326
 import Id
 import MkId             ( seqId )
-import MkCore           ( mkImpossibleExpr, castBottomExpr )
+import MkCore           ( FloatBind, mkImpossibleExpr, castBottomExpr )
+import qualified MkCore as MkCore
 import IdInfo
 import Name             ( mkSystemVarName, isExternalName, getOccFS )
 import Coercion hiding  ( substCo, substCoVar )
@@ -2354,6 +2355,26 @@ Why don't we drop the case?  Because it's strict in v.  It's technically
 wrong to drop even unnecessary evaluations, and in practice they
 may be a result of 'seq' so we *definitely* don't want to drop those.
 I don't really know how to improve this situation.
+
+
+Note [FloatBinds from constructor wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have FloatBinds coming from the constructor wrapper
+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),
+ew cannot float past them. We'd need to float the FloatBind
+together with the simplify floats, unfortunately the
+simplifier doesn't have case-floats. The simplest thing we can
+do is to wrap all the floats here. The next iteration of the
+simplifier will take care of all these cases and lets.
+
+Given data T = MkT !Bool, this allows us to simplify
+case $WMkT b of { MkT x -> f x }
+to
+case b of { b' -> f b' }.
+
+We could try and be more clever (like maybe wfloats only contain
+let binders, so we could float them). But the need for the
+extra complication is not clear.
 -}
 
 ---------------------------------------------------------
@@ -2378,25 +2399,36 @@ rebuildCase env scrut case_bndr alts cont
   = do  { tick (KnownBranch case_bndr)
         ; case findAlt (LitAlt lit) alts of
             Nothing           -> missingAlt env case_bndr alts cont
-            Just (_, bs, rhs) -> simple_rhs bs rhs }
+            Just (_, bs, rhs) -> simple_rhs [] scrut bs rhs }
 
-  | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
+  | Just (wfloats, con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
         -- Works when the scrutinee is a variable with a known unfolding
         -- as well as when it's an explicit constructor application
   = do  { tick (KnownBranch case_bndr)
         ; case findAlt (DataAlt con) alts of
             Nothing  -> missingAlt env case_bndr alts cont
-            Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
-            Just (_, bs, rhs)       -> knownCon env scrut con ty_args other_args
+            Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con)
+                                                 `mkTyApps` ty_args
+                                                 `mkApps`   other_args
+                                       in simple_rhs wfloats con_app bs rhs
+            Just (_, bs, rhs)       -> knownCon env scrut wfloats con ty_args other_args
                                                 case_bndr bs rhs cont
         }
   where
-    simple_rhs bs rhs = ASSERT( null bs )
-                        do { (floats1, env') <- simplNonRecX env case_bndr scrut
-                               -- scrut is a constructor application,
-                               -- hence satisfies let/app invariant
-                           ; (floats2, expr') <- simplExprF env' rhs cont
-                           ; return (floats1 `addFloats` floats2, expr') }
+    simple_rhs wfloats scrut' bs rhs =
+      ASSERT( null bs )
+      do { let env0 = addNewInScopeIds env (concatMap MkCore.floatBindings wfloats)
+         ; (floats1, env') <- simplNonRecX env0 case_bndr scrut'
+             -- scrut is a constructor application,
+             -- hence satisfies let/app invariant
+         ; (floats2, expr') <- simplExprF env' rhs cont
+         ; case wfloats of
+             [] -> return (floats1 `addFloats` floats2, expr')
+             _ -> return
+               -- See Note [FloatBinds from constructor wrappers]
+                   ( emptyFloats env,
+                     MkCore.wrapFloats wfloats $
+                     wrapFloats (floats1 `addFloats` floats2) expr' )}
 
 
 --------------------------------------------------
@@ -2824,17 +2856,25 @@ All this should happen in one sweep.
 -}
 
 knownCon :: SimplEnv
-         -> OutExpr                             -- The scrutinee
-         -> DataCon -> [OutType] -> [OutExpr]   -- The scrutinee (in pieces)
-         -> InId -> [InBndr] -> InExpr          -- The alternative
+         -> OutExpr                                           -- The scrutinee
+         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)
+         -> InId -> [InBndr] -> InExpr                        -- The alternative
          -> SimplCont
          -> SimplM (SimplFloats, OutExpr)
 
-knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
-  = do  { (floats1, env1)  <- bind_args env bs dc_args
+knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
+  = do  { let env0 = addNewInScopeIds env (concatMap MkCore.floatBindings dc_floats)
+        ; (floats1, env1)  <- bind_args env0 bs dc_args
         ; (floats2, env2) <- bind_case_bndr env1
         ; (floats3, expr') <- simplExprF env2 rhs cont
-        ; return (floats1 `addFloats` floats2 `addFloats` floats3, expr') }
+        ; case dc_floats of
+            [] ->
+              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')
+            _ ->
+              return ( emptyFloats env
+               -- See Note [FloatBinds from constructor wrappers]
+                     , MkCore.wrapFloats dc_floats $
+                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }
   where
     zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId
 
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 54308c6a5b..30b5f8c358 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -4,7 +4,7 @@ Result size of Tidy Core
   = {terms: 63, types: 43, coercions: 1, joins: 0/0}
 
 -- RHS size: {terms: 2, types: 4, coercions: 1, joins: 0/0}
-T2431.$WRefl [InlPrag=INLINE[2]] :: forall a. a :~: a
+T2431.$WRefl [InlPrag=INLINE[0]] :: forall a. a :~: a
 [GblId[DataConWrapper],
  Caf=NoCafRefs,
  Str=m,
@@ -110,6 +110,3 @@ T2431.$tc'Refl
       $tc'Refl2
       1#
       $krep3
-
-
-
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 5332a3e02b..41f67dc1d1 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -4,7 +4,7 @@ Result size of Tidy Core
   = {terms: 114, types: 53, coercions: 0, joins: 0/0}
 
 -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
-T7360.$WFoo3 [InlPrag=INLINE[2]] :: Int -> Foo
+T7360.$WFoo3 [InlPrag=INLINE[0]] :: Int -> Foo
 [GblId[DataConWrapper],
  Arity=1,
  Caf=NoCafRefs,
diff --git a/testsuite/tests/simplCore/should_run/T15840.hs b/testsuite/tests/simplCore/should_run/T15840.hs
new file mode 100644
index 0000000000..e844f9db5b
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T15840.hs
@@ -0,0 +1,14 @@
+module Main (main) where
+
+data T = MkT !Bool
+
+f :: T -> Bool
+f _ = False
+{-# NOINLINE f #-}
+
+{-# RULES "non-det" [1] forall x. f (MkT x) = x #-}
+
+main :: IO ()
+main = print (f (MkT True))
+-- Prints `True` if the rule fires, or `False` is the wrapper for `MkT` inlines
+-- in phase 2, preventing the rule from being triggered in phase 1.
diff --git a/testsuite/tests/simplCore/should_run/T15840.stdout b/testsuite/tests/simplCore/should_run/T15840.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T15840.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/simplCore/should_run/T15840a.hs b/testsuite/tests/simplCore/should_run/T15840a.hs
new file mode 100644
index 0000000000..ade75b6ac4
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T15840a.hs
@@ -0,0 +1,22 @@
+module Main (main) where
+
+data T = MkT !Bool
+
+f :: Bool -> IO ()
+f _ = putStrLn "The rule triggered before case-of-known-constructor could take effect (bad!)"
+{-# NOINLINE f #-}
+
+g :: IO ()
+g = putStrLn "Case-of-known-constructor triggered (good!)"
+
+{-# RULES "non-det" [~0] f True = g #-}
+
+main :: IO ()
+main =
+  case MkT True of
+    MkT x -> f x
+-- What we want to see is case-of-known-constructor triggering before phase 0
+-- (when the wrapper for MkT is allowed to be inlined). If it is, then the rule
+-- will see `f True` and trigger, and `g` will be run. If it isn't then `f True`
+-- will only appear at phase 0, when the rule cannot trigger, hence `f` will be
+-- run.
diff --git a/testsuite/tests/simplCore/should_run/T15840a.stdout b/testsuite/tests/simplCore/should_run/T15840a.stdout
new file mode 100644
index 0000000000..54601ba9d1
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T15840a.stdout
@@ -0,0 +1 @@
+Case-of-known-constructor triggered (good!)
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 0a74c628c7..f8089438c5 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -87,3 +87,5 @@ test('T14894', [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(1
 test('T14965', normal, compile_and_run, [''])
 test('T15114', only_ways('optasm'), compile_and_run, [''])
 test('T15436', normal, compile_and_run, [''])
+test('T15840', normal, compile_and_run, [''])
+test('T15840a', normal, compile_and_run, [''])