Refactor wantToUnboxArg a bit

* Rename GHC.Core.Opt.WorkWrap.Utils.wantToUnboxArg to canUnboxArg
  and similarly wantToUnboxResult to canUnboxResult.

* Add GHC.Core.Opt.DmdAnal.wantToUnboxArg as a wrapper for
  the (new) GHC.Core.Opt.WorkWrap.Utils.canUnboxArg,
  avoiding some yukky duplication.

  I decided it was clearer to give it a new data type for its
  return type, because I nedeed the FD_RecBox case which was not
  otherwise readiliy expressible.

* Add dcpc_args to WorkWrap.Utils.DataConPatContext for the payload

* Get rid of the Unlift constructor of UnboxingDecision, eliminate
  two panics, and two arguments to canUnboxArg (new name).  Much
  nicer now.

4 files changed, 217 insertions, 174 deletions

diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index fc5b2abda3..e13be005fb 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -741,7 +741,7 @@ This is all done in 'extendSigEnvForArg'.
 
 Note that
 
-  * Whether or not something unboxes is decided by 'wantToUnboxArg', else we may
+  * Whether or not something unboxes is decided by 'canUnboxArg', else we may
     get over-optimistic CPR results (e.g., from \(x :: a) -> x!).
 
   * If the demand unboxes deeply, we can give the binder a /nested/ CPR
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index c7278fa079..add2c922e4 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -31,7 +31,7 @@ import GHC.Types.Id
 import GHC.Core.Utils
 import GHC.Core.TyCon
 import GHC.Core.Type
-import GHC.Core.Predicate ( isClassPred )
+import GHC.Core.Predicate( isClassPred )
 import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
 import GHC.Core.Coercion ( Coercion )
 import GHC.Core.TyCo.FVs ( coVarsOfCos )
@@ -282,7 +282,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec
     WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id
     -- See Note [Finalising boxity for demand signatures]
 
