Factor out DynFlags from WorkWrap.Utils

Plus a few minor refactorings:

  * Introduce `normSplitTyConApp_maybe` to Core.Utils
  * Reduce boolean blindness in the Bool argument to `wantToUnbox`
  * Let `wantToUnbox` also decide when to drop an argument, cleaning up
    `mkWWstr_one`

6 files changed, 148 insertions, 112 deletions

diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index cd4c310b3a..ddafa72b33 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -483,7 +483,7 @@ argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd)
   where
     go ty dmd
       | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds
-          <- wantToUnbox (ae_fam_envs env) no_inlineable_prag ty dmd
+          <- wantToUnbox (ae_fam_envs env) MaybeArgOfInlineableFun ty dmd
       -- No existentials; see Note [Which types are unboxed?])
       -- Otherwise we'd need to call dataConRepInstPat here and thread a
       -- UniqSupply. So argCprType is a bit less aggressive than it could
@@ -493,11 +493,6 @@ argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd)
       = ConCpr (dataConTag dc) (zipWith go arg_tys ds)
       | otherwise
       = topCpr
-    -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE
-    -- function, we just assume that we aren't. That flag is only relevant
-    -- to Note [Do not unpack class dictionaries], the few unboxing
-    -- opportunities on dicts it prohibits are probably irrelevant to CPR.
-    no_inlineable_prag = False
 
 {- Note [Safe abortion in the fixed-point iteration]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index b317fa5ff5..11270ae8a8 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -537,10 +537,9 @@ forcesRealWorld :: FamInstEnvs -> Type -> Bool
 forcesRealWorld fam_envs ty
   | ty `eqType` realWorldStatePrimTy
   = True
-  | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args }
-      <- splitArgType_maybe fam_envs ty
-  , isUnboxedTupleDataCon dc
-  , let field_tys = dataConInstArgTys dc tc_args
+  | Just (tc, tc_args, _co)  <- normSplitTyConApp_maybe fam_envs ty
+  , isUnboxedTupleTyCon tc
+  , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args
   = any (eqType realWorldStatePrimTy . scaledThing) field_tys
   | otherwise
   = False
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index f21d0205f5..c5e89b2ba9 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1720,7 +1720,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
                 -- And build the results
         ; let spec_body_ty   = exprType spec_body
               spec_lam_args1 = qvars ++ extra_bndrs
-              (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)
+              (spec_lam_args, spec_call_args) = mkWorkerArgs False
                                                              spec_lam_args1 spec_body_ty
                 -- mkWorkerArgs: usual w/w hack to avoid generating
                 -- a spec_rhs of unlifted type and no args
@@ -2031,8 +2031,9 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
 
               -- Remove ones that have too many worker variables
               small_pats = filterOut too_big non_dups
+              max_args = maxWorkerArgs (sc_dflags env)
               too_big (CP { cp_qvars = vars, cp_args = args })
