Improve eta-expansion using ArityTypewip/T18328

As #18355 shows, we were failing to preserve one-shot info when
eta-expanding.  It's rather easy to fix, by using ArityType more,
rather than just Arity.

This patch is important to suport the one-shot monad trick;
see #18202.  But the extra tracking of one-shot-ness requires
the patch

   Define multiShotIO and use it in mkSplitUniqueSupply

If that patch is missing, ths patch makes things worse in
GHC.Types.Uniq.Supply.  With it, however, we see these improvements

    T3064     compiler bytes allocated -2.2%
    T3294     compiler bytes allocated -1.3%
    T12707    compiler bytes allocated -1.3%
    T13056    compiler bytes allocated -2.2%

Metric decrease:
    T3064
    T3294
    T12707
    T13056

9 files changed, 361 insertions, 221 deletions

diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 2b2a7c20ea..7891012792 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -13,9 +13,12 @@
 -- | Arity and eta expansion
 module GHC.Core.Opt.Arity
    ( manifestArity, joinRhsArity, exprArity, typeArity
-   , exprEtaExpandArity, findRhsArity, etaExpand
+   , exprEtaExpandArity, findRhsArity
+   , etaExpand, etaExpandAT
    , etaExpandToJoinPoint, etaExpandToJoinPointRule
    , exprBotStrictness_maybe
+   , ArityType(..), expandableArityType, arityTypeArity
+   , maxWithArity, isBotArityType, idArityType
    )
 where
 
@@ -42,7 +45,7 @@ import GHC.Types.Unique
 import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )
 import GHC.Utils.Outputable
 import GHC.Data.FastString
-import GHC.Utils.Misc     ( debugIsOn )
+import GHC.Utils.Misc     ( lengthAtLeast )
 
 {-
 ************************************************************************
@@ -486,8 +489,11 @@ Then  f             :: AT [False,False] ATop
 -------------------- Main arity code ----------------------------
 -}
 
--- See Note [ArityType]
-data ArityType = ATop [OneShotInfo] | ABot Arity
+
+data ArityType   -- See Note [ArityType]
+  = ATop [OneShotInfo]
+  | ABot Arity
+  deriving( Eq )
      -- There is always an explicit lambda
      -- to justify the [OneShot], or the Arity
 
@@ -495,18 +501,45 @@ instance Outputable ArityType where
   ppr (ATop os) = text "ATop" <> parens (ppr (length os))
   ppr (ABot n)  = text "ABot" <> parens (ppr n)
 
+arityTypeArity :: ArityType -> Arity
+-- The number of value args for the arity type
+arityTypeArity (ATop oss) = length oss
+arityTypeArity (ABot ar)  = ar
+
+expandableArityType :: ArityType -> Bool
+-- True <=> eta-expansion will add at least one lambda
+expandableArityType (ATop oss) = not (null oss)
+expandableArityType (ABot ar)  = ar /= 0
+
+isBotArityType :: ArityType -> Bool
+isBotArityType (ABot {}) = True
+isBotArityType (ATop {}) = False
+
+arityTypeOneShots :: ArityType -> [OneShotInfo]
+arityTypeOneShots (ATop oss) = oss
+arityTypeOneShots (ABot ar)  = replicate ar OneShotLam
+   -- If we are diveging or throwing an exception anyway
+   -- it's fine to push redexes inside the lambdas
+
+botArityType :: ArityType
+botArityType = ABot 0   -- Unit for andArityType
+
+maxWithArity :: ArityType -> Arity -> ArityType
+maxWithArity at@(ABot {}) _   = at
+maxWithArity at@(ATop oss) ar
+     | oss `lengthAtLeast` ar = at
+     | otherwise              = ATop (take ar (oss ++ repeat NoOneShotInfo))
+
 vanillaArityType :: ArityType
 vanillaArityType = ATop []      -- Totally uninformative
 
 -- ^ The Arity returned is the number of value args the
 -- expression can be applied to without doing much work
-exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
+exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType
 -- exprEtaExpandArity is used when eta expanding
 --      e  ==>  \xy -> e x y
 exprEtaExpandArity dflags e
-  = case (arityType env e) of
-      ATop oss -> length oss
-      ABot n   -> n
+  = arityType env e
   where
     env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp
              , ae_ped_bot  = gopt Opt_PedanticBottoms dflags
@@ -529,7 +562,7 @@ mk_cheap_fn dflags cheap_app
 
 
 ----------------------
-findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> (Arity, Bool)
+findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType
 -- This implements the fixpoint loop for arity analysis
 -- See Note [Arity analysis]
 -- If findRhsArity e = (n, is_bot) then
@@ -543,44 +576,34 @@ findRhsArity dflags bndr rhs old_arity
        -- we stop right away (since arities should not decrease)
        -- Result: the common case is that there is just one iteration
   where
-    is_lam = has_lam rhs
-
-    has_lam (Tick _ e) = has_lam e
-    has_lam (Lam b e)  = isId b || has_lam e
-    has_lam _          = False
-
     init_cheap_app :: CheapAppFun
     init_cheap_app fn n_val_args
       | fn == bndr = True   -- On the first pass, this binder gets infinite arity
       | otherwise  = isCheapApp fn n_val_args
 
-    go :: (Arity, Bool) -> (Arity, Bool)
-    go cur_info@(cur_arity, _)
-      | cur_arity <= old_arity = cur_info
-      | new_arity == cur_arity = cur_info
-      | otherwise = ASSERT( new_arity < cur_arity )
+    go :: ArityType -> ArityType
+    go cur_atype
+      | cur_arity <= old_arity = cur_atype
+      | new_atype == cur_atype = cur_atype
+      | otherwise =
 #if defined(DEBUG)
                     pprTrace "Exciting arity"
