Enhance cast worker/wrapper for INLINABLE

In #19890 we realised that cast worker/wrapper didn't really work
properly for functions with an INLINABLE pragma, and hence a stable
unfolding. This patch fixes the problem.

Instead of disabling cast w/w when there is a stable unfolding (as
we did before), we now tranfer the stable unfolding to the worker.

It turned out that it was easier to do that if I moved the cast
w/w stuff from prepareBinding to completeBind.

No chnages at all in nofib results:
--------------------------------------------------------------------------------
        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
            Min          -0.0%      0.0%    -63.8%    -78.2%      0.0%
            Max          -0.0%      0.0%    +11.8%    +11.7%      0.0%
 Geometric Mean          -0.0%     -0.0%    -26.6%    -33.4%     -0.0%

Small decreases in compile-time allocation for two tests (below)
of around 2%.

T12545 increased in compile-time alloc by 4%, but it's not
reproducible on my machine, and is a known-wobbly test.

Metric Increase:
    T12545

Metric Decrease:
    T18698a
    T18698b

12 files changed, 411 insertions, 149 deletions

diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 05df4a7a7d..a17604300f 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -64,8 +64,8 @@ module GHC.Core (
         maybeUnfoldingTemplate, otherCons,
         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
-        isStableUnfolding, hasCoreUnfolding, hasSomeUnfolding,
-        isBootUnfolding,
+        isStableUnfolding, isInlineUnfolding, isBootUnfolding,
+        hasCoreUnfolding, hasSomeUnfolding,
         canUnfold, neverUnfoldGuidance, isStableSource,
 
         -- * Annotated expression data types
@@ -1462,6 +1462,22 @@ isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
 isStableUnfolding (DFunUnfolding {})               = True
 isStableUnfolding _                                = False
 
+isInlineUnfolding :: Unfolding -> Bool
+-- ^ True of a /stable/ unfolding that is
+--   (a) always inlined; that is, with an `UnfWhen` guidance, or
+--   (b) a DFunUnfolding which never needs to be inlined
+isInlineUnfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })
+  | isStableSource src
+  , UnfWhen {} <- guidance
+  = True
+
+isInlineUnfolding (DFunUnfolding {})
+  = True
+
+-- Default case
+isInlineUnfolding _ = False
+
+
 -- | Only returns False if there is no unfolding information available at all
 hasSomeUnfolding :: Unfolding -> Bool
 hasSomeUnfolding NoUnfolding   = False
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index be8b72ace4..caa18050e2 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -359,8 +359,8 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
 
         -- ANF-ise a constructor or PAP rhs
         -- We get at most one float per argument here
-        ; (let_floats, bndr2, body2) <- {-#SCC "prepareBinding" #-}
-                                        prepareBinding env top_lvl bndr bndr1 body1
+        ; (let_floats, body2) <- {-#SCC "prepareBinding" #-}
+                                 prepareBinding env top_lvl bndr1 body1
         ; let body_floats2 = body_floats1 `addLetFloats` let_floats
 
         ; (rhs_floats, rhs')
@@ -385,7 +385,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                         ; return (floats, rhs') }
 
         ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)
-                                             top_lvl Nothing bndr bndr2 rhs'
+                                             top_lvl Nothing bndr bndr1 rhs'
         ; return (rhs_floats `addFloats` bind_float, env2) }
 
 --------------------------
@@ -442,8 +442,7 @@ completeNonRecX :: TopLevelFlag -> SimplEnv
 
 completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
   = assertPpr (not (isJoinId new_bndr)) (ppr new_bndr) $
-    do  { (prepd_floats, new_bndr, new_rhs)
-              <- prepareBinding env top_lvl old_bndr new_bndr new_rhs
+    do  { (prepd_floats, new_rhs) <- prepareBinding env top_lvl new_bndr new_rhs
         ; let floats = emptyFloats env `addLetFloats` prepd_floats
         ; (rhs_floats, rhs2) <-
                 if doFloatFromRhs NotTopLevel NonRecursive is_strict floats new_rhs
@@ -461,22 +460,24 @@ completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
 
 {- *********************************************************************
 *                                                                      *
-           prepareBinding, prepareRhs, makeTrivial
+           Cast worker/wrapper
 *                                                                      *
 ************************************************************************
 
-Note [Cast worker/wrappers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Cast worker/wrapper]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we have a binding
    x = e |> co
 we want to do something very similar to worker/wrapper:
    $wx = e
    x = $wx |> co
 
-So now x can be inlined freely.  There's a chance that e will be a
-constructor application or function, or something like that, so moving
-the coercion to the usage site may well cancel the coercions and lead
-to further optimisation.  Example:
+We call this making a cast worker/wrapper in tryCastWorkerWrapper.
+
+The main motivaiton is that x can be inlined freely.  There's a chance
+that e will be a constructor application or function, or something
+like that, so moving the coercion to the usage site may well cancel
+the coercions and lead to further optimisation.  Example:
 
      data family T a :: *
      data instance T Int = T Int
@@ -489,39 +490,71 @@ to further optimisation.  Example:
           go n = case t of { T m -> go (n-m) }
                 -- This case should optimise
 
-We call this making a cast worker/wrapper, and it's done by prepareBinding.
-
-We need to be careful with inline/noinline pragmas:
-  rec { {-# NOINLINE f #-}
-        f = (...g...) |> co
-      ; g = ...f... }
-This is legitimate -- it tells GHC to use f as the loop breaker
-rather than g.  Now we do the cast thing, to get something like
-  rec { $wf = ...g...
-      ; f = $wf |> co
-      ; g = ...f... }
-Where should the NOINLINE pragma go?  If we leave it on f we'll get
-  rec { $wf = ...g...
-      ; {-# NOINLINE f #-}
-        f = $wf |> co
-      ; g = ...f... }
-and that is bad: the whole point is that we want to inline that
-cast!  We want to transfer the pagma to $wf:
-  rec { {-# NOINLINE $wf #-}
-        $wf = ...g...
-      ; f = $wf |> co
-      ; g = ...f... }
-It's exactly like worker/wrapper for strictness analysis:
+A second reason for doing cast worker/wrapper is that the worker/wrapper
+pass after strictness analysis can't deal with RHSs like
+     f = (\ a b c. blah) |> co
+Instead, it relies on cast worker/wrapper to get rid of the cast,
+leaving a simpler job for demand-analysis worker/wrapper.  See #19874.
+
+Wrinkles
+
+1. We must /not/ do cast w/w on
+     f = g |> co
+   otherwise it'll just keep repeating forever! You might think this
+   is avoided because the call to tryCastWorkerWrapper is guarded by
+   preInlineUnconditinally, but I'm worried that a loop-breaker or an
+   exported Id might say False to preInlineUnonditionally.
+
+2. We need to be careful with inline/noinline pragmas:
+       rec { {-# NOINLINE f #-}
+             f = (...g...) |> co
+           ; g = ...f... }
+   This is legitimate -- it tells GHC to use f as the loop breaker
+   rather than g.  Now we do the cast thing, to get something like
+       rec { $wf = ...g...
+           ; f = $wf |> co
+           ; g = ...f... }
+   Where should the NOINLINE pragma go?  If we leave it on f we'll get
+     rec { $wf = ...g...
+         ; {-# NOINLINE f #-}
+           f = $wf |> co
+         ; g = ...f... }
+   and that is bad: the whole point is that we want to inline that
+   cast!  We want to transfer the pagma to $wf:
+      rec { {-# NOINLINE $wf #-}
+            $wf = ...g...
+          ; f = $wf |> co
+          ; g = ...f... }
+   c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.
+
+3. We should still do cast w/w even if `f` is INLINEABLE.  E.g.
+      {- f: Stable unfolding = <stable-big> -}
+      f = (\xy. <big-body>) |> co
+   Then we want to w/w to
+      {- $wf: Stable unfolding = <stable-big> |> sym co -}
+      $wf = \xy. <big-body>
+      f = $wf |> co
+   Notice that the stable unfolding moves to the worker!  Now demand analysis
+   will work fine on $wf, whereas it has trouble with the original f.
+   c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap.
+
+4. We should /not/ do cast w/w for INLINE functions (hence isInlineUnfolding in
+   tryCastWorkerWrapper) becuase they'll be inlined, cast and all anyway. And
+   if we do cast w/w for an INLINE function with arity zero, we get something
+   really silly: we inline that "worker" right back into the wrapper! Worse than
+   a no-op, because we haev then lost the stable unfolding.
+
+Both these wrinkles are exactly like worker/wrapper for strictness analysis:
   f is the wrapper and must inline like crazy
   $wf is the worker and must carry f's original pragma
-See Note [Worker/wrapper for NOINLINE functions] in
-GHC.Core.Opt.WorkWrap.
+See Note [Worker/wrapper for INLINABLE functions]
+and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.
 
-See #17673, #18093, #18078.
+See #17673, #18093, #18078, #19890.
 
 Note [Preserve strictness in cast w/w]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the Note [Cast worker/wrappers] transformation, keep the strictness info.
+In the Note [Cast worker/wrapper] transformation, keep the strictness info.
 Eg
         f = e `cast` co    -- f has strictness SSL
 When we transform to
@@ -551,41 +584,79 @@ instead, we use (case erorr ... of {}). So I'm not sure
 this Note makes much sense any more.
 -}
 
-prepareBinding :: SimplEnv -> TopLevelFlag
-               -> InId -> OutId -> OutExpr
-               -> SimplM (LetFloats, OutId, OutExpr)
-
-prepareBinding env top_lvl old_bndr bndr rhs
-  | Cast rhs1 co <- rhs
-    -- Try for cast worker/wrapper
-    -- See Note [Cast worker/wrappers]
-  , not (isStableUnfolding (realIdUnfolding old_bndr))
-        -- Don't make a cast w/w if the thing is going to be inlined anyway
-  , not (exprIsTrivial rhs1)
-        -- Nor if the RHS is trivial; then again it'll be inlined
-  , let ty1 = coercionLKind co
-  , not (isUnliftedType ty1)
-        -- Not if rhs has an unlifted type; see Note [Cast w/w: unlifted]
-  = do { (floats, new_id) <- makeTrivialBinding (getMode env) top_lvl
-                                   (getOccFS bndr) worker_info rhs1 ty1
-       ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)
-       ; return (floats, bndr', Cast (Var new_id) co) }
-
-  | otherwise
-  = do { (floats, rhs') <- prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs
-       ; return (floats, bndr, rhs') }
- where
-   info = idInfo bndr
-   worker_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info
-                               `setCprSigInfo`        cprSigInfo info
-                               `setDemandInfo`     demandInfo info
-                               `setInlinePragInfo` inlinePragInfo info
-                               `setArityInfo`      arityInfo info
-          -- We do /not/ want to transfer OccInfo, Rules, Unfolding
-          -- Note [Preserve strictness in cast w/w]
+tryCastWorkerWrapper :: SimplEnv -> TopLevelFlag
+                     -> InId -> OccInfo
+                     -> OutId -> OutExpr
+                     -> SimplM (SimplFloats, SimplEnv)
+-- See Note [Cast worker/wrapper]
+tryCastWorkerWrapper env top_lvl old_bndr occ_info bndr (Cast rhs co)
+  | not (isJoinId bndr) -- Not for join points
+  , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform
+                        --            a DFunUnfolding in mk_worker_unfolding
+  , not (exprIsTrivial rhs)      -- Not x = y |> co; Wrinkle 1
+  , not (isInlineUnfolding unf)  -- Not INLINE things: Wrinkle 4
+  , not (isUnliftedType rhs_ty)  -- Not if rhs has an unlifted type;
+                                 --     see Note [Cast w/w: unlifted]
+  = do  { (rhs_floats, work_rhs) <- prepareRhs mode top_lvl occ_fs rhs
+        ; uniq <- getUniqueM
+        ; let work_name = mkSystemVarName uniq occ_fs
+              work_id   = mkLocalIdWithInfo work_name Many rhs_ty worker_info
+
+       ; work_unf <- mk_worker_unfolding work_id work_rhs
+       ; let  work_id_w_unf = work_id `setIdUnfolding` work_unf
+              floats   = emptyFloats env
+                         `addLetFloats` rhs_floats
+                         `addLetFloats` unitLetFloat (NonRec work_id_w_unf work_rhs)
+
+              triv_rhs = Cast (Var work_id_w_unf) co
+
+       ; if postInlineUnconditionally env top_lvl bndr occ_info triv_rhs
+            -- Almost always True, because the RHS is trivial
+            -- In that case we want to eliminate the binding fast
+            -- We conservatively use postInlineUnconditionally so that we
+            -- check all the right things
+         then do { tick (PostInlineUnconditionally bndr)
+                 ; return ( floats
+                          , extendIdSubst (setInScopeFromF env floats) old_bndr $
+                            DoneEx triv_rhs Nothing ) }
+
+         else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr triv_rhs
+                 ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)
+                               `setIdUnfolding`  wrap_unf
+                       floats' = floats `extendFloats` NonRec bndr' triv_rhs
+                 ; return ( floats', setInScopeFromF env floats' ) } }
+  where
+    mode   = getMode env
+    occ_fs = getOccFS bndr
+    rhs_ty = coercionLKind co
+    info   = idInfo bndr
+    unf    = unfoldingInfo info
+
+    worker_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info
+                                `setCprSigInfo`     cprSigInfo info
+                                `setDemandInfo`     demandInfo info
+                                `setInlinePragInfo` inlinePragInfo info
+                                `setArityInfo`      arityInfo info
+           -- We do /not/ want to transfer OccInfo, Rules
+           -- Note [Preserve strictness in cast w/w]
+           -- and Wrinkle 2 of Note [Cast worker/wrapper]
+
+    ----------- Worker unfolding -----------
+    -- Stable case: if there is a stable unfolding we have to compose with (Sym co);
+    --   the next round of simplification will do the job
+    -- Non-stable case: use work_rhs
+    -- Wrinkle 3 of Note [Cast worker/wrapper]
+    mk_worker_unfolding work_id work_rhs
+      = case unf of
+           CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }
+             | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })
+           _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs
+
+tryCastWorkerWrapper env _ _ _ bndr rhs  -- All other bindings
+  = return (mkFloatBind env (NonRec bndr rhs))
 
 mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma
--- See Note [Cast wrappers]
+-- See Note [Cast worker/wrapper]
 mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })
   = InlinePragma { inl_src    = SourceText "{-# INLINE"
                  , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline]
@@ -599,6 +670,19 @@ mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })
     wrap_act | isNeverActive act = activateDuringFinal
              | otherwise         = act
 
+
+{- *********************************************************************
+*                                                                      *
+           prepareBinding, prepareRhs, makeTrivial
+*                                                                      *
+********************************************************************* -}
+
+prepareBinding :: SimplEnv -> TopLevelFlag
+               -> OutId -> OutExpr
+               -> SimplM (LetFloats, OutExpr)
+prepareBinding env top_lvl bndr rhs
+  = prepareRhs (getMode env) top_lvl (getOccFS bndr) rhs
+
 {- Note [prepareRhs]
 ~~~~~~~~~~~~~~~~~~~~
 prepareRhs takes a putative RHS, checks whether it's a PAP or
@@ -806,31 +890,32 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
    do { let old_info = idInfo old_bndr
             old_unf  = unfoldingInfo old_info
             occ_info = occInfo old_info
+            mode     = getMode env
 
          -- Do eta-expansion on the RHS of the binding
          -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils
-      ; (new_arity, final_rhs) <- tryEtaExpandRhs (getMode env) new_bndr new_rhs
+      ; (new_arity, eta_rhs) <- tryEtaExpandRhs mode new_bndr new_rhs
 
         -- Simplify the unfolding
       ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr
-                          final_rhs (idType new_bndr) new_arity old_unf
+                         eta_rhs (idType new_bndr) new_arity old_unf
 
-      ; let final_bndr = addLetBndrInfo new_bndr new_arity new_unfolding
+      ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding
         -- See Note [In-scope set as a substitution]
 
-      ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs
+      ; if postInlineUnconditionally env top_lvl new_bndr_w_info occ_info eta_rhs
 
         then -- Inline and discard the binding
              do  { tick (PostInlineUnconditionally old_bndr)
                  ; return ( emptyFloats env
                           , extendIdSubst env old_bndr $
-                            DoneEx final_rhs (isJoinId_maybe new_bndr)) }
+                            DoneEx eta_rhs (isJoinId_maybe new_bndr)) }
                 -- Use the substitution to make quite, quite sure that the
                 -- substitution will happen, since we are going to discard the binding
 
-        else -- Keep the binding
+        else -- Keep the binding; do cast worker/wrapper
              -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $
-             return (mkFloatBind env (NonRec final_bndr final_rhs)) }
+             tryCastWorkerWrapper env top_lvl old_bndr occ_info new_bndr_w_info eta_rhs }
 
 addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId
 addLetBndrInfo new_bndr new_arity_type new_unf
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index 87dcd92d1e..8e5244ff4b 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -225,6 +225,8 @@ function will definitely get a w/w split" and that's hard to predict
 in advance...the logic in mkWwBodies is complex. So I've left the
 super-simple test, with this Note to explain.
 
+NB: record selectors are ordinary functions, inlined iff GHC wants to,
+so won't be caught by the preceding isInlineUnfolding test in tryWW.
 
 Note [Worker/wrapper for NOINLINE functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -511,12 +513,16 @@ tryWW ww_opts is_rec fn_id rhs
   , Just filler <- mkAbsentFiller ww_opts fn_id
   = return [(new_fn_id, filler)]
 
+  -- See Note [Don't w/w INLINE things]
+  | hasInlineUnfolding fn_id
+  = return [(new_fn_id, rhs)]
+
   -- See Note [No worker/wrapper for record selectors]
   | isRecordSelector fn_id
   = return [ (new_fn_id, rhs ) ]
 
   | is_fun && is_eta_exp
-  = splitFun ww_opts new_fn_id fn_info wrap_dmds div cpr rhs
+  = splitFun ww_opts new_fn_id fn_info rhs
 
   -- See Note [Thunk splitting]
   | isNonRec is_rec, is_thunk
@@ -526,16 +532,8 @@ tryWW ww_opts is_rec fn_id rhs
   = return [ (new_fn_id, rhs) ]
 
   where
-    fn_info          = idInfo fn_id
-    (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info)
-
-    cpr_ty = getCprSig (cprSigInfo fn_info)
-    -- Arity of the CPR sig should match idArity when it's not a join point.
-    -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal
-    cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info)
-                    (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty)
-                      <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $
-          ct_cpr cpr_ty
+    fn_info        = idInfo fn_id
+    (wrap_dmds, _) = splitDmdSig (dmdSigInfo fn_info)
 
     new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)
         -- See Note [Zapping DmdEnv after Demand Analyzer] and
@@ -649,7 +647,7 @@ Consider this (#19824 comment on 15 May 21):
   v = ...big...
   g x = f v x + 1
 
-So `f` will generate a worker/wrapper split; and `g` (since it is small
+So `f` will generate a worker/wrapper split; and `g` (since it is small)
 will trigger the certainlyWillInline case of splitFun.  The danger is that
 we end up with
   g {- StableUnfolding = \x -> f v x + 1 -}
@@ -670,22 +668,22 @@ by LitRubbish (see Note [Drop absent bindings]) so there is no great harm.
 
 
 ---------------------
-splitFun :: WwOpts -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr
-         -> UniqSM [(Id, CoreExpr)]
-splitFun ww_opts fn_id fn_info wrap_dmds div cpr rhs
+splitFun :: WwOpts -> Id -> IdInfo -> CoreExpr -> UniqSM [(Id, CoreExpr)]
+splitFun ww_opts fn_id fn_info rhs
   = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info)))
                  (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $
     do { mb_stuff <- mkWwBodies ww_opts rhs_fvs fn_id wrap_dmds use_cpr_info
        ; case mb_stuff of
-            Nothing -> return [(fn_id, rhs)]
+            Nothing -> -- No useful wrapper; leave the binding alone
+                       return [(fn_id, rhs)]
 
             Just stuff
               | Just stable_unf <- certainlyWillInline uf_opts fn_info
+                -- We could make a w/w split, but in fact the RHS is small
+                -- See Note [Don't w/w inline small non-loop-breaker things]
               , let id_w_unf = fn_id `setIdUnfolding` stable_unf
                 -- See Note [Inline pragma for certainlyWillInline]
               ->  return [ (id_w_unf, rhs) ]
-                  -- See Note [Don't w/w INLINE things]
-                  -- See Note [Don't w/w inline small non-loop-breaker things]
 
               | otherwise
               -> do { work_uniq <- getUniqueM
@@ -695,6 +693,16 @@ splitFun ww_opts fn_id fn_info wrap_dmds div cpr rhs
     uf_opts = so_uf_opts (wo_simple_opts ww_opts)
     rhs_fvs = exprFreeVars rhs
 
+    (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info)
+
+    cpr_ty = getCprSig (cprSigInfo fn_info)
+    -- Arity of the CPR sig should match idArity when it's not a join point.
+    -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal
+    cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info)
+                    (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty)
+                      <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $
+          ct_cpr cpr_ty
+
     -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points,
     -- see Note [Don't w/w join points for CPR].
     use_cpr_info  | isJoinId fn_id = topCpr
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index bd02bd6fc1..55561c9cbc 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -972,11 +972,11 @@ certainlyWillInline opts fn_info
         | noinline     -> Nothing       -- See Note [Worker/wrapper for NOINLINE functions]
         | otherwise
         -> case guidance of
-             UnfNever  -> Nothing
+             UnfNever   -> Nothing
              UnfWhen {} -> Just (fn_unf { uf_src = src' })
                              -- INLINE functions have UnfWhen
              UnfIfGoodArgs { ug_size = size, ug_args = args }
-               -> do_cunf expr size args src'
+                        -> do_cunf expr size args src'
         where
           src' = -- Do not change InlineCompulsory!
                  case src of
diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs
index e911d722ee..378d5a6131 100644
--- a/compiler/GHC/Core/Unfold/Make.hs
+++ b/compiler/GHC/Core/Unfold/Make.hs
@@ -230,7 +230,7 @@ The semantics of an INLINE pragma is
 the `UnfoldingGuidance`.)
 
 In the example, x's ug_arity is 0, so we should inline it at every use
-site.  It's rare to have such an INLINE pragma (usually INLINE Is on
+site.  It's rare to have such an INLINE pragma (usually INLINE is on
 functions), but it's occasionally very important (#15578, #15519).
 In #15519 we had something like
    x = case (g a b) of I# r -> T r
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 55ff3f9335..7c78c1928b 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -94,7 +94,7 @@ module GHC.Types.Id (
         -- ** Reading 'IdInfo' fields
         idArity,
         idCallArity, idFunRepArity,
-        idUnfolding, realIdUnfolding,
+        idUnfolding, realIdUnfolding, hasInlineUnfolding,
         idSpecialisation, idCoreRules, idHasRules,
         idCafInfo, idLFInfo_maybe,
         idOneShotInfo, idStateHackOneShotInfo,
@@ -124,7 +124,8 @@ module GHC.Types.Id (
 import GHC.Prelude
 
 import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,
-                 isCompulsoryUnfolding, Unfolding( NoUnfolding ) )
+                 isCompulsoryUnfolding, isInlineUnfolding,
+                 Unfolding( NoUnfolding ) )
 
 import GHC.Types.Id.Info
 import GHC.Types.Basic
@@ -721,6 +722,12 @@ idUnfolding id
   where
     info = idInfo id
 
+hasInlineUnfolding :: Id -> Bool
+-- ^ True of a non-loop-breaker Id that has a /stable/ unfolding that is
+--   (a) always inlined; that is, with an `UnfWhen` guidance, or
+--   (b) a DFunUnfolding which never needs to be inlined
+hasInlineUnfolding id = isInlineUnfolding (idUnfolding id)
+
 realIdUnfolding :: Id -> Unfolding
 -- Expose the unfolding if there is one, including for loop breakers
 realIdUnfolding id = unfoldingInfo (idInfo id)
diff --git a/testsuite/tests/simplCore/should_compile/T18078.hs b/testsuite/tests/simplCore/should_compile/T18078.hs
index e28b4a98ac..776e1194de 100644
--- a/testsuite/tests/simplCore/should_compile/T18078.hs
+++ b/testsuite/tests/simplCore/should_compile/T18078.hs
@@ -3,7 +3,7 @@ module T18078 where
 newtype N = N { unN :: Int -> Int }
 
 -- This an example of a worker/wrapper thing
--- See Note [Cast worker/wrappers] in Simplify
+-- See Note [Cast worker/wrapper] in Simplify
 -- We should get good code, with a $wf calling itself
 -- but in 8.10 we do not
 f :: N
diff --git a/testsuite/tests/simplCore/should_compile/T19890.hs b/testsuite/tests/simplCore/should_compile/T19890.hs
new file mode 100644
index 0000000000..39f89bc1e6
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19890.hs
@@ -0,0 +1,8 @@
+module T19890 where
+
+newtype Wombat a = Wombat (a->a)
+
+foo :: Num a => Bool -> Wombat a
+{-# INLINEABLE foo #-}
+foo True  = foo False
+foo False = Wombat (\x -> x+1)
diff --git a/testsuite/tests/simplCore/should_compile/T19890.stderr b/testsuite/tests/simplCore/should_compile/T19890.stderr
new file mode 100644
index 0000000000..9c9857edfc
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19890.stderr
@@ -0,0 +1,178 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 82, types: 41, coercions: 12, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+lvl_rzi :: Integer
+[GblId, Unf=OtherCon []]
+lvl_rzi = 1
+
+Rec {
+-- RHS size: {terms: 18, types: 9, coercions: 0, joins: 0/0}
+T19890.foo1 [InlPrag=INLINABLE, Occ=LoopBreaker]
+  :: forall {a}. Num a => Bool -> a -> a
+[GblId,
+ Arity=3,
+ Str=<SP(SCS(C1(L)),A,A,A,A,A,L)><1L><L>,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 70 0] 230 0
+         Tmpl= \ (@a_aye)
+                 ($dNum_ayf :: Num a_aye)
+                 (ds_dyN [Occ=Once1!] :: Bool)
+                 (eta_B0 [Occ=Once2] :: a_aye) ->
+                 case ds_dyN of {
+                   False ->
+                     + @a_aye $dNum_ayf eta_B0 (fromInteger @a_aye $dNum_ayf 1);
+                   True -> T19890.foo1 @a_aye $dNum_ayf GHC.Types.False eta_B0
+                 }}]
+T19890.foo1
+  = \ (@a_aye)
+      ($dNum_ayf :: Num a_aye)
+      (ds_dyN :: Bool)
+      (eta_B0 :: a_aye) ->
+      case ds_dyN of {
+        False ->
+          + @a_aye $dNum_ayf eta_B0 (fromInteger @a_aye $dNum_ayf lvl_rzi);
+        True -> T19890.foo1 @a_aye $dNum_ayf GHC.Types.False eta_B0
+      }
+end Rec }
+
+-- RHS size: {terms: 1, types: 0, coercions: 12, joins: 0/0}
+foo :: forall a. Num a => Bool -> Wombat a
+[GblId,
+ Arity=3,
+ Str=<SP(SCS(C1(L)),A,A,A,A,A,L)><1L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
+foo
+  = T19890.foo1
+    `cast` (forall (a :: <*>_N).
+            <Num a>_R
+            %<'Many>_N ->_R <Bool>_R
+            %<'Many>_N ->_R Sym (T19890.N:Wombat[0] <a>_R)
+            :: (forall {a}. Num a => Bool -> a -> a)
+               ~R# (forall {a}. Num a => Bool -> Wombat a))
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T19890.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T19890.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T19890.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T19890.$trModule3 = GHC.Types.TrNameS T19890.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T19890.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T19890.$trModule2 = "T19890"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T19890.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T19890.$trModule1 = GHC.Types.TrNameS T19890.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T19890.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T19890.$trModule
+  = GHC.Types.Module T19890.$trModule3 T19890.$trModule1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep_rzj :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep_rzj = GHC.Types.KindRepVar 0#
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep1_rzk :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep1_rzk = GHC.Types.KindRepFun $krep_rzj $krep_rzj
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T19890.$tcWombat2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T19890.$tcWombat2 = "Wombat"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T19890.$tcWombat1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T19890.$tcWombat1 = GHC.Types.TrNameS T19890.$tcWombat2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T19890.$tcWombat :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T19890.$tcWombat
+  = GHC.Types.TyCon
+      14886729617606120106##
+      9341180610983476309##
+      T19890.$trModule
+      T19890.$tcWombat1
+      0#
+      GHC.Types.krep$*Arr*
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep2_rzl :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep2_rzl
+  = GHC.Types.:
+      @GHC.Types.KindRep $krep_rzj (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep3_rzm :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep3_rzm = GHC.Types.KindRepTyConApp T19890.$tcWombat $krep2_rzl
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T19890.$tc'Wombat1 [InlPrag=[~]] :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+T19890.$tc'Wombat1 = GHC.Types.KindRepFun $krep1_rzk $krep3_rzm
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T19890.$tc'Wombat3 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T19890.$tc'Wombat3 = "'Wombat"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T19890.$tc'Wombat2 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T19890.$tc'Wombat2 = GHC.Types.TrNameS T19890.$tc'Wombat3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T19890.$tc'Wombat :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T19890.$tc'Wombat
+  = GHC.Types.TyCon
+      2678731069210293856##
+      16131282919067740460##
+      T19890.$trModule
+      T19890.$tc'Wombat2
+      1#
+      T19890.$tc'Wombat1
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T8331.stderr b/testsuite/tests/simplCore/should_compile/T8331.stderr
index 76c8d90817..e84edead21 100644
--- a/testsuite/tests/simplCore/should_compile/T8331.stderr
+++ b/testsuite/tests/simplCore/should_compile/T8331.stderr
@@ -14,52 +14,10 @@
                       ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s b)
                      (forall {a} {b}.
                       ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) b))
-"SPEC $c<* @(ST s) _"
-    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
-      $fApplicativeReaderT_$c<* @(ST s) @r $dApplicative
-      = ($fApplicativeReaderT2 @s @r)
-        `cast` (forall (a :: <*>_N) (b :: <*>_N).
-                <ReaderT r (ST s) a>_R
-                %<'Many>_N ->_R <ReaderT r (ST s) b>_R
-                %<'Many>_N ->_R <r>_R %<'Many>_N ->_R Sym (N:ST[0] <s>_N <a>_R)
-                                ; Sym (N:ReaderT[0] <*>_N <r>_R <ST s>_R <a>_N)
-                :: Coercible
-                     (forall {a} {b}.
-                      ReaderT r (ST s) a -> ReaderT r (ST s) b -> r -> STRep s a)
-                     (forall {a} {b}.
-                      ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) a))
-"SPEC $c<*> @(ST s) _"
-    forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
-      $fApplicativeReaderT5 @(ST s) @r $dApplicative
-      = ($fApplicativeReaderT6 @s @r)
-        `cast` (forall (a :: <*>_N) (b :: <*>_N).
-                <ReaderT r (ST s) (a -> b)>_R
-                %<'Many>_N ->_R <ReaderT r (ST s) a>_R
-                %<'Many>_N ->_R <r>_R
-                %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
-                :: Coercible
-                     (forall {a} {b}.
-                      ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> STRep s b)
-                     (forall {a} {b}.
-                      ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> ST s b))
 "SPEC $c>> @(ST s) _"
     forall (@s) (@r) ($dMonad :: Monad (ST s)).
       $fMonadReaderT_$c>> @(ST s) @r $dMonad
       = $fMonadAbstractIOSTReaderT_$s$c>> @s @r
-"SPEC $c>>= @(ST s) _"
-    forall (@s) (@r) ($dMonad :: Monad (ST s)).
-      $fMonadReaderT1 @(ST s) @r $dMonad
-      = ($fMonadReaderT2 @s @r)
-        `cast` (forall (a :: <*>_N) (b :: <*>_N).
-                <ReaderT r (ST s) a>_R
-                %<'Many>_N ->_R <a -> ReaderT r (ST s) b>_R
-                %<'Many>_N ->_R <r>_R
-                %<'Many>_N ->_R Sym (N:ST[0] <s>_N <b>_R)
-                :: Coercible
-                     (forall {a} {b}.
-                      ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> STRep s b)
-                     (forall {a} {b}.
-                      ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> ST s b))
 "SPEC $cliftA2 @(ST s) _"
     forall (@s) (@r) ($dApplicative :: Applicative (ST s)).
       $fApplicativeReaderT_$cliftA2 @(ST s) @r $dApplicative
diff --git a/testsuite/tests/simplCore/should_compile/T9509.stdout b/testsuite/tests/simplCore/should_compile/T9509.stdout
index 5f272e47e1..c5016afb8b 100644
--- a/testsuite/tests/simplCore/should_compile/T9509.stdout
+++ b/testsuite/tests/simplCore/should_compile/T9509.stdout
@@ -1,2 +1,2 @@
-    Rule: SPEC/T9509 foo @Int
-    Rule: SPEC/T9509 foo @Int
+    Rule: SPEC/T9509 foo1 @Int
+    Rule: SPEC/T9509 foo1 @Int
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index e0f4338328..ed45e9dc65 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -364,3 +364,5 @@ test('T19672', normal, compile, ['-O2 -ddump-rules'])
 
 test('T19780', normal, compile, ['-O2'])
 test('T19794', normal, compile, ['-O'])
+test('T19890',  [ grep_errmsg(r'= T19890.foo1') ], compile, ['-O -ddump-simpl'])
+