-                = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars)
+                = not (isWorkerSmallEnough max_args (valArgCount args) vars)
                   -- We are about to construct w/w pair in 'spec_one'.
                   -- Omit specialisation leading to high arity workers.
                   -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index 2ee334b9f8..a85ff4d04e 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -611,7 +611,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
   | otherwise
   = WARN( 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 dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info
+    do { mb_stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_dmds use_cpr_info
        ; case mb_stuff of
             Nothing -> return [(fn_id, rhs)]
 
@@ -870,7 +870,8 @@ splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(
 splitThunk dflags fam_envs is_rec x rhs
   = ASSERT(not (isJoinId x))
     do { let x' = localiseId x -- See comment above
-       ; (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [x']
+       ; (useful,_, wrap_fn, work_fn)
+           <- mkWWstr (initWwOpts dflags fam_envs) NotArgOfInlineableFun [x']
        ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ]
        ; if useful then ASSERT2( 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 f51e716c38..b257e6d27a 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -7,8 +7,9 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser
 {-# LANGUAGE CPP #-}
 
 module GHC.Core.Opt.WorkWrap.Utils
-   ( mkWwBodies, mkWWstr, mkWorkerArgs
-   , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox
+   ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWorkerArgs
+   , DataConPatContext(..), splitArgType_maybe
+   , UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnbox
    , findTypeShape
    , isWorkerSmallEnough
    )
@@ -20,7 +21,8 @@ import GHC.Prelude
 
 import GHC.Core
 import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase
-                        , bindNonRec, dataConRepFSInstPat )
+                        , bindNonRec, dataConRepFSInstPat
+                        , normSplitTyConApp_maybe )
 import GHC.Types.Id
 import GHC.Types.Id.Info ( JoinArity )
 import GHC.Core.DataCon
@@ -45,7 +47,6 @@ import GHC.Core.TyCon.RecWalk
 import GHC.Types.Unique.Supply
 import GHC.Types.Unique
 import GHC.Types.Name ( getOccFS )
-import GHC.Data.Maybe
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -123,14 +124,31 @@ the unusable strictness-info into the interfaces.
 @mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
 -}
 
+data WwOpts
+  = MkWwOpts
+  { wo_fam_envs          :: !FamInstEnvs
+  , wo_cpr_anal          :: !Bool
+  , wo_fun_to_thunk      :: !Bool
+  , wo_max_worker_args   :: !Int
+  , wo_output_file       :: Maybe String
+  }
+
+initWwOpts :: DynFlags -> FamInstEnvs -> WwOpts
+initWwOpts dflags fam_envs = MkWwOpts
+  { wo_fam_envs          = fam_envs
+  , wo_cpr_anal          = gopt Opt_CprAnal dflags
+  , wo_fun_to_thunk      = gopt Opt_FunToThunk dflags
+  , wo_max_worker_args   = maxWorkerArgs dflags
+  , wo_output_file       = outputFile dflags
+  }
+
 type WwResult
   = ([Demand],              -- Demands for worker (value) args
      JoinArity,             -- Number of worker (type OR value) args
      Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id
      CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs
 
-mkWwBodies :: DynFlags
-           -> FamInstEnvs
+mkWwBodies :: WwOpts
            -> VarSet         -- Free vars of RHS
                              -- See Note [Freshen WW arguments]
            -> Id             -- The original function
@@ -149,25 +167,25 @@ mkWwBodies :: DynFlags
 --                        let x = (a,b) in
 --                        E
 
-mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
+mkWwBodies opts rhs_fvs fun_id demands cpr_info
   = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)
                 -- See Note [Freshen WW arguments]
 
         ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
              <- mkWWargs empty_subst fun_ty demands
         ; (useful1, work_args, wrap_fn_str, work_fn_str)
-             <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args
+             <- mkWWstr opts inlineable_flag wrap_args
 
         -- Do CPR w/w.  See Note [Always do CPR w/w]
         ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
-              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info
+              <- mkWWcpr opts res_ty cpr_info
 
-        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty
+        ; let (work_lam_args, work_call_args) = mkWorkerArgs (wo_fun_to_thunk opts) work_args cpr_res_ty
               worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
               wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
               worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args
 
-        ; if isWorkerSmallEnough dflags (length demands) work_args
+        ; if isWorkerSmallEnough (wo_max_worker_args opts) (length demands) work_args
              && not (too_many_args_for_join_point wrap_args)
              && ((useful1 && not only_one_void_argument) || useful2)
           then return (Just (worker_args_dmds, length work_call_args,
@@ -184,8 +202,9 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
   where
     fun_ty        = idType fun_id
     mb_join_arity = isJoinId_maybe fun_id
-    has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)
-                          -- See Note [Do not unpack class dictionaries]
+    inlineable_flag -- See Note [Do not unpack class dictionaries]
+      | isStableUnfolding (realIdUnfolding fun_id) = MaybeArgOfInlineableFun
+      | otherwise                                  = NotArgOfInlineableFun
 
     -- Note [Do not split void functions]
     only_one_void_argument
@@ -208,9 +227,9 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
       = False
 
 -- See Note [Limit w/w arity]
-isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool
-isWorkerSmallEnough dflags old_n_args vars
-  = count isId vars <= max old_n_args (maxWorkerArgs dflags)
+isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool
+isWorkerSmallEnough max_worker_args old_n_args vars
+  = count isId vars <= max old_n_args max_worker_args
     -- We count only Free variables (isId) to skip Type, Kind
     -- variables which have no runtime representation.
     -- Also if the function took 82 arguments before (old_n_args), it's fine if
@@ -274,11 +293,12 @@ add a void argument.  E.g.
 We use the state-token type which generates no code.
 -}
 
-mkWorkerArgs :: DynFlags -> [Var]
+mkWorkerArgs :: Bool
+             -> [Var]
              -> Type    -- Type of body
              -> ([Var], -- Lambda bound args
                  [Var]) -- Args at call site
-mkWorkerArgs dflags args res_ty
+mkWorkerArgs fun_to_thunk args res_ty
     | any isId args || not needsAValueLambda
     = (args, args)
     | otherwise
@@ -290,7 +310,7 @@ mkWorkerArgs dflags args res_ty
         -- We may encounter a levity-polymorphic result, in which case we
         -- conservatively assume that we have laziness that needs preservation.
         -- See #15186.
-        || not (gopt Opt_FunToThunk dflags)
+        || not fun_to_thunk
            -- see Note [Protecting the last value argument]
 
       -- Might the result be lifted?
@@ -546,9 +566,7 @@ data DataConPatContext
 -- See Note [Which types are unboxed?].
 splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext
 splitArgType_maybe fam_envs ty
-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
-                    `orElse` (mkRepReflCo ty, ty)
-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+  | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty
   , Just con <- tyConSingleAlgDataCon_maybe tc
   = Just DataConPatContext { dcpc_dc      = con
                            , dcpc_tc_args = tc_args
@@ -564,9 +582,7 @@ splitArgType_maybe _ _ = Nothing
 -- See Note [Which types are unboxed?].
 splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext
 splitResultType_maybe fam_envs con_tag ty
-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
-                    `orElse` (mkRepReflCo ty, ty)
-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+  | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty
   , isDataTyCon tc -- NB: rules out unboxed sums and pairs!
   , let cons = tyConDataCons tc
   , cons `lengthAtLeast` con_tag -- This might not be true if we import the
@@ -596,6 +612,8 @@ isLinear (Scaled w _ ) =
 data UnboxingDecision s
   = StopUnboxing
   -- ^ We ran out of strictness info. Leave untouched.
+  | DropAbsent
+  -- ^ The argument/field was absent. Drop it.
   | Unbox !DataConPatContext [s]
   -- ^ The argument is used strictly or the returned product was constructed, so
   -- unbox it.
@@ -604,23 +622,36 @@ data UnboxingDecision s
   -- The @[s]@ carries the bits of information with which we can continue
   -- unboxing, e.g. @s@ will be 'Demand'.
 
-wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand
+-- | A specialised Bool for an argument to 'wantToUnbox'.
+-- See Note [Do not unpack class dictionaries].
+data ArgOfInlineableFun
+  = NotArgOfInlineableFun   -- ^ Definitely not in an inlineable fun.
+  | MaybeArgOfInlineableFun -- ^ We might be in an inlineable fun, so we won't
+                            -- unbox dictionary args.
+  deriving Eq
+
+wantToUnbox :: FamInstEnvs -> ArgOfInlineableFun -> Type -> Demand -> UnboxingDecision Demand
 -- See Note [Which types are unboxed?]
-wantToUnbox fam_envs has_inlineable_prag ty dmd =
-  case splitArgType_maybe fam_envs ty of
-    Just dcpc@DataConPatContext{ dcpc_dc = dc }
-      | isStrUsedDmd dmd
-      , let arity = dataConRepArity dc
-      -- See Note [Unpacking arguments with product and polymorphic demands]
-      , Just cs <- split_prod_dmd_arity dmd arity
-      -- See Note [Do not unpack class dictionaries]
-      , not (has_inlineable_prag && isClassPred ty)
-      -- See Note [mkWWstr and unsafeCoerce]
-      , cs `lengthIs` arity
-      -- See Note [Add demands for strict constructors]
-      , let cs' = addDataConStrictness dc cs
-      -> Unbox dcpc cs'
-    _ -> StopUnboxing
+wantToUnbox fam_envs inlineable_flag ty dmd
+  | isAbsDmd dmd
+  = DropAbsent
+
+  | isStrUsedDmd dmd
+  , Just dcpc@DataConPatContext{ dcpc_dc = dc } <- splitArgType_maybe fam_envs ty
+  , let arity = dataConRepArity dc
+  -- See Note [Unpacking arguments with product and polymorphic demands]
+  , Just cs <- split_prod_dmd_arity dmd arity
+  -- See Note [Do not unpack class dictionaries]
+  , inlineable_flag == NotArgOfInlineableFun || not (isClassPred ty)
+  -- See Note [mkWWstr and unsafeCoerce]
+  , cs `lengthIs` arity
+  -- See Note [Add demands for strict constructors]
+  , let cs' = addDataConStrictness dc cs
+  = Unbox dcpc cs'
+
+  | otherwise
+  = StopUnboxing
+
   where
     split_prod_dmd_arity dmd arity
       -- For seqDmd, it should behave like <S(AAAA)>, for some
@@ -850,25 +881,23 @@ the case on `x` up through the case on `burble`.
 ************************************************************************
 -}
 
-mkWWstr :: DynFlags
-        -> FamInstEnvs
-        -> Bool    -- True <=> INLINEABLE pragma on this function defn
-                   -- See Note [Do not unpack class dictionaries]
-        -> [Var]                                -- Wrapper args; have their demand info on them
-                                                --  *Includes type variables*
-        -> UniqSM (Bool,                        -- Is this useful
-                   [Var],                       -- Worker args
-                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call
-                                                -- and without its lambdas
-                                                -- This fn adds the unboxing
-
-                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,
-                                                -- and lacking its lambdas.
-                                                -- This fn does the reboxing
-mkWWstr dflags fam_envs has_inlineable_prag args
+mkWWstr :: WwOpts
+        -> ArgOfInlineableFun            -- See Note [Do not unpack class dictionaries]
+        -> [Var]                         -- Wrapper args; have their demand info on them
+                                         --  *Includes type variables*
+        -> UniqSM (Bool,                 -- Is this useful
+                   [Var],                -- Worker args
+                   CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
+                                         -- and without its lambdas
+                                         -- This fn adds the unboxing
+
+                   CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
+                                         -- and lacking its lambdas.
+                                         -- This fn does the reboxing
+mkWWstr opts inlineable_flag args
   = go args
   where
-    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg
+    go_one arg = mkWWstr_one opts inlineable_flag arg
 
     go []           = return (False, [], nop_fn, nop_fn)
     go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg
@@ -885,37 +914,37 @@ mkWWstr dflags fam_envs has_inlineable_prag args
 --   * work_fn assumes work_args are in scope, a
 --        brings into scope wrap_arg (via lets)
 -- See Note [How to do the worker/wrapper split]
-mkWWstr_one :: DynFlags -> FamInstEnvs
-            -> Bool    -- True <=> INLINEABLE pragma on this function defn
-                       -- See Note [Do not unpack class dictionaries]
+mkWWstr_one :: WwOpts
+            -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries]
             -> Var
             -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-mkWWstr_one dflags fam_envs has_inlineable_prag arg
-  | isTyVar arg
-  = return (False, [arg],  nop_fn, nop_fn)
+mkWWstr_one opts inlineable_flag arg =
+  case wantToUnbox fam_envs inlineable_flag arg_ty arg_dmd of
+    _ | isTyVar arg -> do_nothing
 
-  | isAbsDmd dmd
-  , Just work_fn <- mk_absent_let dflags arg dmd
-     -- Absent case.  We can't always handle absence for rep-polymorphic
-     -- types, so we need to choose just the cases we can
-     -- (that's what mk_absent_let does)
-  = return (True, [], nop_fn, work_fn)
+    DropAbsent
+      | Just work_fn <- mk_absent_let 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)
 
-  | Unbox dcpc cs <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd
-  = unbox_one dflags fam_envs arg cs dcpc
+    Unbox dcpc cs -> unbox_one opts arg cs dcpc
 
-  | otherwise   -- Other cases
-  = return (False, [arg], nop_fn, nop_fn)
+    _ -> do_nothing -- Other cases, like StopUnboxing
 
   where
-    arg_ty = idType arg
-    dmd    = idDemandInfo arg
+    fam_envs   = wo_fam_envs opts
+    arg_ty     = idType arg
+    arg_dmd    = idDemandInfo arg
+    do_nothing = return (False, [arg], nop_fn, nop_fn)
 
-unbox_one :: DynFlags -> FamInstEnvs -> Var
+unbox_one :: WwOpts
+          -> Var
           -> [Demand]
           -> DataConPatContext
           -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-unbox_one dflags fam_envs arg cs
+unbox_one opts arg cs
           DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
                             , dcpc_co = co }
   = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM
@@ -930,7 +959,7 @@ unbox_one dflags fam_envs arg cs
                           -- in GHC.Core.Opt.Simplify; and see #13890
              rebox_fn   = Let (NonRec arg_no_unf con_app)
              con_app    = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co
-       ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids')
+       ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr opts NotArgOfInlineableFun (ex_tvs' ++ arg_ids')
        ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
                           -- Don't pass the arg, rebox instead
 
@@ -1142,8 +1171,7 @@ The non-CPR results appear ordered in the unboxed tuple as if by a
 left-to-right traversal of the result structure.
 -}
 
-mkWWcpr :: Bool
-        -> FamInstEnvs
+mkWWcpr :: WwOpts
         -> Type                              -- function body type
         -> Cpr                               -- CPR analysis results
         -> UniqSM (Bool,                     -- Is w/w'ing useful?
@@ -1151,15 +1179,15 @@ mkWWcpr :: Bool
                    CoreExpr -> CoreExpr,     -- New worker
                    Type)                     -- Type of worker's body
 
-mkWWcpr opt_CprAnal fam_envs body_ty cpr
+mkWWcpr opts body_ty cpr
     -- CPR explicitly turned off (or in -O0)
-  | not opt_CprAnal = return (False, id, id, body_ty)
+  | not (wo_cpr_anal opts) = return (False, id, id, body_ty)
     -- CPR is turned on by default for -O and O2
   | otherwise
   = case asConCpr cpr of
        Nothing      -> return (False, id, id, body_ty)  -- No CPR info
        Just (con_tag, _cprs)
-         | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty
+         | Just dcpc <- splitResultType_maybe (wo_fam_envs opts) con_tag body_ty
          -> mkWWcpr_help dcpc
          |  otherwise
          -- See Note [non-algebraic or open body type warning]
@@ -1373,12 +1401,12 @@ fragile
 -- 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 :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)
-mk_absent_let dflags arg dmd
+mk_absent_let :: WwOpts -> Id -> Maybe (CoreExpr -> CoreExpr)
+mk_absent_let 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]
   | Just [LiftedRep] <- mb_mono_prim_reps
-  , not (isStrictDmd dmd) -- See (2) in Note [Absent fillers]
+  , not (isStrictDmd (idDemandInfo arg)) -- See (2) in Note [Absent fillers]
   = Just (Let (NonRec arg panic_rhs))
 
   -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@
@@ -1392,26 +1420,26 @@ mk_absent_let dflags arg dmd
   = WARN( True, text "No absent value for" <+> ppr arg_ty )
     Nothing
   where
-    arg_ty            = idType arg
+    arg_ty = idType arg
     mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty
 
     panic_rhs = mkAbsentErrorApp arg_ty msg
 
-    msg       = showSDoc (gopt_set dflags Opt_SuppressUniques)
-                         (vcat
-                           [ text "Arg:" <+> ppr arg
-                           , text "Type:" <+> ppr arg_ty
-                           , file_msg
-                           ])
+    msg = renderWithContext
+            (defaultSDocContext { sdocSuppressUniques = True })
+            (vcat
+              [ text "Arg:" <+> ppr arg
+              , text "Type:" <+> ppr arg_ty
+              , file_msg ])
               -- We need to suppress uniques here because otherwise they'd
               -- end up in the generated code as strings. This is bad for
               -- determinism, because with different uniques the strings
               -- will have different lengths and hence different costs for
               -- the inliner leading to different inlining.
               -- See also Note [Unique Determinism] in GHC.Types.Unique
-    file_msg  = case outputFile dflags of
-                  Nothing -> empty
-                  Just f  -> text "In output file " <+> quotes (text f)
+    file_msg = case wo_output_file opts of
+                 Nothing -> empty
+                 Just f  -> text "In output file " <+> quotes (text f)
 
 ww_prefix :: FastString
 ww_prefix = fsLit "ww"
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 6b779ef1aa..7d7e5342b9 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -47,7 +47,7 @@ module GHC.Core.Utils (
         exprToType, exprToCoercion_maybe,
         applyTypeToArgs, applyTypeToArg,
         dataConRepInstPat, dataConRepFSInstPat,
-        isEmptyTy,
+        isEmptyTy, normSplitTyConApp_maybe,
 
         -- * Working with ticks
         stripTicksTop, stripTicksTopE, stripTicksTopT,
@@ -89,6 +89,7 @@ import GHC.Builtin.PrimOps
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Core.Type as Type
+import GHC.Core.FamInstEnv
 import GHC.Core.Predicate
 import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )
 import GHC.Core.Coercion
@@ -2596,6 +2597,17 @@ isEmptyTy ty
     | otherwise
     = False
 
+-- | If @normSplitTyConApp_maybe _ ty = Just (tc, tys, co)@
+-- then @ty |> co = tc tys@. It's 'splitArgType_maybe', but looks through
+-- coercions via 'topNormaliseType_maybe'. Hence the \"norm\" prefix.
+normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
+normSplitTyConApp_maybe fam_envs ty
+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
+                    `orElse` (mkRepReflCo ty, ty)
+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+  = Just (tc, tc_args, co)
+normSplitTyConApp_maybe _ _ = Nothing
+
 {-
 *****************************************************
 *