-                       (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
+                       (vcat [ ppr bndr <+> ppr cur_atype <+> ppr new_atype
                              , ppr rhs])
 #endif
-                    go new_info
+                    go new_atype
       where
-        new_info@(new_arity, _) = get_arity cheap_app
+        new_atype = get_arity cheap_app
 
+        cur_arity = arityTypeArity cur_atype
         cheap_app :: CheapAppFun
         cheap_app fn n_val_args
           | fn == bndr = n_val_args < cur_arity
           | otherwise  = isCheapApp fn n_val_args
 
-    get_arity :: CheapAppFun -> (Arity, Bool)
-    get_arity cheap_app
-      = case (arityType env rhs) of
-          ABot n -> (n, True)
-          ATop (os:oss) | isOneShotInfo os || is_lam
-                  -> (1 + length oss, False)    -- Don't expand PAPs/thunks
-          ATop _  -> (0,              False)    -- Note [Eta expanding thunks]
-       where
+    get_arity :: CheapAppFun -> ArityType
+    get_arity cheap_app = arityType env rhs
+      where
          env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app
                   , ae_ped_bot  = gopt Opt_PedanticBottoms dflags
                   , ae_joins    = emptyVarSet }
@@ -613,7 +636,6 @@ write the analysis loop.
 The analysis is cheap-and-cheerful because it doesn't deal with
 mutual recursion.  But the self-recursive case is the important one.
 
-
 Note [Eta expanding through dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If the experimental -fdicts-cheap flag is on, we eta-expand through
@@ -632,24 +654,6 @@ The (foo DInt) is floated out, and makes ineffective a RULE
 
 One could go further and make exprIsCheap reply True to any
 dictionary-typed expression, but that's more work.
-
-Note [Eta expanding thunks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don't eta-expand
-   * Trivial RHSs     x = y
-   * PAPs             x = map g
-   * Thunks           f = case y of p -> \x -> blah
-
-When we see
-     f = case y of p -> \x -> blah
-should we eta-expand it? Well, if 'x' is a one-shot state token
-then 'yes' because 'f' will only be applied once.  But otherwise
-we (conservatively) say no.  My main reason is to avoid expanding
-PAPSs
-        f = g d  ==>  f = \x. g d x
-because that might in turn make g inline (if it has an inline pragma),
-which we might not want.  After all, INLINE pragmas say "inline only
-when saturated" so we don't want to be too gung-ho about saturating!
 -}
 
 arityLam :: Id -> ArityType -> ArityType
@@ -673,6 +677,7 @@ arityApp (ATop [])     _     = ATop []
 arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as)
 
 andArityType :: ArityType -> ArityType -> ArityType   -- Used for branches of a 'case'
+-- This is least upper bound in the ArityType lattice
 andArityType (ABot n1) (ABot n2)  = ABot (n1 `max` n2) -- Note [ABot branches: use max]
 andArityType (ATop as)  (ABot _)  = ATop as
 andArityType (ABot _)   (ATop bs) = ATop bs
@@ -754,8 +759,7 @@ arityType :: ArityEnv -> CoreExpr -> ArityType
 
 arityType env (Cast e co)
   = case arityType env e of
-      ATop os -> ATop (take co_arity os)
-      -- See Note [Arity trimming]
+      ATop os -> ATop (take co_arity os)  -- See Note [Arity trimming]
       ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo)
              | otherwise    -> ABot n
   where
@@ -769,19 +773,9 @@ arityType env (Cast e co)
 
 arityType env (Var v)
   | v `elemVarSet` ae_joins env
-  = ABot 0  -- See Note [Eta-expansion and join points]
-
-  | strict_sig <- idStrictness v
-  , not $ isTopSig strict_sig
-  , (ds, res) <- splitStrictSig strict_sig
-  , let arity = length ds
-  = if isDeadEndDiv res then ABot arity
-                        else ATop (take arity one_shots)
+  = botArityType  -- See Note [Eta-expansion and join points]
   | otherwise
-  = ATop (take (idArity v) one_shots)
-  where
-    one_shots :: [OneShotInfo]  -- One-shot-ness derived from the type
-    one_shots = typeArity (idType v)
+  = idArityType v
 
         -- Lambdas; increase arity
 arityType env (Lam x e)
@@ -804,13 +798,13 @@ arityType env (App fun arg )
         --
 arityType env (Case scrut _ _ alts)
   | exprIsDeadEnd scrut || null alts
-  = ABot 0     -- Do not eta expand
-               -- See Note [Dealing with bottom (1)]
+  = botArityType    -- Do not eta expand
+                    -- See Note [Dealing with bottom (1)]
   | otherwise
   = case alts_type of
-     ABot n  | n>0       -> ATop []    -- Don't eta expand
-             | otherwise -> ABot 0     -- if RHS is bottomming
-                                       -- See Note [Dealing with bottom (2)]
+     ABot n  | n>0       -> ATop []       -- Don't eta expand
+             | otherwise -> botArityType  -- if RHS is bottomming
+                                          -- See Note [Dealing with bottom (2)]
 
      ATop as | not (ae_ped_bot env)    -- See Note [Dealing with bottom (3)]
              , ae_cheap_fn env scrut Nothing -> ATop as
@@ -886,7 +880,8 @@ So we do this:
   body of the let.
 
 * Dually, when we come to a /call/ of a join point, just no-op
