Drop absent bindings in worker/wrapper

Consider this (from #19824)
   let t = ...big...
   in ...(f t x)...

were `f` ignores its first argument.  With luck f's wrapper will inline
thereby dropping `t`, but maybe not: the arguments to f all look boring.

So we pre-empt the problem by replacing t's RHS with an absent filler
during w/w.  Simple and effective.

The main payload is the new `isAbsDmd` case in `tryWw`, but there are
some other minor refactorings:

* To implment this I had to refactor `mk_absent_let` to
  `mkAbsentFiller`, which can be called from `tryWW`.

* wwExpr took both WwOpts and DynFlags which seems silly.  I combined
  them into one.

* I renamed the historical mkInineRule to mkWrapperUnfolding

6 files changed, 138 insertions, 75 deletions

diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index a27ab91948..93813a1735 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -2890,7 +2890,7 @@ restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs
 {- Note [Do not mark CoVars as dead]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It's obviously wrong to mark CoVars as dead if they are used.
-Currently we don't traverse types to gather usase info for CoVars,
+Currently we don't traverse types to gather usage info for CoVars,
 so we had better treat them as having noOccInfo.
 
 This showed up in #15696 we had something like
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 05dbe4149a..9bf26f54d8 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -425,7 +425,8 @@ contIsDupable _                                 = False
 contIsTrivial :: SimplCont -> Bool
 contIsTrivial (Stop {})                                         = True
 contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k
-contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k
+-- This one doesn't look right.  A value application is not trivial
+-- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k
 contIsTrivial (CastIt _ k)                                      = contIsTrivial k
 contIsTrivial _                                                 = False
 
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index f07f6c5a42..87dcd92d1e 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -23,11 +23,11 @@ import GHC.Types.Unique.Supply
 import GHC.Types.Basic
 import GHC.Driver.Session
 import GHC.Driver.Ppr
-import GHC.Driver.Config
 import GHC.Types.Demand
 import GHC.Types.Cpr
 import GHC.Types.SourceText
 import GHC.Core.Opt.WorkWrap.Utils
+import GHC.Core.SimpleOpt( SimpleOpts(..) )
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Types.Unique
@@ -68,8 +68,10 @@ wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgra
 
 wwTopBinds dflags fam_envs us top_binds
   = initUs_ us $ do
-    top_binds' <- mapM (wwBind dflags fam_envs) top_binds
+    top_binds' <- mapM (wwBind ww_opts) top_binds
     return (concat top_binds')
+  where
+    ww_opts = initWwOpts dflags fam_envs
 
 {-
 ************************************************************************
@@ -82,25 +84,24 @@ wwTopBinds dflags fam_envs us top_binds
 turn.  Non-recursive case first, then recursive...
 -}
 
-wwBind  :: DynFlags
-        -> FamInstEnvs
+wwBind  :: WwOpts
         -> CoreBind
         -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;
                                 -- the caller will convert to Expr/Binding,
                                 -- as appropriate.
 
-wwBind dflags fam_envs (NonRec binder rhs) = do
-    new_rhs <- wwExpr dflags fam_envs rhs
-    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs
+wwBind ww_opts (NonRec binder rhs) = do
+    new_rhs   <- wwExpr ww_opts rhs
+    new_pairs <- tryWW ww_opts NonRecursive binder new_rhs
     return [NonRec b e | (b,e) <- new_pairs]
       -- Generated bindings must be non-recursive
       -- because the original binding was.
 
-wwBind dflags fam_envs (Rec pairs)
+wwBind ww_opts (Rec pairs)
   = return . Rec <$> concatMapM do_one pairs
   where
-    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs
-                              tryWW dflags fam_envs Recursive binder new_rhs
+    do_one (binder, rhs) = do new_rhs <- wwExpr ww_opts rhs
+                              tryWW ww_opts Recursive binder new_rhs
 
 {-
 @wwExpr@ basically just walks the tree, looking for appropriate
@@ -109,41 +110,41 @@ matching by looking for strict arguments of the correct type.
 @wwExpr@ is a version that just returns the ``Plain'' Tree.
 -}
 
-wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr
+wwExpr :: WwOpts -> CoreExpr -> UniqSM CoreExpr
 
-wwExpr _      _ e@(Type {}) = return e
-wwExpr _      _ e@(Coercion {}) = return e
-wwExpr _      _ e@(Lit  {}) = return e
-wwExpr _      _ e@(Var  {}) = return e
+wwExpr _ e@(Type {}) = return e
+wwExpr _ e@(Coercion {}) = return e
+wwExpr _ e@(Lit  {}) = return e
+wwExpr _ e@(Var  {}) = return e
 
-wwExpr dflags fam_envs (Lam binder expr)
-  = Lam new_binder <$> wwExpr dflags fam_envs expr
+wwExpr ww_opts (Lam binder expr)
+  = Lam new_binder <$> wwExpr ww_opts expr
   where new_binder | isId binder = zapIdUsedOnceInfo binder
                    | otherwise   = binder
   -- See Note [Zapping Used Once info in WorkWrap]
 
-wwExpr dflags fam_envs (App f a)
-  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a
+wwExpr ww_opts (App f a)
+  = App <$> wwExpr ww_opts f <*> wwExpr ww_opts a
 
-wwExpr dflags fam_envs (Tick note expr)
-  = Tick note <$> wwExpr dflags fam_envs expr
+wwExpr ww_opts (Tick note expr)
+  = Tick note <$> wwExpr ww_opts expr
 
-wwExpr dflags fam_envs (Cast expr co) = do
-    new_expr <- wwExpr dflags fam_envs expr
+wwExpr ww_opts (Cast expr co) = do
+    new_expr <- wwExpr ww_opts expr
     return (Cast new_expr co)
 
-wwExpr dflags fam_envs (Let bind expr)
-  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr
+wwExpr ww_opts (Let bind expr)
+  = mkLets <$> wwBind ww_opts bind <*> wwExpr ww_opts expr
 
-wwExpr dflags fam_envs (Case expr binder ty alts) = do
-    new_expr <- wwExpr dflags fam_envs expr
+wwExpr ww_opts (Case expr binder ty alts) = do
+    new_expr <- wwExpr ww_opts expr
     new_alts <- mapM ww_alt alts
     let new_binder = zapIdUsedOnceInfo binder
       -- See Note [Zapping Used Once info in WorkWrap]
     return (Case new_expr new_binder ty new_alts)
   where
     ww_alt (Alt con binders rhs) = do
-        new_rhs <- wwExpr dflags fam_envs rhs
+        new_rhs <- wwExpr ww_opts rhs
         let new_binders = [ if isId b then zapIdUsedOnceInfo b else b
                           | b <- binders ]
            -- See Note [Zapping Used Once info in WorkWrap]
@@ -461,7 +462,7 @@ Conclusion:
     exists. NB: Similar to InitialPhase, users can't write INLINE[Final] f;
     it's syntactically illegal.
 
-  - Otherwise inline wrapper in phase 2.  That allows the
+  - Otherwise inline wrapper in phase Final.  That allows the
     'gentle' simplification pass to apply specialisation rules
 
 Note [Wrapper NoUserInlinePrag]
@@ -477,10 +478,20 @@ happen for w/w’ed things (#14186).  We don't need a pragma, because
 everything we needs is expressed by (a) the stable unfolding and (b)
 the inl_act activation.)
 
+Note [Drop absent bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#19824):
+   let t = ...big...
+   in ...(f t x)...
+
+were `f` ignores its first argument.  With luck f's wrapper will inline
+thereby dropping `t`, but maybe not: the arguments to f all look boring.
+
+So we pre-empt the problem by replacing t's RHS with an absent filler.
+Simple and effective.
 -}
 
-tryWW   :: DynFlags
-        -> FamInstEnvs
+tryWW   :: WwOpts
         -> RecFlag
         -> Id                           -- The fn binder
         -> CoreExpr                     -- The bound rhs; its innards
@@ -490,17 +501,26 @@ tryWW   :: DynFlags
                                         -- the orig "wrapper" lives on);
                                         -- if two, then a worker and a
                                         -- wrapper.
-tryWW dflags fam_envs is_rec fn_id rhs
+tryWW ww_opts is_rec fn_id rhs
+  -- Do this even if there is a NOINLINE pragma
   -- See Note [Worker/wrapper for NOINLINE functions]
 
-  | isRecordSelector fn_id  -- See Note [No worker/wrapper for record selectors]
+  -- See Note [Drop absent bindings]
+  | isAbsDmd (demandInfo fn_info)
+  , not (isJoinId fn_id)
+  , Just filler <- mkAbsentFiller ww_opts fn_id
+  = return [(new_fn_id, filler)]
+
+  -- See Note [No worker/wrapper for record selectors]
+  | isRecordSelector fn_id
   = return [ (new_fn_id, rhs ) ]
 
   | is_fun && is_eta_exp
-  = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs
+  = splitFun ww_opts new_fn_id fn_info wrap_dmds div cpr rhs
 
-  | isNonRec is_rec, is_thunk                        -- See Note [Thunk splitting]
-  = splitThunk dflags fam_envs is_rec new_fn_id rhs
+  -- See Note [Thunk splitting]
+  | isNonRec is_rec, is_thunk
+  = splitThunk ww_opts is_rec new_fn_id rhs
 
   | otherwise
   = return [ (new_fn_id, rhs) ]
@@ -621,34 +641,59 @@ be inlined. That would lead to reboxing, because the analysis tacitly assumes
 that we W/W'd for idArity and will propagate analysis information under that
 assumption. So far, this doesn't seem to matter in practice.
 See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.
+
+Note [Inline pragma for certainlyWillInline]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (#19824 comment on 15 May 21):
+  f _ (x,y) = ...big...
+  v = ...big...
+  g x = f v x + 1
+
+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 -}
+    = ...blah...
+
+Since (a) that unfolding for g is AlwaysActive
+      (b) the unfolding for f's wrapper is ActiveAfterInitial
+the call of f will never inline in g's stable unfolding, thereby
+keeping `v` alive.
+
+I thought of changing g's unfolding to be ActiveAfterInitial, but that
+too is bad: it delays g's inlining into other modules, which makes fewer
+specialisations happen. Example in perf/should_run/DeriveNull.
+
+So I decided to live with the problem.  In fact v's RHS will be replaced
+by LitRubbish (see Note [Drop absent bindings]) so there is no great harm.
 -}
 
 
 ---------------------
-splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr
+splitFun :: WwOpts -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr
          -> UniqSM [(Id, CoreExpr)]
-splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
-  = warnPprTrace (not (wrap_dmds `lengthIs` arity)) (ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr)) $
-          -- The arity should match the signature
-    do { mb_stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_dmds use_cpr_info
+splitFun ww_opts fn_id fn_info wrap_dmds div cpr 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)]
 
             Just stuff