-    id_dmd'            = finaliseLetBoxity (ae_fam_envs env) (idType id) id_dmd
+    id_dmd'            = finaliseLetBoxity env (idType id) id_dmd
     !id'               = setBindIdDemandInfo top_lvl id id_dmd'
     (rhs_ty, rhs')     = dmdAnalStar env id_dmd' rhs
 
@@ -963,7 +963,6 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
 
     WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs
     DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
-    -- See Note [Do not unbox class dictionaries]
     -- See Note [Boxity for bottoming functions]
     (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div
                                   `orElse` (rhs_dmds, rhs')
@@ -1285,7 +1284,7 @@ wrapper for `indexError` *will* unbox `p`). This pattern often occurs in
 performance sensitive code that does bounds-checking.
 
 It would be a shame to let `Boxed` win for the fields! So here's what we do:
-While to summarising `indexError`'s boxity signature in `finaliseArgBoxities`,
+While summarising `indexError`'s boxity signature in `finaliseArgBoxities`,
 we `unboxDeeplyDmd` all its argument demands and are careful not to discard
 excess boxity in the `StopUnboxing` case, to get the signature
 `<1!P(!S,!S)><1!S><S!S>b`.
@@ -1352,11 +1351,11 @@ Here is a list of different Notes it has to take care of:
   * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in
     general, but still allow Note [Unboxing evaluated arguments]
   * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)`
-  * Implement fixes for corner cases Note [Do not unbox class dictionaries]
-    and Note [mkWWstr and unsafeCoerce]
+  * Note [mkWWstr and unsafeCoerce]
 
-Then, in worker/wrapper blindly trusts the boxity info in the demand signature
-and will not look at strictness info *at all*, in 'wantToUnboxArg'.
+NB: Then, the worker/wrapper blindly trusts the boxity info in the
+demand signature; that is why 'canUnboxArg' does not look at
+strictness -- it is redundant to do so.
 
 Note [Finalising boxity for let-bound Ids]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1458,7 +1457,7 @@ So here's what we do
   'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but
   since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'.
 
-* Worker/wrapper will consult 'wantToUnboxArg' for its unboxing decision. It will
+* Worker/wrapper will consult 'canUnboxArg' for its unboxing decision. It will
   /not/ look at the strictness bits of the demand, only at Boxity flags. As such,
   it will happily unbox 'a' despite the lazy demand on it.
 
@@ -1624,7 +1623,6 @@ finaliseArgBoxities env fn arity rhs div
     -- uses the info on the binders directly.
   where
     opts            = ae_opts env
-    fam_envs        = ae_fam_envs env
     is_inlinable_fn = isStableUnfolding (realIdUnfolding fn)
     (bndrs, _body)  = collectBinders rhs
     max_wkr_args    = dmd_max_worker_args opts `max` arity
@@ -1637,59 +1635,62 @@ finaliseArgBoxities env fn arity rhs div
 
     arg_triples :: [(Type, StrictnessMark, Demand)]
     arg_triples = take arity $
-                  map mk_triple $
-                  filter isRuntimeVar bndrs
-
-    mk_triple :: Id -> (Type,StrictnessMark,Demand)
-    mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd)
-                   | is_bot_fn     = (ty, NotMarkedStrict, unboxDeeplyDmd dmd)
-                   -- See Note [OPAQUE pragma]
-                   -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
-                   | is_opaque     = (ty, NotMarkedStrict, trimBoxity dmd)
-                   | otherwise     = (ty, NotMarkedStrict, dmd)
-                   where
-                     ty        = idType bndr
-                     dmd       = idDemandInfo bndr
-                     is_opaque = isOpaquePragma (idInlinePragma fn)
-
-    -- is_cls_arg: see Note [Do not unbox class dictionaries]
-    is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty
+                  [ (bndr_ty, NotMarkedStrict, get_dmd bndr bndr_ty)
+                  | bndr <- bndrs
+                  , isRuntimeVar bndr, let bndr_ty = idType bndr ]
+
+    get_dmd :: Id -> Type -> Demand
+    get_dmd bndr bndr_ty
+      | isClassPred bndr_ty
+      , is_inlinable_fn = trimBoxity dmd
+        -- See Note [Do not unbox class dictionaries]
+        -- NB: 'ty' has not been normalised, so this will (rightly)
+        --     catch newtype dictionaries too.
+        -- NB: even for bottoming functions, don't unbox dictionaries
+
+      | is_bot_fn = unboxDeeplyDmd dmd
+        -- See Note [Boxity for bottoming functions]
+
+      | is_opaque = trimBoxity dmd
+        -- See Note [OPAQUE pragma]
+        -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
+
+      | otherwise = dmd
+      where
+        dmd       = idDemandInfo bndr
+        is_opaque = isOpaquePragma (idInlinePragma fn)
+
     -- is_bot_fn:  see Note [Boxity for bottoming functions]
-    is_bot_fn         = div == botDiv
+    is_bot_fn = div == botDiv
 
     go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])
     go_args bg triples = mapAccumL go_arg bg triples
 
     go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)
     go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))
-      = case wantToUnboxArg False fam_envs ty dmd of
-          StopUnboxing
-            | not is_bot_fn
-                -- If bot: Keep deep boxity even though WW won't unbox
-                -- See Note [Boxity for bottoming functions]
-            -> (MkB (bg_top-1) bg_inner, trimBoxity dmd)
-
-          Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds
-            -> (MkB (bg_top-1) final_bg_inner, final_dmd)
+      = case wantToUnboxArg env ty str_mark dmd of
+          FD_Absent -> (bg, dmd)
+
+          FD_Box | is_bot_fn -> (decremented_bg, dmd)
+                 | otherwise -> (decremented_bg, trimBoxity dmd)
+            -- If bot: Keep deep boxity even though WW won't unbox
+            -- See Note [Boxity for bottoming functions]
+            -- trimBoxity: see Note [No lazy, Unboxed demands in demand signature]
+
+          FD_RecBox -> (decremented_bg, trimBoxity dmd)
+            -- Important: must do trimBoxity for FD_RecBox, even for bottoming fns,
+            -- else we unbox infinitely (simpl019, T11545, T18304, T4903)
+
+          FD_Unbox triples -> (MkB (bg_top-1) final_bg_inner, final_dmd)
             where
-              dc_arity = dataConRepArity dc
-              arg_tys  = dubiousDataConInstArgTys dc tc_args
-              (bg_inner', dmds') = go_args (incTopBudget bg_inner) $
-                                   zip3 arg_tys (dataConRepStrictness dc) dmds
+              (bg_inner', dmds') = go_args (incTopBudget bg_inner) triples
+                     -- incTopBudget: give one back for the arg we are unboxing
               dmd' = n :* (mkProd Unboxed $! dmds')
               (final_bg_inner, final_dmd)
-                  | dmds `lengthIs` dc_arity
-                  , isStrict n || isMarkedStrict str_mark
-                     -- isStrict: see Note [No lazy, Unboxed demands in demand signature]
-                     -- isMarkedStrict: see Note [Unboxing evaluated arguments]
-                  , positiveTopBudget bg_inner'
-                  , NonRecursiveOrUnsure <- ae_rec_dc env dc
-                     -- See Note [Which types are unboxed?]
-                     -- and Note [Demand analysis for recursive data constructors]
-                  = (bg_inner', dmd')
-                  | otherwise
-                  = (bg_inner, trimBoxity dmd)
-          _ -> (bg, dmd)
+                 | positiveTopBudget bg_inner' = (bg_inner', dmd')
+                 | otherwise                   = (bg_inner,  trimBoxity dmd)
+      where
+        decremented_bg = MkB (bg_top-1) bg_inner
 
     add_demands :: [Demand] -> CoreExpr -> CoreExpr
     -- Attach the demands to the outer lambdas of this expression
@@ -1700,7 +1701,7 @@ finaliseArgBoxities env fn arity rhs div
     add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)
 
 finaliseLetBoxity
-  :: FamInstEnvs
+  :: AnalEnv
   -> Type                   -- ^ Type of the let-bound Id
   -> Demand                 -- ^ How the Id is used
   -> Demand
@@ -1709,21 +1710,61 @@ finaliseLetBoxity
 -- it has no "budget".  It simply unboxes strict demands, and stops
 -- when it reaches a lazy one.
 finaliseLetBoxity env ty dmd
-  = go ty NotMarkedStrict dmd
+  = go (ty, NotMarkedStrict, dmd)
   where
-    go ty mark dmd@(n :* _) =
-      case wantToUnboxArg False env ty dmd of
-        DropAbsent   -> dmd
-        StopUnboxing -> trimBoxity dmd
-        Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds
-          | isStrict n || isMarkedStrict mark
-          , dmds `lengthIs` dataConRepArity dc
-          , let arg_tys = dubiousDataConInstArgTys dc tc_args
-                dmds'   = strictZipWith3 go arg_tys (dataConRepStrictness dc) dmds
-          -> n :* (mkProd Unboxed $! dmds')
-          | otherwise
-          -> trimBoxity dmd
-        Unlift -> panic "No unlifting in DmdAnal"
+    go :: (Type,StrictnessMark,Demand) -> Demand
+    go (ty, str, dmd@(n :* _)) =
+      case wantToUnboxArg env ty str dmd of
+        FD_Absent        -> dmd
+        FD_Box           -> trimBoxity dmd
+        FD_RecBox        -> trimBoxity dmd
+        FD_Unbox triples -> n :* (mkProd Unboxed $! map go triples)
+
+-- The data type `FinalDecision` is entirely local to this one module,
+-- and is used only to express the result of `wantToUnboxArg`.
+--
+-- `FinalDecision` is a bit like WorkWrap.Utils.UnboxingDecision, but
+-- not quite the same, notably because of the need for FD_RecBox.  But
+-- I decided make `FinalDecision` do just what was needed, rather than
+-- to attempt to generalise `UnboxingDecision`, or make it GADT-ish or
+-- something.
+data FinalDecision
+  = FD_Absent
+  | FD_Box        -- Keep this argument boxed
+  | FD_RecBox     -- Special case of a strict recursive product!  Take care!
+  | FD_Unbox [(Type, StrictnessMark, Demand)]
+
+wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand -> FinalDecision
+wantToUnboxArg env ty str_mark dmd@(n :* _)
+  | isAbs n
+  = FD_Absent
+
+  | not (isStrict n || isMarkedStrict str_mark)
+  = FD_Box -- Don't unbox a lazy field
+    -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal
+
+  | otherwise
+  = case canUnboxArg (ae_fam_envs env) ty dmd of
+      DropAbsent -> FD_Absent
+        -- The earlier isAbs guard means this case won't happen, in fact;
+        -- but it does no harm.  We can't drop the isAbs guard or we'd
+        -- wrongly return StopUnboxing for absent args.
+
+      StopUnboxing -> FD_Box
+
+      Unbox (DataConPatContext{ dcpc_dc      = dc
+                              , dcpc_tc_args = tc_args
+                              , dcpc_args    = dmds })
+       -- OK, so we /can/ unbox it; but do we /want/ to?
+       | DefinitelyRecursive <- ae_rec_dc env dc
+         -- See Note [Which types are unboxed?]
+         -- and Note [Demand analysis for recursive data constructors]
+       -> FD_RecBox
+
+       | otherwise
+       -> FD_Unbox (zip3 (dubiousDataConInstArgTys dc tc_args)
+                         (dataConRepStrictness dc)
+                         dmds)
 
 
 {- *********************************************************************
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 1f5cd29a26..f23384d134 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(..), mkWwBodies, mkWWstr, mkWWstr_one
    , needsVoidWorkerArg, addVoidWorkerArg
    , DataConPatContext(..)
-   , UnboxingDecision(..), wantToUnboxArg
+   , UnboxingDecision(..), canUnboxArg
    , findTypeShape, IsRecDataConResult(..), isRecDataCon
    , mkAbsentFiller
    , isWorkerSmallEnough, dubiousDataConInstArgTys
@@ -221,18 +221,18 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
               zapped_arg_vars = map zap_var arg_vars
               (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars
               res_ty' = GHC.Core.Subst.substTy subst res_ty
-              init_cbv_marks = map (const NotMarkedStrict) cloned_arg_vars
+              init_str_marks = map (const NotMarkedStrict) cloned_arg_vars
 
-        ; (useful1, work_args_cbv, wrap_fn_str, fn_args)
-             <- mkWWstr opts cloned_arg_vars init_cbv_marks
+        ; (useful1, work_args_str, wrap_fn_str, fn_args)
+             <- mkWWstr opts cloned_arg_vars init_str_marks
 
-        ; let (work_args, work_marks) = unzip work_args_cbv
+        ; let (work_args, work_marks) = unzip work_args_str
 
         -- Do CPR w/w.  See Note [Always do CPR w/w]
         ; (useful2, wrap_fn_cpr, work_fn_cpr)
               <- mkWWcpr_entry opts res_ty' res_cpr
 
-        ; let (work_lam_args, work_call_args, work_call_cbv)
+        ; let (work_lam_args, work_call_args, work_call_str)
                 | needsVoidWorkerArg fun_id arg_vars work_args
                 = addVoidWorkerArg work_args work_marks
                 | otherwise
@@ -243,9 +243,9 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
                                   -- See Note [Join points and beta-redexes]
               wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work
                                   -- See Note [Call-by-value for worker args]
-              work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_cbv)
+              work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_str)
               worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs
-              worker_args_dmds= [(idDemandInfo v) | v <- work_call_args, isId v]
+              worker_args_dmds= [ idDemandInfo v | v <- work_call_args, isId v]
 
         ; if ((useful1 && not only_one_void_argument) || useful2)
           then return (Just (worker_args_dmds, length work_call_args,
@@ -394,9 +394,9 @@ needsVoidWorkerArg fn_id wrap_args work_args
 addVoidWorkerArg :: [Var] -> [StrictnessMark]
                  -> ([Var],     -- Lambda bound args
                      [Var],     -- Args at call site
-                     [StrictnessMark]) -- cbv semantics for the worker args.
-addVoidWorkerArg work_args cbv_marks
-  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:cbv_marks)
+                     [StrictnessMark]) -- str semantics for the worker args.
+addVoidWorkerArg work_args str_marks
+  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:str_marks)
 
 {-
 Note [Protecting the last value argument]
@@ -554,29 +554,26 @@ see #17478.
 --
 --   * @dc @exs flds :: T tys@
 --   * @co :: T tys ~ ty@
-data DataConPatContext
+--
+-- 's' will be 'Demand' or 'Cpr'.
+data DataConPatContext s
   = DataConPatContext
   { dcpc_dc      :: !DataCon
   , dcpc_tc_args :: ![Type]
   , dcpc_co      :: !Coercion
+  , dcpc_args    :: ![s]
   }
 
 -- | Describes the outer shape of an argument to be unboxed or left as-is
 -- Depending on how @s@ is instantiated (e.g., 'Demand' or 'Cpr').
-data UnboxingDecision s
+data UnboxingDecision unboxing_info
   = 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.
-  -- The 'DataConPatContext' carries the bits necessary for
-  -- instantiation with 'dataConRepInstPat'.
-  -- The @[s]@ carries the bits of information with which we can continue
-  -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'.
-  | Unlift
-  -- ^ The argument can't be unboxed, but we want it to be passed evaluated to the worker.
+  | Unbox !unboxing_info
+  -- ^ The argument is used strictly or the returned product
+  -- was constructed, so unbox it.
 
 -- Do we want to create workers just for unlifting?
 wwForUnlifting :: WwOpts -> Bool
@@ -599,41 +596,34 @@ isGoodWorker = id
 -- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns
 -- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon'
 -- to unbox.
-wantToUnboxArg
-  :: Bool                -- ^ Consider unlifting
-  -> FamInstEnvs
-  -> Type                -- ^ Type of the argument
-  -> Demand              -- ^ How the arg was used
-  -> UnboxingDecision Demand
+canUnboxArg
+  :: FamInstEnvs
+  -> Type        -- ^ Type of the argument
+  -> Demand      -- ^ How the arg was used
+  -> UnboxingDecision (DataConPatContext Demand)
 -- See Note [Which types are unboxed?]
-wantToUnboxArg do_unlifting fam_envs ty dmd@(n :* sd)
+canUnboxArg fam_envs ty (n :* sd)
   | isAbs n
   = DropAbsent
 
+  -- From here we are strict and not absent
   | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty
   , Just dc <- tyConSingleAlgDataCon_maybe tc
   , let arity = dataConRepArity dc
-  , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity analysis]
-  -- NB: No strictness or evaluatedness checks for unboxing here.
-  -- That is done by 'finaliseArgBoxities'!
-  = Unbox (DataConPatContext dc tc_args co) ds
-
-  -- See Note [CBV Function Ids]
-  | do_unlifting
-  , isStrUsedDmd dmd
-  , not (isFunTy ty)
-  , not (isUnliftedType ty) -- Already unlifted!
-    -- NB: function arguments have a fixed RuntimeRep, so it's OK to call isUnliftedType here
-  = Unlift
+  , Just (Unboxed, dmds) <- viewProd arity sd -- See Note [Boxity analysis]
+  , dmds `lengthIs` dataConRepArity dc
+  = Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
+                             , dcpc_co = co, dcpc_args = dmds })
 
   | otherwise
   = StopUnboxing
 
 
 -- | Unboxing strategy for constructed results.
-wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr
+canUnboxResult :: FamInstEnvs -> Type -> Cpr
+               -> UnboxingDecision (DataConPatContext Cpr)
 -- See Note [Which types are unboxed?]
-wantToUnboxResult fam_envs ty cpr
+canUnboxResult fam_envs ty cpr
   | Just (con_tag, arg_cprs) <- asConCpr cpr
   , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty
   , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning
@@ -648,14 +638,15 @@ wantToUnboxResult fam_envs ty cpr
   -- Deactivates CPR worker/wrapper splits on constructors with non-linear
   -- arguments, for the moment, because they require unboxed tuple with variable
   -- multiplicity fields.
-  = Unbox (DataConPatContext dc tc_args co) arg_cprs
+  = Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
+                             , dcpc_co = co, dcpc_args = arg_cprs })
 
   | otherwise
   = StopUnboxing
 
   where
     -- See Note [non-algebraic or open body type warning]
-    open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing
+    open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing
 
 isLinear :: Scaled a -> Bool
 isLinear (Scaled w _ ) =
@@ -697,8 +688,8 @@ Worker/wrapper will unbox
      to
      > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)
 
-The respective tests are in 'wantToUnboxArg' and
-'wantToUnboxResult', respectively.
+The respective tests are in 'canUnboxArg' and
+'canUnboxResult', respectively.
 
 Note that the data constructor /can/ have evidence arguments: equality
 constraints, type classes etc.  So it can be GADT.  These evidence
@@ -756,14 +747,17 @@ Performing W/W might not always be a win. In particular it's easy to break
 See #20364 for a more detailed explaination.
 
 Hence we have the following strategies with different trade-offs:
+
 A) Never do W/W *just* for unlifting of arguments.
   + Very conservative - doesn't break any rules
   - Lot's of performance left on the table
+
 B) Do W/W on just about anything where it might be
   beneficial.
   + Exploits pretty much every oppertunity for unlifting.
   - A bit of compile time/code size cost for all the wrappers.
   - Can break rules which would otherwise fire. See #20364.
+
 C) Unlift *any* (non-boot exported) functions arguments if they are strict.
   That is instead of creating a Worker with the new calling convention we
   change the calling convention of the binding itself.
@@ -784,11 +778,13 @@ C) Unlift *any* (non-boot exported) functions arguments if they are strict.
 
 Currently we use the first approach A) by default, with a flag that allows users to fall back to the
 more aggressive approach B).
+
 I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling
 code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903.
 We could still try to do C) in the future by having PAP calls which will evaluate the required arguments
 before calling the partially applied function. But this would be neither a small nor simple change so we
 stick with A) and a flag for B) for now.
+
 See also Note [Tag Inference] and Note [CBV Function Ids]
 -}
 
@@ -803,7 +799,7 @@ See also Note [Tag Inference] and Note [CBV Function Ids]
 mkWWstr :: WwOpts
         -> [Var]                         -- Wrapper args; have their demand info on them
                                          --  *Includes type variables*
-        -> [StrictnessMark]                     -- cbv info for arguments
+        -> [StrictnessMark]              -- Strictness-mark info for arguments
         -> UniqSM (Bool,                 -- Will this result in a useful worker
                    [(Var,StrictnessMark)],      -- Worker args/their call-by-value semantics.
                    CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
@@ -812,20 +808,18 @@ mkWWstr :: WwOpts
                    [CoreExpr])           -- Reboxed args for the call to the
                                          -- original RHS. Corresponds one-to-one
                                          -- with the wrapper arg vars
-mkWWstr opts args cbv_info
-  = go args cbv_info
+mkWWstr opts args str_marks
+  = go args str_marks
   where
-    go_one arg cbv = mkWWstr_one opts arg cbv
-
-    go []           _ = return (badWorker, [], nop_fn, [])
-    go (arg : args) (cbv:cbvs)
-      =               do { (useful1, args1, wrap_fn1, wrap_arg)  <- go_one arg cbv
-                         ; (useful2, args2, wrap_fn2, wrap_args) <- go args cbvs
-                         ; return ( useful1 || useful2
-                                  , args1 ++ args2
-                                  , wrap_fn1 . wrap_fn2
-                                  , wrap_arg:wrap_args ) }
-    go _ _ = panic "mkWWstr: Impossible - cbv/arg length missmatch"
+    go [] _ = return (badWorker, [], nop_fn, [])
+    go (arg : args) (str:strs)
+      = do { (useful1, args1, wrap_fn1, wrap_arg)  <- mkWWstr_one opts arg str
+           ; (useful2, args2, wrap_fn2, wrap_args) <- go args strs
+           ; return ( useful1 || useful2
+                    , args1 ++ args2
+                    , wrap_fn1 . wrap_fn2
+                    , wrap_arg:wrap_args ) }
+    go _ _ = panic "mkWWstr: Impossible - str/arg length missmatch"
 
 ----------------------
 -- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg)
@@ -838,24 +832,28 @@ mkWWstr_one :: WwOpts
             -> Var
             -> StrictnessMark
             -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-mkWWstr_one opts arg banged =
-  case wantToUnboxArg True fam_envs arg_ty arg_dmd of
+mkWWstr_one opts arg str_mark =
+  case canUnboxArg fam_envs arg_ty arg_dmd of
     _ | isTyVar arg -> do_nothing
 
     DropAbsent
-      | Just absent_filler <- mkAbsentFiller opts arg banged
+      | Just absent_filler <- mkAbsentFiller opts arg str_mark
          -- Absent case.  Dropt the argument from the worker.
          -- We can't always handle absence for arbitrary
          -- unlifted types, so we need to choose just the cases we can
          -- (that's what mkAbsentFiller does)
       -> return (goodWorker, [], nop_fn, absent_filler)
 
-    Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc banged
+    Unbox dcpc -> unbox_one_arg opts arg dcpc
 
-    Unlift -> return  ( wwForUnlifting opts
-                      , [(arg, MarkedStrict)]
-                      , nop_fn
-                      , varToCoreExpr arg)
+    _ | isStrictDmd arg_dmd || isMarkedStrict str_mark
+      , wwForUnlifting opts
+      , not (isFunTy arg_ty)
+      , not (isUnliftedType arg_ty) -- Already unlifted!
+        -- NB: function arguments have a fixed RuntimeRep,
+        -- so it's OK to call isUnliftedType here
+      -> -- See Note [CBV Function Ids]
+         return  (goodWorker, [(arg, MarkedStrict)], nop_fn, varToCoreExpr arg )
 
     _ -> do_nothing -- Other cases, like StopUnboxing
 
@@ -863,37 +861,42 @@ mkWWstr_one opts arg banged =
     fam_envs   = wo_fam_envs opts
     arg_ty     = idType arg
     arg_dmd    = idDemandInfo arg
-    -- Type args don't get cbv marks
-    arg_cbv    = if isTyVar arg then NotMarkedStrict else banged
-
-    do_nothing = return (badWorker, [(arg,arg_cbv)], nop_fn, varToCoreExpr arg)
+    arg_str    | isTyVar arg = NotMarkedStrict -- Type args don't get stricness marks
+               | otherwise   = str_mark
+    do_nothing = return (badWorker, [(arg,arg_str)], nop_fn, varToCoreExpr arg)
 
 unbox_one_arg :: WwOpts
-          -> Var
-          -> [Demand]
-          -> DataConPatContext
-          -> StrictnessMark
-          -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-unbox_one_arg opts arg_var ds
-          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
-                            , dcpc_co = co }
-          _marked_cbv
+              -> Var-> DataConPatContext Demand
+              -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
+unbox_one_arg opts arg_var
+              DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
+                                , dcpc_co = co, dcpc_args = ds }
   = do { pat_bndrs_uniqs <- getUniquesM
        ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc
+
              -- Create new arguments we get when unboxing dc
-             (ex_tvs', arg_ids) =
-               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args
+             (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix)
+                                            pat_bndrs_uniqs (idMult arg_var) dc tc_args
              con_str_marks = dataConRepStrictness dc
-             -- Apply str info to new args. Also remove OtherCon unfoldings so they don't end up in lambda binders
-             -- of the worker. See Note [Never put `OtherCon` unfoldings on lambda binders]
-             arg_ids' = map zapIdUnfolding $ zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds
+
+             -- Apply str info to new args. Also remove OtherCon unfoldings so they
+             -- don't end up in lambda binders of the worker.
+             -- See Note [Never put `OtherCon` unfoldings on lambda binders]
+             arg_ids' = map zapIdUnfolding $
+                        zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds
+
              unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var)
                                      dc (ex_tvs' ++ arg_ids')
-             -- Mark arguments coming out of strict fields so we can make the worker strict on those
-             -- argumnets later. seq them later. See Note [Call-by-value for worker args]
-             strict_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks
-       ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids') strict_marks
+
+             -- Mark arguments coming out of strict fields so we can seq them in the worker
+             -- See Note [Call-by-value for worker args]
+             all_str_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks
+
+       ; (_sub_args_quality, worker_args, wrap_fn, wrap_args)
+             <- mkWWstr opts (ex_tvs' ++ arg_ids') all_str_marks
+
        ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co
+
        ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) }
                           -- Don't pass the arg, rebox instead
 
@@ -937,7 +940,7 @@ mkAbsentFiller opts arg str
 {- Note [Worker/wrapper for Strictness and Absence]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The worker/wrapper transformation, mkWWstr_one, takes concrete action
-based on the 'UnboxingDescision' returned by 'wantToUnboxArg'.
+based on the 'UnboxingDecision' returned by 'canUnboxArg'.
 The latter takes into account several possibilities to decide if the
 function is worthy for splitting:
 
@@ -951,7 +954,7 @@ function is worthy for splitting:
 
 2. If the argument is evaluated strictly (or known to be eval'd),
    we can take a view into the product demand ('viewProd'). In accordance
-   with Note [Boxity analysis], 'wantToUnboxArg' will say 'Unbox'.
+   with Note [Boxity analysis], 'canUnboxArg' will say 'Unbox'.
    'mkWWstr_one' then follows suit it and recurses into the fields of the
    product demand. For example
 
@@ -973,7 +976,7 @@ function is worthy for splitting:
      $gw c a b = if c then a else b
 
 2a But do /not/ unbox if Boxity Analysis said "Boxed".
-   In this case, 'wantToUnboxArg' returns 'StopUnboxing'.
+   In this case, 'canUnboxArg' returns 'StopUnboxing'.
    Otherwise we risk decomposing and reboxing a massive
    tuple which is barely used. Example:
 
@@ -994,7 +997,7 @@ function is worthy for splitting:
 3. In all other cases (e.g., lazy, used demand and not eval'd),
    'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed'
    (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal)
-   and 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one'
+   and 'canUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one'
    stops unboxing.
 
 Note [Worker/wrapper for bottoming functions]
@@ -1374,7 +1377,7 @@ mkWWcpr _opts vars []   =
   -- hence stop WW.
   return (badWorker, toOL vars, map varToCoreExpr vars, nop_fn)
 mkWWcpr opts  vars cprs = do
-  -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that.
+  -- No existentials in 'vars'. 'canUnboxResult' should have checked that.
   massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs)
   massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs)
   (usefuls, varss, rebuilt_results, work_unpack_ress) <-
@@ -1388,17 +1391,17 @@ mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResultOne
 -- ^ See if we want to unbox the result and hand off to 'unbox_one_result'.
 mkWWcpr_one opts res_bndr cpr
   | assert (not (isTyVar res_bndr) ) True
-  , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr
-  = unbox_one_result opts res_bndr arg_cprs dcpc
+  , Unbox dcpc <- canUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr
+  = unbox_one_result opts res_bndr dcpc
   | otherwise
   = return (badWorker, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn)
 
 unbox_one_result
-  :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResultOne
+  :: WwOpts -> Id -> DataConPatContext Cpr -> UniqSM CprWwResultOne
 -- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR]
-unbox_one_result opts res_bndr arg_cprs
+unbox_one_result opts res_bndr
                  DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
-                                   , dcpc_co = co } = do
+                                   , dcpc_co = co, dcpc_args = arg_cprs } = do
   -- unboxer (free in `res_bndr`):       |   builder (where <i> builds what was
   --   ( case res_bndr of (i, j) -> )    |            bound to i)
   --   ( case i of I# a ->          )    |
@@ -1407,7 +1410,7 @@ unbox_one_result opts res_bndr arg_cprs
   pat_bndrs_uniqs <- getUniquesM
   let (_exs, arg_ids) =
         dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args
-  massert (null _exs) -- Should have been caught by wantToUnboxResult
+  massert (null _exs) -- Should have been caught by canUnboxResult
 
   (nested_useful, transit_vars, con_args, work_unbox_res) <-
     mkWWcpr opts arg_ids arg_cprs
diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs
index 8ea0ddc84e..9bd29a5a37 100644
--- a/compiler/GHC/Types/Demand.hs
+++ b/compiler/GHC/Types/Demand.hs
@@ -2224,11 +2224,10 @@ prependArgsDmdSig :: Int -> DmdSig -> DmdSig
 prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res))
   | new_args == 0       = sig
   | isNopDmdType dmd_ty = sig
-  | new_args < 0        = pprPanic "prependArgsDmdSig: negative new_args"
-                                   (ppr new_args $$ ppr sig)
   | otherwise           = DmdSig (DmdType env dmds' res)
   where
-    dmds' = replicate new_args topDmd ++ dmds
+    dmds' = assertPpr (new_args > 0) (ppr new_args) $
+            replicate new_args topDmd ++ dmds
 
 etaConvertDmdSig :: Arity -> DmdSig -> DmdSig
 -- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to