-  by returning (ABot 0), the neutral element of ArityType.
+  by returning botArityType, the bottom element of ArityType,
+  which so that: bot `andArityType` x = x
 
 * This works if the join point is bound in the expression we are
   taking the arityType of.  But if it's bound further out, it makes
@@ -905,6 +900,20 @@ An alternative (roughly equivalent) idea would be to carry an
 environment mapping let-bound Ids to their ArityType.
 -}
 
+idArityType :: Id -> ArityType
+idArityType v
+  | strict_sig <- idStrictness v
+  , not $ isTopSig strict_sig
+  , (ds, res) <- splitStrictSig strict_sig
+  , let arity = length ds
+  = if isDeadEndDiv res then ABot arity
+                        else ATop (take arity one_shots)
+  | otherwise
+  = ATop (take (idArity v) one_shots)
+  where
+    one_shots :: [OneShotInfo]  -- One-shot-ness derived from the type
+    one_shots = typeArity (idType v)
+
 {-
 %************************************************************************
 %*                                                                      *
@@ -1001,6 +1010,25 @@ which we want to lead to code like
 This means that we need to look through type applications and be ready
 to re-add floats on the top.
 
+Note [Eta expansion with ArityType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The etaExpandAT function takes an ArityType (not just an Arity) to
+guide eta-expansion.  Why? Because we want to preserve one-shot info.
+Consider
+  foo = \x. case x of
+              True  -> (\s{os}. blah) |> co
+              False -> wubble
+We'll get an ArityType for foo of (ATop [NoOneShot,OneShot]).
+
+Then we want to eta-expand to
+  foo = \x. (\eta{os}. (case x of ...as before...) eta) |> some_co
+
+That 'eta' binder is fresh, and we really want it to have the
+one-shot flag from the inner \s{osf}.  By expanding with the
+ArityType gotten from analysing the RHS, we achieve this neatly.
+
+This makes a big difference to the one-shot monad trick;
+see Note [The one-shot state monad trick] in GHC.Core.Unify.
 -}
 
 -- | @etaExpand n e@ returns an expression with
@@ -1013,11 +1041,16 @@ to re-add floats on the top.
 -- We should have that:
 --
 -- > ty = exprType e = exprType e'
-etaExpand :: Arity              -- ^ Result should have this number of value args
-          -> CoreExpr           -- ^ Expression to expand
-          -> CoreExpr
+etaExpand   :: Arity     -> CoreExpr -> CoreExpr
+etaExpandAT :: ArityType -> CoreExpr -> CoreExpr
+
+etaExpand   n  orig_expr = eta_expand (replicate n NoOneShotInfo) orig_expr
+etaExpandAT at orig_expr = eta_expand (arityTypeOneShots at)      orig_expr
+                           -- See Note [Eta expansion with ArityType]
+
 -- etaExpand arity e = res
 -- Then 'res' has at least 'arity' lambdas at the top
+-- See Note [Eta expansion with ArityType]
 --
 -- etaExpand deals with for-alls. For example:
 --              etaExpand 1 E
@@ -1028,21 +1061,23 @@ etaExpand :: Arity              -- ^ Result should have this number of value arg
 -- It deals with coerces too, though they are now rare
 -- so perhaps the extra code isn't worth it
 
-etaExpand n orig_expr
-  = go n orig_expr
+eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr
+eta_expand one_shots orig_expr
+  = go one_shots orig_expr
   where
       -- Strip off existing lambdas and casts before handing off to mkEtaWW
       -- Note [Eta expansion and SCCs]
-    go 0 expr = expr
-    go n (Lam v body) | isTyVar v = Lam v (go n     body)
-                      | otherwise = Lam v (go (n-1) body)
-    go n (Cast expr co)           = Cast (go n expr) co
-    go n expr
+    go [] expr = expr
+    go oss@(_:oss1) (Lam v body) | isTyVar v = Lam v (go oss  body)
+                                 | otherwise = Lam v (go oss1 body)
+    go oss (Cast expr co) = Cast (go oss expr) co
+
+    go oss expr
       = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
         retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas)
       where
           in_scope = mkInScopeSet (exprFreeVars expr)
-          (in_scope', etas) = mkEtaWW n (ppr orig_expr) in_scope (exprType expr)
+          (in_scope', etas) = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr)
           subst' = mkEmptySubst in_scope'
 
           -- Find ticks behind type apps.
@@ -1141,7 +1176,7 @@ etaInfoAppTy _  (EtaCo co : eis) = etaInfoAppTy (coercionRKind co) eis
 -- semantically-irrelevant source annotations, so call sites must take care to
 -- preserve that info. See Note [Eta expansion and SCCs].
 mkEtaWW
-  :: Arity
+  :: [OneShotInfo]
   -- ^ How many value arguments to eta-expand
   -> SDoc
   -- ^ The pretty-printed original expression, for warnings.
@@ -1153,36 +1188,29 @@ mkEtaWW
   -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the
   -- fresh variables in 'EtaInfo'.
 
-mkEtaWW orig_n ppr_orig_expr in_scope orig_ty
-  = go orig_n empty_subst orig_ty []
+mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty
+  = go 0 orig_oss empty_subst orig_ty []
   where
     empty_subst = mkEmptyTCvSubst in_scope
 
-    go :: Arity              -- Number of value args to expand to
+    go :: Int                -- For fresh names
+       -> [OneShotInfo]      -- Number of value args to expand to
        -> TCvSubst -> Type   -- We are really looking at subst(ty)
        -> [EtaInfo]          -- Accumulating parameter
        -> (InScopeSet, [EtaInfo])
-    go n subst ty eis       -- See Note [exprArity invariant]
-
+    go _ [] subst _ eis       -- See Note [exprArity invariant]
        ----------- Done!  No more expansion needed
-       | n == 0
        = (getTCvInScope subst, reverse eis)
 
+    go n oss@(one_shot:oss1) subst ty eis       -- See Note [exprArity invariant]
        ----------- Forall types  (forall a. ty)
        | Just (tcv,ty') <- splitForAllTy_maybe ty
-       , let (subst', tcv') = Type.substVarBndr subst tcv
-       = let ((n_subst, n_tcv), n_n)
-               -- We want to have at least 'n' lambdas at the top.
-               -- If tcv is a tyvar, it corresponds to one Lambda (/\).
-               --   And we won't reduce n.
-               -- If tcv is a covar, we could eta-expand the expr with one
-               --   lambda \co:ty. e co. In this case we generate a new variable
-               --   of the coercion type, update the scope, and reduce n by 1.
-               | isTyVar tcv = ((subst', tcv'), n)
-                    -- covar case:
-               | otherwise   = (freshEtaId n subst' (unrestricted (varType tcv')), n-1)
-           -- Avoid free vars of the original expression
-         in go n_n n_subst ty' (EtaVar n_tcv : eis)
+       , (subst', tcv') <- Type.substVarBndr subst tcv
+       , let oss' | isTyVar tcv = oss
+                  | otherwise   = oss1
+         -- A forall can bind a CoVar, in which case
+         -- we consume one of the [OneShotInfo]
+       = go n oss' subst' ty' (EtaVar tcv' : eis)
 
        ----------- Function types  (t1 -> t2)
        | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty
@@ -1190,9 +1218,11 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty
           -- See Note [Levity polymorphism invariants] in GHC.Core
           -- See also test case typecheck/should_run/EtaExpandLevPoly
 
-       , let (subst', eta_id') = freshEtaId n subst (Scaled mult arg_ty)
-           -- Avoid free vars of the original expression
-       = go (n-1) subst' res_ty (EtaVar eta_id' : eis)
+       , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty)
+          -- Avoid free vars of the original expression
+
+       , let eta_id' = eta_id `setIdOneShotInfo` one_shot
+       = go (n+1) oss1 subst' res_ty (EtaVar eta_id' : eis)
 
        ----------- Newtypes
        -- Given this:
@@ -1206,12 +1236,12 @@ mkEtaWW orig_n ppr_orig_expr in_scope orig_ty
              -- Remember to apply the substitution to co (#16979)
              -- (or we could have applied to ty, but then
              --  we'd have had to zap it for the recursive call)
-       = go n subst ty' (pushCoercion co' eis)
+       = go n oss subst ty' (pushCoercion co' eis)
 
        | otherwise       -- We have an expression of arity > 0,
                          -- but its type isn't a function, or a binder
                          -- is levity-polymorphic
-       = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr_orig_expr )
+       = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr )
          (getTCvInScope subst, reverse eis)
         -- This *can* legitimately happen:
         -- e.g.  coerce Int (\x. x) Essentially the programmer is
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index ffddd62c8c..1577f3a151 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -46,7 +46,8 @@ import GHC.Core.Ppr     ( pprCoreExpr )
 import GHC.Types.Unique ( hasKey )
 import GHC.Core.Unfold
 import GHC.Core.Utils
-import GHC.Core.Opt.Arity ( etaExpand )
+import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType
+                          , idArityType, etaExpandAT )
 import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg
                           , joinPointBinding_maybe, joinPointBindings_maybe )
 import GHC.Core.FVs     ( mkRuleInfo )
@@ -706,10 +707,10 @@ makeTrivialBinding mode top_lvl occ_fs info expr expr_ty
 
         -- Now something very like completeBind,
         -- but without the postInlineUnconditionally part
-        ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1
+        ; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1
         ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2
 
-        ; let final_id = addLetBndrInfo var arity is_bot unf
+        ; let final_id = addLetBndrInfo var arity_type unf
               bind     = NonRec final_id expr2
 
         ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) }
@@ -799,14 +800,13 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
 
          -- Do eta-expansion on the RHS of the binding
          -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils
-      ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env)
-                                                          new_bndr new_rhs
+      ; (new_arity, final_rhs) <- tryEtaExpandRhs (getMode env) 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
 
-      ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding
+      ; let final_bndr = 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
@@ -823,10 +823,13 @@ completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
              -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $
              return (mkFloatBind env (NonRec final_bndr final_rhs)) }
 
-addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId
-addLetBndrInfo new_bndr new_arity is_bot new_unf
+addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId
+addLetBndrInfo new_bndr new_arity_type new_unf
   = new_bndr `setIdInfo` info5
   where
+    new_arity = arityTypeArity new_arity_type
+    is_bot    = isBotArityType new_arity_type
+
     info1 = idInfo new_bndr `setArityInfo` new_arity
 
     -- Unfolding info: Note [Setting the new unfolding]
@@ -844,12 +847,13 @@ addLetBndrInfo new_bndr new_arity is_bot new_unf
           = info2
 
     -- Bottoming bindings: see Note [Bottoming bindings]
-    info4 | is_bot    = info3
-                          `setStrictnessInfo`
-                            mkClosedStrictSig (replicate new_arity topDmd) botDiv
-                          `setCprInfo` mkCprSig new_arity botCpr
+    info4 | is_bot    = info3 `setStrictnessInfo` bot_sig
+                              `setCprInfo`        bot_cpr
           | otherwise = info3
 