-              | Just stable_unf <- certainlyWillInline (unfoldingOpts dflags) fn_info
-              ->  return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]
+              | Just stable_unf <- certainlyWillInline uf_opts fn_info
+              , 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
-                    ; return (mkWWBindPair dflags fn_id fn_info arity rhs
+                    ; return (mkWWBindPair ww_opts fn_id fn_info rhs
                                            work_uniq div cpr stuff) } }
   where
+    uf_opts = so_uf_opts (wo_simple_opts ww_opts)
     rhs_fvs = exprFreeVars rhs
-    arity   = arityInfo fn_info
-            -- The arity is set by the simplifier using exprEtaExpandArity
-            -- So it may be more than the number of top-level-visible lambdas
 
     -- 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].
@@ -656,16 +701,20 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
                   | otherwise      = cpr
 
 
-mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity
+mkWWBindPair :: WwOpts -> Id -> IdInfo
              -> CoreExpr -> Unique -> Divergence -> Cpr
              -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)
              -> [(Id, CoreExpr)]
-mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr
+mkWWBindPair ww_opts fn_id fn_info rhs work_uniq div cpr
              (work_demands, join_arity, wrap_fn, work_fn)
   = [(work_id, work_rhs), (wrap_id, wrap_rhs)]
      -- Worker first, because wrapper mentions it
   where