+    bot_sig = mkClosedStrictSig (replicate new_arity topDmd) botDiv
+    bot_cpr = mkCprSig new_arity botCpr
+
      -- Zap call arity info. We have used it by now (via
      -- `tryEtaExpandRhs`), and the simplifier can invalidate this
      -- information, leading to broken code later (e.g. #13479)
@@ -860,9 +864,9 @@ addLetBndrInfo new_bndr new_arity is_bot new_unf
 ~~~~~~~~~~~~~~~~~~~~~~~~
 Generally speaking the arity of a binding should not decrease.  But it *can*
 legitimately happen because of RULES.  Eg
-        f = g Int
+        f = g @Int
 where g has arity 2, will have arity 2.  But if there's a rewrite rule
-        g Int --> h
+        g @Int --> h
 where h has arity 1, then f's arity will decrease.  Here's a real-life example,
 which is in the output of Specialise:
 
@@ -892,7 +896,7 @@ Then we'd like to drop the dead <alts> immediately.  So it's good to
 propagate the info that x's RHS is bottom to x's IdInfo as rapidly as
 possible.
 
-We use tryEtaExpandRhs on every binding, and it turns ou that the
+We use tryEtaExpandRhs on every binding, and it turns out that the
 arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already
 does a simple bottoming-expression analysis.  So all we need to do
 is propagate that info to the binder's IdInfo.
@@ -1551,7 +1555,7 @@ simplLamBndr env bndr
   | isId bndr && hasCoreUnfolding old_unf   -- Special case
   = do { (env1, bndr1) <- simplBinder env bndr
        ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr
-                                      (idType bndr1) (idArity bndr1) old_unf
+                                      (idType bndr1) (idArityType bndr1) old_unf
        ; let bndr2 = bndr1 `setIdUnfolding` unf'
        ; return (modifyInScope env1 bndr2, bndr2) }
 
@@ -3736,7 +3740,7 @@ because we don't know its usage in each RHS separately
 simplLetUnfolding :: SimplEnv-> TopLevelFlag
                   -> MaybeJoinCont
                   -> InId
-                  -> OutExpr -> OutType -> Arity
+                  -> OutExpr -> OutType -> ArityType
                   -> Unfolding -> SimplM Unfolding
 simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf
   | isStableUnfolding unf
@@ -3766,7 +3770,9 @@ mkLetUnfolding dflags top_lvl src id new_rhs
 simplStableUnfolding :: SimplEnv -> TopLevelFlag
                      -> MaybeJoinCont  -- Just k => a join point with continuation k
                      -> InId
-                     -> OutType -> Arity -> Unfolding
+                     -> OutType
+                     -> ArityType      -- Used to eta expand, but only for non-join-points
+                     -> Unfolding
                      ->SimplM Unfolding
 -- Note [Setting the new unfolding]
 simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf
@@ -3829,7 +3835,7 @@ simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf
     eta_expand expr
       | not eta_on         = expr
       | exprIsTrivial expr = expr
-      | otherwise          = etaExpand id_arity expr
+      | otherwise          = etaExpandAT id_arity expr
     eta_on = sm_eta_expand (getMode env)
 
 {- Note [Eta-expand stable unfoldings]
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index b4b0ad7062..e9ee16157f 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -1479,9 +1479,9 @@ mkLam env bndrs body cont
       , sm_eta_expand (getMode env)
       , any isRuntimeVar bndrs
       , let body_arity = exprEtaExpandArity dflags body
-      , body_arity > 0
+      , expandableArityType body_arity
       = do { tick (EtaExpansion (head bndrs))
-           ; let res = mkLams bndrs (etaExpand body_arity body)
+           ; let res = mkLams bndrs (etaExpandAT body_arity body)
            ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)
                                           , text "after" <+> ppr res])
            ; return res }
@@ -1551,7 +1551,7 @@ because the latter is not well-kinded.
 -}
 
 tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
-                -> SimplM (Arity, Bool, OutExpr)
+                -> SimplM (ArityType, OutExpr)
 -- See Note [Eta-expanding at let bindings]
 -- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then
 --   (a) rhs' has manifest arity n
@@ -1559,40 +1559,46 @@ tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
 tryEtaExpandRhs mode bndr rhs
   | Just join_arity <- isJoinId_maybe bndr
   = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
-       ; return (count isId join_bndrs, exprIsDeadEnd join_body, rhs) }
+             oss   = [idOneShotInfo id | id <- join_bndrs, isId id]
+             arity_type | exprIsDeadEnd join_body = ABot (length oss)
+                        | otherwise               = ATop oss
+       ; return (arity_type, rhs) }
          -- Note [Do not eta-expand join points]
          -- But do return the correct arity and bottom-ness, because
          -- these are used to set the bndr's IdInfo (#15517)
          -- Note [Invariants on join points] invariant 2b, in GHC.Core
 
+  | sm_eta_expand mode      -- Provided eta-expansion is on
+  , new_arity > old_arity   -- And the current manifest arity isn't enough
+  , want_eta rhs
+  = do { tick (EtaExpansion bndr)
+       ; return (arity_type, etaExpandAT arity_type rhs) }
+
   | otherwise
-  = do { (new_arity, is_bot, new_rhs) <- try_expand
+  = return (arity_type, rhs)
 
-       ; WARN( new_arity < old_id_arity,
-               (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity
-                <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )
-                        -- Note [Arity decrease] in GHC.Core.Opt.Simplify
-         return (new_arity, is_bot, new_rhs) }
   where
-    try_expand
-      | exprIsTrivial rhs  -- See Note [Do not eta-expand trivial expressions]
-      = return (exprArity rhs, False, rhs)
-
-      | sm_eta_expand mode      -- Provided eta-expansion is on
-      , new_arity > old_arity   -- And the current manifest arity isn't enough
-      = do { tick (EtaExpansion bndr)
-           ; return (new_arity, is_bot, etaExpand new_arity rhs) }
-
-      | otherwise
-      = return (old_arity, is_bot && new_arity == old_arity, rhs)
-
-    dflags       = sm_dflags mode
-    old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]
-    old_id_arity = idArity bndr
-
-    (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity
-    new_arity2 = idCallArity bndr
-    new_arity  = max new_arity1 new_arity2
+    dflags    = sm_dflags mode
+    old_arity = exprArity rhs
+
+    arity_type = findRhsArity dflags bndr rhs old_arity
+                 `maxWithArity` idCallArity bndr
+    new_arity = arityTypeArity arity_type
+
+    -- See Note [Which RHSs do we eta-expand?]
+    want_eta (Cast e _)                  = want_eta e
+    want_eta (Tick _ e)                  = want_eta e
+    want_eta (Lam b e) | isTyVar b       = want_eta e
+    want_eta (App e a) | exprIsTrivial a = want_eta e
+    want_eta (Var {})                    = False
+    want_eta (Lit {})                    = False
+    want_eta _ = True
+{-
+    want_eta _ = case arity_type of
+                   ATop (os:_) -> isOneShotInfo os
+                   ATop []     -> False
+                   ABot {}     -> True
+-}
 
 {-
 Note [Eta-expanding at let bindings]
@@ -1619,14 +1625,53 @@ because then 'genMap' will inline, and it really shouldn't: at least
 as far as the programmer is concerned, it's not applied to two
 arguments!
 
-Note [Do not eta-expand trivial expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Do not eta-expand a trivial RHS like
-  f = g
-If we eta expand do
-  f = \x. g x
-we'll just eta-reduce again, and so on; so the
-simplifier never terminates.
+Note [Which RHSs do we eta-expand?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't eta-expand:
+
+* Trivial RHSs, e.g.     f = g
+  If we eta expand do
+    f = \x. g x
+  we'll just eta-reduce again, and so on; so the
+  simplifier never terminates.
+
+* PAPs: see Note [Do not eta-expand PAPs]
+
+What about things like this?
+   f = case y of p -> \x -> blah
+
+Here we do eta-expand.  This is a change (Jun 20), but if we have
+really decided that f has arity 1, then putting that lambda at the top
+seems like a Good idea.
+
+Note [Do not eta-expand PAPs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to have old_arity = manifestArity rhs, which meant that we
+would eta-expand even PAPs.  But this gives no particular advantage,
+and can lead to a massive blow-up in code size, exhibited by #9020.
+Suppose we have a PAP
+    foo :: IO ()
+    foo = returnIO ()
+Then we can eta-expand do
+    foo = (\eta. (returnIO () |> sym g) eta) |> g
+where
+    g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)
+
+But there is really no point in doing this, and it generates masses of
+coercions and whatnot that eventually disappear again. For T9020, GHC
+allocated 6.6G before, and 0.8G afterwards; and residency dropped from
+1.8G to 45M.
+
+Moreover, if we eta expand
+        f = g d  ==>  f = \x. g d x
+that might in turn make g inline (if it has an inline pragma), which
+we might not want.  After all, INLINE pragmas say "inline only when
+saturated" so we don't want to be too gung-ho about saturating!
+
+But note that this won't eta-expand, say
+  f = \g -> map g
+Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps
+strictness analysis will have less to bite on?
 
 Note [Do not eta-expand join points]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1667,29 +1712,6 @@ CorePrep comes around, the code is very likely to look more like this:
              $j2 = if n > 0 then $j1
                             else (...) eta
 
-Note [Do not eta-expand PAPs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to have old_arity = manifestArity rhs, which meant that we
-would eta-expand even PAPs.  But this gives no particular advantage,
-and can lead to a massive blow-up in code size, exhibited by #9020.
-Suppose we have a PAP
-    foo :: IO ()
-    foo = returnIO ()
-Then we can eta-expand do
-    foo = (\eta. (returnIO () |> sym g) eta) |> g
-where
-    g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)
-
-But there is really no point in doing this, and it generates masses of
-coercions and whatnot that eventually disappear again. For T9020, GHC
-allocated 6.6G before, and 0.8G afterwards; and residency dropped from
-1.8G to 45M.
-
-But note that this won't eta-expand, say
-  f = \g -> map g
-Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps
-strictness analysis will have less to bite on?
-
 
 ************************************************************************
 *                                                                      *
diff --git a/testsuite/tests/profiling/should_run/T5654-O1.prof.sample b/testsuite/tests/profiling/should_run/T5654-O1.prof.sample
index 0e65631521..5da6ed89e7 100644
--- a/testsuite/tests/profiling/should_run/T5654-O1.prof.sample
+++ b/testsuite/tests/profiling/should_run/T5654-O1.prof.sample
@@ -1,27 +1,28 @@
-	Thu Dec  8 11:34 2016 Time and Allocation Profiling Report  (Final)
+	Thu Jul  9 17:12 2020 Time and Allocation Profiling Report  (Final)
 
-	   T5654-O1 +RTS -p -RTS
+	   T5654-O1 +RTS -hc -p -RTS
 
 	total time  =        0.00 secs   (0 ticks @ 1000 us, 1 processor)
-	total alloc =      39,064 bytes  (excludes profiling overheads)
+	total alloc =      38,664 bytes  (excludes profiling overheads)
 
 COST CENTRE MODULE           SRC              %time %alloc
 
-MAIN        MAIN             <built-in>         0.0    1.9
-CAF         GHC.IO.Handle.FD <entire-module>    0.0   88.6
-CAF         GHC.IO.Encoding  <entire-module>    0.0    7.1
-CAF         GHC.Conc.Signal  <entire-module>    0.0    1.6
+MAIN        MAIN             <built-in>         0.0    1.7
+CAF         GHC.IO.Handle.FD <entire-module>    0.0   89.7
+CAF         GHC.IO.Encoding  <entire-module>    0.0    6.3
+CAF         GHC.Conc.Signal  <entire-module>    0.0    1.7
 
 
-                                                                         individual      inherited
-COST CENTRE MODULE                SRC                 no.     entries  %time %alloc   %time %alloc
+                                                                          individual      inherited
+COST CENTRE  MODULE                SRC                 no.     entries  %time %alloc   %time %alloc
 
-MAIN        MAIN                  <built-in>          104          0    0.0    1.9     0.0  100.0
- CAF        Main                  <entire-module>     207          0    0.0    0.0     0.0    0.2
-  main      Main                  T5654-O1.hs:13:1-21 208          1    0.0    0.1     0.0    0.2
-   f        Main                  T5654-O1.hs:7:1-5   209          1    0.0    0.0     0.0    0.0
-    g       Main                  T5654-O1.hs:11:1-11 210          1    0.0    0.0     0.0    0.0
- CAF        GHC.Conc.Signal       <entire-module>     201          0    0.0    1.6     0.0    1.6
- CAF        GHC.IO.Encoding       <entire-module>     191          0    0.0    7.1     0.0    7.1
- CAF        GHC.IO.Encoding.Iconv <entire-module>     189          0    0.0    0.6     0.0    0.6
- CAF        GHC.IO.Handle.FD      <entire-module>     181          0    0.0   88.6     0.0   88.6
+MAIN         MAIN                  <built-in>          121           0    0.0    1.7     0.0  100.0
+ CAF         Main                  <entire-module>     241           0    0.0    0.0     0.0    0.1
+  f          Main                  T5654-O1.hs:7:1-5   243           1    0.0    0.0     0.0    0.0
+  main       Main                  T5654-O1.hs:13:1-21 242           1    0.0    0.1     0.0    0.1
+   f         Main                  T5654-O1.hs:7:1-5   244           0    0.0    0.0     0.0    0.0
+    g        Main                  T5654-O1.hs:11:1-11 245           1    0.0    0.0     0.0    0.0
+ CAF         GHC.Conc.Signal       <entire-module>     236           0    0.0    1.7     0.0    1.7
+ CAF         GHC.IO.Encoding       <entire-module>     227           0    0.0    6.3     0.0    6.3
+ CAF         GHC.IO.Encoding.Iconv <entire-module>     225           0    0.0    0.5     0.0    0.5
+ CAF         GHC.IO.Handle.FD      <entire-module>     217           0    0.0   89.7     0.0   89.7
diff --git a/testsuite/tests/profiling/should_run/T5654b-O1.prof.sample b/testsuite/tests/profiling/should_run/T5654b-O1.prof.sample
index 45ae0ba55c..2ff1e70bc7 100644
--- a/testsuite/tests/profiling/should_run/T5654b-O1.prof.sample
+++ b/testsuite/tests/profiling/should_run/T5654b-O1.prof.sample
@@ -1,28 +1,30 @@
-	Fri Jun  3 11:00 2016 Time and Allocation Profiling Report  (Final)
+	Thu Jul  9 17:12 2020 Time and Allocation Profiling Report  (Final)
 
 	   T5654b-O1 +RTS -hc -p -RTS
 
 	total time  =        0.00 secs   (0 ticks @ 1000 us, 1 processor)
-	total alloc =      38,880 bytes  (excludes profiling overheads)
+	total alloc =      38,728 bytes  (excludes profiling overheads)
 
 COST CENTRE MODULE           SRC              %time %alloc
 
 MAIN        MAIN             <built-in>         0.0    1.7
-CAF         GHC.IO.Handle.FD <entire-module>    0.0   88.8
-CAF         GHC.IO.Encoding  <entire-module>    0.0    7.1
+CAF         GHC.IO.Handle.FD <entire-module>    0.0   89.5
+CAF         GHC.IO.Encoding  <entire-module>    0.0    6.3
 CAF         GHC.Conc.Signal  <entire-module>    0.0    1.7
 
 
-                                                                          individual      inherited
-COST CENTRE MODULE                SRC                  no.     entries  %time %alloc   %time %alloc
+                                                                           individual      inherited
+COST CENTRE  MODULE                SRC                  no.     entries  %time %alloc   %time %alloc
 
-MAIN        MAIN                  <built-in>            43          0    0.0    1.7     0.0  100.0
- CAF        Main                  <entire-module>       85          0    0.0    0.0     0.0    0.1
-  main      Main                  T5654b-O1.hs:22:1-21  86          1    0.0    0.1     0.0    0.1
-   f        Main                  T5654b-O1.hs:12:1-7   87          1    0.0    0.0     0.0    0.0
-    g       Main                  T5654b-O1.hs:16:1-7   88          1    0.0    0.0     0.0    0.0
-     h      Main                  T5654b-O1.hs:20:1-19  89          1    0.0    0.0     0.0    0.0
- CAF        GHC.Conc.Signal       <entire-module>       79          0    0.0    1.7     0.0    1.7
- CAF        GHC.IO.Encoding       <entire-module>       74          0    0.0    7.1     0.0    7.1
- CAF        GHC.IO.Handle.FD      <entire-module>       72          0    0.0   88.8     0.0   88.8
- CAF        GHC.IO.Encoding.Iconv <entire-module>       53          0    0.0    0.6     0.0    0.6
+MAIN         MAIN                  <built-in>           121           0    0.0    1.7     0.0  100.0
+ CAF         Main                  <entire-module>      241           0    0.0    0.0     0.0    0.3
+  f          Main                  T5654b-O1.hs:12:1-7  243           1    0.0    0.1     0.0    0.1
+  g          Main                  T5654b-O1.hs:16:1-7  244           1    0.0    0.0     0.0    0.0
+  main       Main                  T5654b-O1.hs:22:1-21 242           1    0.0    0.1     0.0    0.1
+   f         Main                  T5654b-O1.hs:12:1-7  245           0    0.0    0.0     0.0    0.0
+    g        Main                  T5654b-O1.hs:16:1-7  246           0    0.0    0.0     0.0    0.0
+     h       Main                  T5654b-O1.hs:20:1-19 247           1    0.0    0.0     0.0    0.0
+ CAF         GHC.Conc.Signal       <entire-module>      236           0    0.0    1.7     0.0    1.7
+ CAF         GHC.IO.Encoding       <entire-module>      227           0    0.0    6.3     0.0    6.3
+ CAF         GHC.IO.Encoding.Iconv <entire-module>      225           0    0.0    0.5     0.0    0.5
+ CAF         GHC.IO.Handle.FD      <entire-module>      217           0    0.0   89.5     0.0   89.5
diff --git a/testsuite/tests/profiling/should_run/ioprof.stderr b/testsuite/tests/profiling/should_run/ioprof.stderr
index db9c36bbe3..0cb2b4b174 100644
--- a/testsuite/tests/profiling/should_run/ioprof.stderr
+++ b/testsuite/tests/profiling/should_run/ioprof.stderr
@@ -1,5 +1,5 @@
 ioprof: a
-CallStack (from ImplicitParams):
+CallStack (from HasCallStack):
   error, called at ioprof.hs:23:22 in main:Main
 CallStack (from -prof):
   Main.errorM.\ (ioprof.hs:23:22-28)
@@ -11,4 +11,3 @@ CallStack (from -prof):
   Main.bar (ioprof.hs:31:1-20)
   Main.runM (ioprof.hs:26:1-37)
   Main.main (ioprof.hs:28:1-43)
-  Main.CAF (<entire-module>)
diff --git a/testsuite/tests/simplCore/should_compile/T18355.hs b/testsuite/tests/simplCore/should_compile/T18355.hs
new file mode 100644
index 0000000000..207c2087d6
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T18355.hs
@@ -0,0 +1,9 @@
+module T18355 where
+
+import GHC.Exts
+
+-- I expect the simplified Core to have an eta-expaned
+-- defn of f, with a OneShot on the final lambda-binder
+f x b = case b of
+          True -> oneShot (\y -> x+y)
+          False -> \y -> x-y
diff --git a/testsuite/tests/simplCore/should_compile/T18355.stderr b/testsuite/tests/simplCore/should_compile/T18355.stderr
new file mode 100644
index 0000000000..50efeca4b1
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T18355.stderr
@@ -0,0 +1,70 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 32, types: 23, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 17, types: 10, coercions: 0, joins: 0/0}
+f :: forall {a}. Num a => a -> Bool -> a -> a
+[GblId,
+ Arity=4,
+ Str=<S,1*U(1*C1(C1(U)),1*C1(C1(U)),A,A,A,A,A)><L,U><S,1*U><L,U>,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (@a)
+                 ($dNum [Occ=Once*] :: Num a)
+                 (x [Occ=Once*] :: a)
+                 (b [Occ=Once!] :: Bool)
+                 (eta [Occ=Once*, OS=OneShot] :: a) ->
+                 case b of {
+                   False -> - @a $dNum x eta;
+                   True -> + @a $dNum x eta
+                 }}]
+f = \ (@a)
+      ($dNum :: Num a)
+      (x :: a)
+      (b :: Bool)
+      (eta [OS=OneShot] :: a) ->
+      case b of {
+        False -> - @a $dNum x eta;
+        True -> + @a $dNum x eta
+      }
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule4 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T18355.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T18355.$trModule3 = GHC.Types.TrNameS T18355.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule2 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T18355.$trModule2 = "T18355"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T18355.$trModule1 = GHC.Types.TrNameS T18355.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18355.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
+T18355.$trModule
+  = GHC.Types.Module T18355.$trModule3 T18355.$trModule1
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 93f7fc155a..0abd79858b 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -330,4 +330,5 @@ test('T17673', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, [
 test('T18078', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999'])
 test('T18328', [ only_ways(['optasm']), grep_errmsg(r'Arity=') ], compile, ['-ddump-simpl -dsuppress-uniques'])
 test('T18347', normal, compile, ['-dcore-lint -O'])
+test('T18355', [ grep_errmsg(r'OneShot') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('T18399', normal, compile, ['-dcore-lint -O'])