-    simpl_opts = initSimpleOpts dflags
+    arity = arityInfo fn_info
+            -- The arity is set by the simplifier using exprEtaExpandArity
+            -- So it may be more than the number of top-level-visible lambdas
+
+    simpl_opts = wo_simple_opts ww_opts
 
     work_rhs = work_fn rhs
     work_act = case fn_inline_spec of  -- See Note [Worker activation]
@@ -721,8 +770,9 @@ mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr
 
     wrap_rhs  = wrap_fn work_id
     wrap_prag = mkStrWrapperInlinePrag fn_inl_prag
+    wrap_unf  = mkWrapperUnfolding simpl_opts wrap_rhs arity
 
-    wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule simpl_opts wrap_rhs arity
+    wrap_id   = fn_id `setIdUnfolding`  wrap_unf
                       `setInlinePragma` wrap_prag
                       `setIdOccInfo`    noOccInfo
                         -- Zap any loop-breaker-ness, to avoid bleating from Lint
@@ -885,12 +935,12 @@ get around by localising the Id for the auxiliary bindings in 'splitThunk'.
 --
 -- How can we do thunk-splitting on a top-level binder?  See
 -- Note [Thunk splitting for top-level binders].
-splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
-splitThunk dflags fam_envs is_rec x rhs
+splitThunk :: WwOpts -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
+splitThunk ww_opts is_rec x rhs
   = assert (not (isJoinId x)) $
     do { let x' = localiseId x -- See comment above
        ; (useful,_, wrap_fn, work_fn)
-           <- mkWWstr (initWwOpts dflags fam_envs) NotArgOfInlineableFun [x']
+           <- mkWWstr ww_opts NotArgOfInlineableFun [x']
        ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ]
        ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive
                    return res
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 127e684938..839c2ccd68 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -11,7 +11,7 @@ module GHC.Core.Opt.WorkWrap.Utils
    ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWorkerArgs
    , DataConPatContext(..)
    , UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnboxArg
-   , findTypeShape
+   , findTypeShape, mkAbsentFiller
    , isWorkerSmallEnough
    )
 where
@@ -41,6 +41,8 @@ import GHC.Core.FamInstEnv
 import GHC.Types.Basic       ( Boxity(..) )
 import GHC.Core.TyCon
 import GHC.Core.TyCon.RecWalk
+import GHC.Core.SimpleOpt( SimpleOpts )
+
 import GHC.Types.Unique.Supply
 import GHC.Types.Unique
 import GHC.Types.Name ( getOccFS )
@@ -50,6 +52,7 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Driver.Session
 import GHC.Driver.Ppr
+import GHC.Driver.Config( initSimpleOpts )
 import GHC.Data.FastString
 import GHC.Data.OrdList
 import GHC.Data.List.SetOps
@@ -132,6 +135,7 @@ the unusable strictness-info into the interfaces.
 data WwOpts
   = MkWwOpts
   { wo_fam_envs          :: !FamInstEnvs
+  , wo_simple_opts       :: !SimpleOpts
   , wo_cpr_anal          :: !Bool
   , wo_fun_to_thunk      :: !Bool
   , wo_max_worker_args   :: !Int
@@ -141,6 +145,7 @@ data WwOpts
 initWwOpts :: DynFlags -> FamInstEnvs -> WwOpts
 initWwOpts dflags fam_envs = MkWwOpts
   { wo_fam_envs          = fam_envs
+  , wo_simple_opts       = initSimpleOpts dflags
   , wo_cpr_anal          = gopt Opt_CprAnal dflags
   , wo_fun_to_thunk      = gopt Opt_FunToThunk dflags
   , wo_max_worker_args   = maxWorkerArgs dflags
@@ -965,11 +970,11 @@ mkWWstr_one opts inlineable_flag arg =
     _ | isTyVar arg -> do_nothing
 
     DropAbsent
-      | Just work_fn <- mk_absent_let opts arg
+      | Just absent_filler <- mkAbsentFiller opts arg
          -- Absent case.  We can't always handle absence for arbitrary
          -- unlifted types, so we need to choose just the cases we can
          -- (that's what mk_absent_let does)
-      -> return (True, [], nop_fn, work_fn)
+      -> return (True, [], nop_fn, bindNonRec arg absent_filler)
 
     Unbox dcpc cs -> unbox_one_arg opts arg cs dcpc
 
@@ -1010,21 +1015,19 @@ unbox_one_arg opts arg cs
 -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding
 -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be
 -- found.
-mk_absent_let :: WwOpts -> Id -> Maybe (CoreExpr -> CoreExpr)
-mk_absent_let opts arg
+mkAbsentFiller :: WwOpts -> Id -> Maybe CoreExpr
+mkAbsentFiller opts arg
   -- The lifted case: Bind 'absentError' for a nice panic message if we are
   -- wrong (like we were in #11126). See (1) in Note [Absent fillers]
   | not (isUnliftedType arg_ty)
   , not (isStrictDmd (idDemandInfo arg)) -- See (2) in Note [Absent fillers]
-  = Just (Let (NonRec arg panic_rhs))
+  = Just panic_rhs
 
   -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty`
   -- See Note [Absent fillers], the main part
-  | Just lit_expr <- mkLitRubbish arg_ty
-  = Just (bindNonRec arg lit_expr)
-
   | otherwise
-  = Nothing
+  = mkLitRubbish arg_ty
+
   where
     arg_ty = idType arg
 
diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs
index 84cd5168db..e911d722ee 100644
--- a/compiler/GHC/Core/Unfold/Make.hs
+++ b/compiler/GHC/Core/Unfold/Make.hs
@@ -11,7 +11,7 @@ module GHC.Core.Unfold.Make
    , mkInlineUnfolding
    , mkInlineUnfoldingWithArity
    , mkInlinableUnfolding
-   , mkWwInlineRule
+   , mkWrapperUnfolding
    , mkCompulsoryUnfolding
    , mkCompulsoryUnfolding'
    , mkDFunUnfolding
@@ -78,12 +78,15 @@ mkDFunUnfolding bndrs con ops
                   , df_args = map occurAnalyseExpr ops }
                   -- See Note [Occurrence analysis of unfoldings]
 
-mkWwInlineRule :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
-mkWwInlineRule opts expr arity
+mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
+-- Make the unfolding for the wrapper in a worker/wrapper split
+-- after demand/CPR analysis
+mkWrapperUnfolding opts expr arity
   = mkCoreUnfolding InlineStable True
-                   (simpleOptExpr opts expr)
-                   (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk
-                            , ug_boring_ok = boringCxtNotOk })
+                    (simpleOptExpr opts expr)
+                    (UnfWhen { ug_arity     = arity
+                             , ug_unsat_ok  = unSaturatedOk
+                             , ug_boring_ok = boringCxtNotOk })
 
 mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
 -- See Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index fbf871dd7d..b18e93c951 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -1609,11 +1609,17 @@ expr_ok primop_ok other_expr
   | (expr, args) <- collectArgs other_expr
   = case stripTicksTopE (not . tickishCounts) expr of
         Var f            -> app_ok primop_ok f args
+
         -- 'LitRubbish' is the only literal that can occur in the head of an
         -- application and will not be matched by the above case (Var /= Lit).
-        Lit LitRubbish{}  -> True
-        Lit _ | debugIsOn -> pprPanic "Non-rubbish lit in app head" (ppr other_expr)
-        _                 -> False
+        -- See Note [How a rubbish literal can be the head of an application]
+        -- in GHC.Types.Literal
+        Lit lit | debugIsOn, not (isLitRubbish lit)
+                 -> pprPanic "Non-rubbish lit in app head" (ppr lit)
+                 | otherwise
+                 -> True
+
+        _ -> False
 
 -----------------------------
 app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool