Nested CPR light (#19398)wip/conservative-field-binder-cpr

While fixing #19232, it became increasingly clear that the vestigial
hack described in `Note [Optimistic field binder CPR]` is complicated
and causes reboxing. Rather than make the hack worse, this patch
gets rid of it completely in favor of giving deeply unboxed parameters
the Nested CPR property. Example:
```hs
f :: (Int, Int) -> Int
f p = case p of
 (x, y) | x == y    = x
        | otherwise = y
```
Based on `p`'s `idDemandInfo` `1P(1P(L),1P(L))`, we can see that both
fields of `p` will be available unboxed. As a result, we give `p` the
nested CPR property `1(1,1)`. When analysing the `case`, the field
CPRs are transferred to the binders `x` and `y`, respectively, so that
we ultimately give `f` the CPR property.

I took the liberty to do a bit of refactoring:

- I renamed `CprResult` ("Constructed product result result") to plain
  `Cpr`.
- I Introduced `FlatConCpr` in addition to (now nested) `ConCpr` and
  and according pattern synonym that rewrites flat `ConCpr` to
  `FlatConCpr`s, purely for compiler perf reasons.
- Similarly for performance reasons, we now store binders with a
  Top signature in a separate `IntSet`,
  see `Note [Efficient Top sigs in SigEnv]`.
- I moved a bit of stuff around in `GHC.Core.Opt.WorkWrap.Utils` and
  introduced `UnboxingDecision` to replace the `Maybe DataConPatContext`
  type we used to return from `wantToUnbox`.
- Since the `Outputable Cpr` instance changed anyway, I removed the
  leading `m` which we used to emit for `ConCpr`. It's just noise,
  especially now that we may output nested CPRs.

Fixes #19398.

28 files changed, 705 insertions, 508 deletions

diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
index d8330abe2b..be3fa73282 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ b/compiler/GHC/Core/Opt/CprAnal.hs
@@ -21,20 +21,26 @@ import GHC.Core.Seq
 import GHC.Utils.Outputable
 import GHC.Types.Var.Env
 import GHC.Types.Basic
-import GHC.Core.DataCon
 import GHC.Types.Id
 import GHC.Types.Id.Info
+import GHC.Core.DataCon
+import GHC.Core.Multiplicity
 import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram )
 import GHC.Core.Type
 import GHC.Core.FamInstEnv
 import GHC.Core.Opt.WorkWrap.Utils
 import GHC.Utils.Misc
+import GHC.Utils.Panic
 import GHC.Utils.Logger  ( Logger, dumpIfSet_dyn, DumpFormat (..) )
-import GHC.Data.Maybe   ( isJust, isNothing )
+import GHC.Data.Graph.UnVar -- for UnVarSet
+import GHC.Data.Maybe   ( isNothing )
 
 import Control.Monad ( guard )
 import Data.List ( mapAccumL )
 
+import GHC.Driver.Ppr
+_ = pprTrace -- Tired of commenting out the import all the time
+
 {- Note [Constructed Product Result]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The goal of Constructed Product Result analysis is to identify functions that
@@ -177,7 +183,8 @@ cprAnal' env (Lam var body)
   | otherwise
   = (lam_ty, Lam var body')
   where
-    env'             = extendSigEnvForDemand env var (idDemandInfo var)
+    -- See Note [CPR for binders that will be unboxed]
+    env'             = extendSigEnvForArg env var
     (body_ty, body') = cprAnal env' body
     lam_ty           = abstractCprTy body_ty
 
@@ -185,11 +192,8 @@ cprAnal' env (Case scrut case_bndr ty alts)
   = (res_ty, Case scrut' case_bndr ty alts')
   where
     (scrut_ty, scrut') = cprAnal env scrut
-    -- We used to give the case binder the CPR property unconditionally.
-    -- See Historic Note [Optimistic case binder CPR]
     env'               = extendSigEnv env case_bndr (CprSig scrut_ty)
-    be_optimistic      = assumeOptimisticFieldCpr scrut scrut_ty
-    (alt_tys, alts')   = mapAndUnzip (cprAnalAlt env' be_optimistic) alts
+    (alt_tys, alts')   = mapAndUnzip (cprAnalAlt env' scrut_ty) alts
     res_ty             = foldl' lubCprType botCprType alt_tys
 
 cprAnal' env (Let (NonRec id rhs) body)
@@ -206,49 +210,28 @@ cprAnal' env (Let (Rec pairs) body)
 
 cprAnalAlt
   :: AnalEnv
-  -> Bool     -- ^ Does Note [Optimistic field binder CPR] apply?
-  -> Alt Var  -- ^ current alternative
+  -> CprType -- ^ CPR type of the scrutinee
+  -> Alt Var -- ^ current alternative
   -> (CprType, Alt Var)
-cprAnalAlt env be_optimistic (Alt con bndrs rhs)
+cprAnalAlt env scrut_ty (Alt con bndrs rhs)
   = (rhs_ty, Alt con bndrs rhs')
   where
     env_alt
-      | DataAlt dc <- con, be_optimistic
-      -- Optimistically give strictly used field binders the CPR property.
-      -- See Note [Optimistic field binder CPR].
-      -- What we actually want here is Nested CPR.
-      = giveStrictFieldsCpr env dc bndrs
+      | DataAlt dc <- con
+      , let ids = filter isId bndrs
+      , CprType arity cpr <- scrut_ty
+      , ASSERT( arity == 0 ) True
+      = case unpackConFieldsCpr dc cpr of
+          AllFieldsSame field_cpr
+            | let sig = mkCprSig 0 field_cpr
+            -> extendSigEnvAllSame env ids sig
+          ForeachField field_cprs
+            | let sigs = zipWith (mkCprSig . idArity) ids field_cprs
+            -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs)
       | otherwise
       = env
     (rhs_ty, rhs') = cprAnal env_alt rhs
 
-giveStrictFieldsCpr :: AnalEnv -> DataCon -> [Id] -> AnalEnv
--- See Note [Optimistic field binder CPR]
-giveStrictFieldsCpr env dc bs = foldl' do_one_field env (fields_w_dmds dc bs)
-  where
-    -- 'extendSigEnvForDemand' gives 'id' the CPR property if 'dmd' is strict
-    do_one_field env (id, dmd) = extendSigEnvForDemand env id dmd
-    fields_w_dmds dc bndrs = -- returns the fields paired with their 'idDemandInfo'
-       -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils
-       [ (id, applyWhen (isMarkedStrict mark) strictifyDmd (idDemandInfo id))
-       | (id, mark) <- filter isId bndrs `zip` dataConRepStrictness dc
-       ]
-
--- | Decide whether to optimistically give 'DataAlt' field binders the CPR
--- property based on strictness.
--- Tests (A) and (B) of Note [Optimistic field binder CPR].
-assumeOptimisticFieldCpr :: CoreExpr -> CprType -> Bool
-assumeOptimisticFieldCpr scrut scrut_ty = is_var scrut && case_will_cancel
-  where
-    -- Test (A): The case will only cancel when 'scrut' has the CPR property.
-    case_will_cancel | CprType 0 cpr <- scrut_ty = isJust (asConCpr cpr)
-                     | otherwise                 = False
-    -- Test (B): Guess whether 'scrut' is a parameter. Surely not if it's not a
-    -- variable!
-    is_var (Cast e _) = is_var e
-    is_var (Var v)    = isLocalId v
-    is_var _          = False
-
 --
 -- * CPR transformer
 --
@@ -293,7 +276,7 @@ cprFix top_lvl orig_env orig_pairs
     orig_virgin = ae_virgin orig_env
     init_pairs | orig_virgin  = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]
                | otherwise    = orig_pairs
-    init_env = extendSigEnvList orig_env (map fst init_pairs)
+    init_env = extendSigEnvFromIds orig_env (map fst init_pairs)
 
     -- The fixed-point varies the idCprInfo field of the binders and and their
     -- entries in the AnalEnv, and terminates if that annotation does not change
@@ -413,35 +396,68 @@ data AnalEnv
   -- ^ Needed when expanding type families and synonyms of product types.
   }
 
-type SigEnv = VarEnv CprSig
-
 instance Outputable AnalEnv where
   ppr (AE { ae_sigs = env, ae_virgin = virgin })
     = text "AE" <+> braces (vcat
          [ text "ae_virgin =" <+> ppr virgin
          , text "ae_sigs =" <+> ppr env ])
 
+-- | An environment storing 'CprSig's for local Ids.
+-- Puts binders with 'topCprSig' in a space-saving 'IntSet'.
+-- See Note [Efficient Top sigs in SigEnv].
+data SigEnv
+  = SE
+  { se_tops :: !UnVarSet
+  -- ^ All these Ids have 'topCprSig'. Like a 'VarSet', but more efficient.
+  , se_sigs :: !(VarEnv CprSig)
+  -- ^ Ids that have something other than 'topCprSig'.
+  }
+
+instance Outputable SigEnv where
+  ppr (SE { se_tops = tops, se_sigs = sigs })
+    = text "SE" <+> braces (vcat
+         [ text "se_tops =" <+> ppr tops
+         , text "se_sigs =" <+> ppr sigs ])
+
 emptyAnalEnv :: FamInstEnvs -> AnalEnv
 emptyAnalEnv fam_envs
   = AE
-  { ae_sigs = emptyVarEnv
+  { ae_sigs = SE emptyUnVarSet emptyVarEnv
   , ae_virgin = True
   , ae_fam_envs = fam_envs
   }
 
--- | Extend an environment with the CPR sigs attached to the id
-extendSigEnvList :: AnalEnv -> [Id] -> AnalEnv
-extendSigEnvList env ids
-  = env { ae_sigs = sigs' }
-  where
-    sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ]
+modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
+modifySigEnv f env = env { ae_sigs = f (ae_sigs env) }
+
+lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig
+-- See Note [Efficient Top sigs in SigEnv]
+lookupSigEnv AE{ae_sigs = SE tops sigs} id
+  | id `elemUnVarSet` tops = Just topCprSig
+  | otherwise              = lookupVarEnv sigs id
 
 extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv
+-- See Note [Efficient Top sigs in SigEnv]
 extendSigEnv env id sig
-  = env { ae_sigs = extendVarEnv (ae_sigs env) id sig }
+  | isTopCprSig sig
+  = modifySigEnv (\se -> se{se_tops = extendUnVarSet id (se_tops se)}) env
+  | otherwise
+  = modifySigEnv (\se -> se{se_sigs = extendVarEnv (se_sigs se) id sig}) env
 
-lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig
-lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
+-- | Extend an environment with the (Id, CPR sig) pairs
+extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv
+extendSigEnvList env ids_cprs
+  = foldl' (\env (id, sig) -> extendSigEnv env id sig) env ids_cprs
+
+-- | Extend an environment with the CPR sigs attached to the ids
+extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv
+extendSigEnvFromIds env ids
+  = foldl' (\env id -> extendSigEnv env id (idCprInfo id)) env ids
+
+-- | Extend an environment with the same CPR sig for all ids
+extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv
+extendSigEnvAllSame env ids sig
+  = foldl' (\env id -> extendSigEnv env id sig) env ids
 
 nonVirgin :: AnalEnv -> AnalEnv
 nonVirgin env = env { ae_virgin = False }
@@ -451,29 +467,63 @@ nonVirgin env = env { ae_virgin = False }
 -- In this case, we can still look at their demand to attach CPR signatures
 -- anticipating the unboxing done by worker/wrapper.
 -- See Note [CPR for binders that will be unboxed].
-extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv
-extendSigEnvForDemand env id dmd
-  | isId id
-  , Just (_, DataConPatContext { dcpc_dc = dc })
-      <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd
-  = extendSigEnv env id (CprSig (conCprType (dataConTag dc)))
-  | otherwise
-  = env
+extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv
+extendSigEnvForArg env id
+  = extendSigEnv env id (CprSig (argCprType env (idType id) (idDemandInfo id)))
+
+-- | Produces a 'CprType' according to how a strict argument will be unboxed.
+-- Examples:
+--
+--   * A head-strict demand @1L@ on @Int@ would translate to @1@
+--   * A product demand @1P(1L,L)@ on @(Int, Bool)@ would translate to @1(1,)@
+--   * A product demand @1P(1L,L)@ on @(a , Bool)@ would translate to @1(,)@,
+--     because the unboxing strategy would not unbox the @a@.
+argCprType :: AnalEnv -> Type -> Demand -> CprType
+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
+      -- 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
+      -- be, for the sake of coding convenience.
+      , null (dataConExTyCoVars dc)
+      , let arg_tys = map scaledThing (dataConInstArgTys dc tc_args)
+      = 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.
-    has_inlineable_prag = False
+    no_inlineable_prag = False
 
 {- Note [Safe abortion in the fixed-point iteration]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 Fixed-point iteration may fail to terminate. But we cannot simply give up and
 return the environment and code unchanged! We still need to do one additional
 round, to ensure that all expressions have been traversed at least once, and any
 unsound CPR annotations have been updated.
 
+Note [Efficient Top sigs in SigEnv]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's pretty common for binders in the SigEnv to have a 'topCprSig'.
+Wide records with 100 fields like in T9675 even will generate code where the
+majority of binders has Top signature. To save some allocations, we store
+those binders with a Top signature in a separate UnVarSet (which is an IntSet
+with a convenient Var-tailored API).
+
+Why store top signatures at all in the SigEnv? After all, when 'cprTransform'
+encounters a locally-bound Id without an entry in the SigEnv, it should behave
+as if that binder has a Top signature!
+Well, the problem is when case binders should have a Top signatures. They always
+have an unfolding and thus look to 'cprTransform' as if they bind a data
+structure, Note [CPR for data structures], and thus would always have the CPR
+property. So we need some mechanism to separate data structures from case
+binders with a Top signature, and the UnVarSet provides that in the least
+convoluted way I can think of.
+
 Note [CPR for binders that will be unboxed]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If a lambda-bound variable will be unboxed by worker/wrapper (so it must be
@@ -496,21 +546,37 @@ Moreover, if f itself is strict in x, then we'll pass x unboxed to
 f1, and so the boxed version *won't* be available; in that case it's
 very helpful to give 'x' the CPR property.
 
-This is all done in 'extendSigEnvForDemand'.
+This is all done in 'extendSigEnvForArg'.
 
 Note that
 
-  * We only want to do this for something that definitely unboxes as per
-    'wantToUnbox', else we may get over-optimistic CPR results e.g.
-    (from \x -> x!).
+  * Whether or not something unboxes is decided by 'wantToUnbox', 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
+    property, e.g.
+
+      g :: (Int, Int) -> Int
+      g p = case p of
+        (x, y) | x < 0     -> 0
+               | otherwise -> x
+
+    `x` should have the CPR property because it will be unboxed. We do so
+    by giving `p` the Nested CPR property `1(1,)`, indicating that we not only
+    have `p` available unboxed, but also its field `x`. Analysis of the Case
+    will then transfer the CPR property to `x`.
 
-  * This also (approximately) applies to DataAlt field binders;
-    See Note [Optimistic field binder CPR].
+    Before we were able to express Nested CPR, we used to guess which field
+    binders should get the CPR property.
+    See Historic Note [Optimistic field binder CPR].
 
   * See Note [CPR examples]
 
-Note [Optimistic field binder CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Historic Note [Optimistic field binder CPR]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This Note describes how we used to guess whether fields have the CPR property
+before we were able to express Nested CPR for arguments.
+
 Consider
 
   data T a = MkT a
@@ -531,9 +597,6 @@ Lacking Nested CPR, we have to guess a bit, by looking for
   (B) A variable scrutinee. Otherwise surely it can't be a parameter.
   (C) Strict demand on the field binder `y` (or it binds a strict field)
 
-(A) and (B) are tested in 'assumeOptimisticFieldCpr',
-(C) in 'giveStrictFieldsCpr' via 'extendSigEnvForDemand'.
-
 While (A) is a necessary condition to give a field the CPR property, there are
 ways in which (B) and (C) are too lax, leading to unsound analysis results and
 thus reboxing in the wrapper:
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index a4444d9957..030cb2ac8a 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -602,7 +602,7 @@ See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.
 
 
 ---------------------
-splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr
+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr
          -> UniqSM [(Id, CoreExpr)]
 splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
   | isRecordSelector fn_id  -- See Note [No worker/wrapper for record selectors]
@@ -638,7 +638,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs
 
 
 mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity
-             -> CoreExpr -> Unique -> Divergence -> CprResult
+             -> 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
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 0a7ef0f3a5..5223e66817 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -8,7 +8,7 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser
 
 module GHC.Core.Opt.WorkWrap.Utils
    ( mkWwBodies, mkWWstr, mkWorkerArgs
-   , DataConPatContext(..), splitArgType_maybe, wantToUnbox
+   , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox
    , findTypeShape
    , isWorkerSmallEnough
    )
@@ -135,7 +135,7 @@ mkWwBodies :: DynFlags
                              -- See Note [Freshen WW arguments]
            -> Id             -- The original function
            -> [Demand]       -- Strictness of original function
-           -> CprResult      -- Info about function result
+           -> Cpr            -- Info about function result
            -> UniqSM (Maybe WwResult)
 
 -- wrap_fn_args E       = \x y -> E
@@ -511,105 +511,100 @@ To avoid this:
 
     Another tricky case was when f :: forall a. a -> forall a. a->a
     (i.e. with shadowing), and then the worker used the same 'a' twice.
+-}
 
+{-
 ************************************************************************
 *                                                                      *
-\subsection{Strictness stuff}
+\subsection{Unboxing Decision for Strictness and CPR}
 *                                                                      *
 ************************************************************************
 -}
 
-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
-  = go args
-  where
-    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg
-
-    go []           = return (False, [], nop_fn, nop_fn)
-    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg
-                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args
-                         ; return ( useful1 || useful2
-                                  , args1 ++ args2
-                                  , wrap_fn1 . wrap_fn2
-                                  , work_fn1 . work_fn2) }
-
-{-
-Note [Unpacking arguments with product and polymorphic demands]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The argument is unpacked in a case if it has a product type and has a
-strict *and* used demand put on it. I.e., arguments, with demands such
-as the following ones:
-
-   <S,U(U, L)>
-   <S(L,S),U>
-
-will be unpacked, but
-
-   <S,U> or <B,U>
-
-will not, because the pieces aren't used. This is quite important otherwise
-we end up unpacking massive tuples passed to the bottoming function. Example:
-
-        f :: ((Int,Int) -> String) -> (Int,Int) -> a
-        f g pr = error (g pr)
-
-        main = print (f fst (1, error "no"))
-
-Does 'main' print "error 1" or "error no"?  We don't really want 'f'
-to unbox its second argument.  This actually happened in GHC's onwn
-source code, in Packages.applyPackageFlag, which ended up un-boxing
-the enormous DynFlags tuple, and being strict in the
-as-yet-un-filled-in unitState files.
--}
-
-----------------------
--- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
---   *  wrap_fn assumes wrap_arg is in scope,
---        brings into scope work_args (via cases)
---   * 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]
-            -> 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)
-
-  | isAbsDmd dmd
-  , Just work_fn <- mk_absent_let dflags fam_envs arg dmd
-     -- 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)
+-- | The information needed to build a pattern for a DataCon to be unboxed.
+-- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via
+-- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype
+-- wrappers.
+--
+-- If we get @DataConPatContext dc tys co@ for some type @ty@
+-- and @dataConRepInstPat ... dc tys = (exs, flds)@, then
+--
+--   * @dc @exs flds :: T tys@
+--   * @co :: T tys ~ ty@
+data DataConPatContext
+  = DataConPatContext
+  { dcpc_dc      :: !DataCon
+  , dcpc_tc_args :: ![Type]
+  , dcpc_co      :: !Coercion
+  }
 
-  | Just (cs, acdc) <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd
-  = unbox_one dflags fam_envs arg cs acdc
+-- | If @splitArgType_maybe ty = Just (dc, tys, co)@
+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
+-- and  @co :: ty ~ tc tys@
+-- where underscore prefixes are holes, e.g. yet unspecified.
+--
+-- 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 con <- tyConSingleAlgDataCon_maybe tc
+  = Just DataConPatContext { dcpc_dc      = con
+                           , dcpc_tc_args = tc_args
+                           , dcpc_co      = co }
+splitArgType_maybe _ _ = Nothing
 
-  | otherwise   -- Other cases
-  = return (False, [arg], nop_fn, nop_fn)
+-- | If @splitResultType_maybe n ty = Just (dc, tys, co)@
+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
+-- and  @co :: ty ~ tc tys@
+-- where underscore prefixes are holes, e.g. yet unspecified.
+-- @dc@ is the @n@th data constructor of @tc@.
+--
+-- 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
+  , 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
+                                 -- type constructor via a .hs-boot file (#8743)
+  , let con = cons `getNth` (con_tag - fIRST_TAG)
+  , null (dataConExTyCoVars con) -- no existentials;
+                                 -- See Note [Which types are unboxed?]
+                                 -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt
+                                 -- where we also check this.
+  , all isLinear (dataConInstArgTys con tc_args)
+  -- Deactivates CPR worker/wrapper splits on constructors with non-linear
+  -- arguments, for the moment, because they require unboxed tuple with variable
+  -- multiplicity fields.
+  = Just DataConPatContext { dcpc_dc = con
+                           , dcpc_tc_args = tc_args
+                           , dcpc_co = co }
+splitResultType_maybe _ _ _ = Nothing
 
-  where
-    arg_ty = idType arg
-    dmd    = idDemandInfo arg
+isLinear :: Scaled a -> Bool
+isLinear (Scaled w _ ) =
+  case w of
+    One -> True
+    _ -> False
 
-wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConPatContext)
+-- | Describes the outer shape of an argument to be unboxed or left as-is
+-- Depending on how @s@ is instantiated (e.g., 'Demand').
+data UnboxingDecision s
+  = StopUnboxing
+  -- ^ We ran out of strictness info. Leave untouched.
+  | 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'.
+
+wantToUnbox :: FamInstEnvs -> Bool -> 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
@@ -622,8 +617,10 @@ wantToUnbox fam_envs has_inlineable_prag ty dmd =
       , not (has_inlineable_prag && isClassPred ty)
       -- See Note [mkWWstr and unsafeCoerce]
       , cs `lengthIs` arity
-      -> Just (cs, dcpc)
-    _ -> Nothing
+      -- See Note [Add demands for strict constructors]
+      , let cs' = addDataConStrictness dc cs
+      -> Unbox dcpc cs'
+    _ -> StopUnboxing
   where
     split_prod_dmd_arity dmd arity
       -- For seqDmd, it should behave like <S(AAAA)>, for some
@@ -632,110 +629,96 @@ wantToUnbox fam_envs has_inlineable_prag ty dmd =
       | _ :* Prod ds <- dmd = Just ds
       | otherwise           = Nothing
 
-unbox_one :: DynFlags -> FamInstEnvs -> Var
-          -> [Demand]
-          -> DataConPatContext
-          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-unbox_one dflags fam_envs arg cs
-          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
-                            , dcpc_co = co }
-  = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM
-       ; let ex_name_fss     = map getOccFS $ dataConExTyCoVars dc
-             (ex_tvs', arg_ids) =
-               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args
-             -- See Note [Add demands for strict constructors]
-             cs'       = addDataConStrictness dc cs
-             arg_ids'  = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs'
-             unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq
-                                      dc (ex_tvs' ++ arg_ids')
-             arg_no_unf = zapStableUnfolding arg
-                          -- See Note [Zap unfolding when beta-reducing]
-                          -- 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')
-       ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
-                          -- Don't pass the arg, rebox instead
+{- Note [Which types are unboxed?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Worker/wrapper will unbox
 
-----------------------
-nop_fn :: CoreExpr -> CoreExpr
-nop_fn body = body
+  1. A strict data type argument, that
+       * is an algebraic data type (not a newtype)
+       * has a single constructor (thus is a "product")
+       * that may bind existentials
+     We can transform
+     > f (D @ex a b) = e
+     to
+     > $wf @ex a b = e
+     via 'mkWWstr'.
 
-addDataConStrictness :: DataCon -> [Demand] -> [Demand]
--- See Note [Add demands for strict constructors]
-addDataConStrictness con ds
-  = zipWithEqual "addDataConStrictness" add ds strs
-  where
-    strs = dataConRepStrictness con
-    add dmd str | isMarkedStrict str = strictifyDmd dmd
-                | otherwise          = dmd
+  2. The constructed result of a function, if
+       * its type is an algebraic data type (not a newtype)
+       * (might have multiple constructors, in contrast to (1))
+       * the applied data constructor *does not* bind existentials
+     We can transform
+     > f x y = let ... in D a b
+     to
+     > $wf x y = let ... in (# a, b #)
+     via 'mkWWcpr'.
 
-{- Note [How to do the worker/wrapper split]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The worker-wrapper transformation, mkWWstr_one, takes into account
-several possibilities to decide if the function is worthy for
-splitting:
+     NB: We don't allow existentials for CPR W/W, because we don't have unboxed
+     dependent tuples (yet?). Otherwise, we could transform
+     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)
+     to
+     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)
 
-1. If an argument is absent, it would be silly to pass it to
-   the worker.  Hence the isAbsDmd case.  This case must come
-   first because a demand like <S,A> or <B,A> is possible.
-   E.g. <B,A> comes from a function like
-       f x = error "urk"
-   and <S,A> can come from Note [Add demands for strict constructors]
+The respective tests are in 'splitArgType_maybe' and
+'splitResultType_maybe', respectively.
 
-2. If the argument is evaluated strictly, and we can split the
-   product demand (splitProdDmd_maybe), then unbox it and w/w its
-   pieces.  For example
+Note that the data constructor /can/ have evidence arguments: equality
+constraints, type classes etc.  So it can be GADT.  These evidence
+arguments are simply value arguments, and should not get in the way.
 
-    f :: (Int, Int) -> Int
-    f p = (case p of (a,b) -> a) + 1
-  is split to
-    f :: (Int, Int) -> Int
-    f p = case p of (a,b) -> $wf a
+Note [Unpacking arguments with product and polymorphic demands]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The argument is unpacked in a case if it has a product type and has a
+strict *and* used demand put on it. I.e., arguments, with demands such
+as the following ones:
 
-    $wf :: Int -> Int
-    $wf a = a + 1
+   <S,U(U, L)>
+   <S(L,S),U>
 
-  and
-    g :: Bool -> (Int, Int) -> Int
-    g c p = case p of (a,b) ->
-               if c then a else b
-  is split to
-   g c p = case p of (a,b) -> $gw c a b
-   $gw c a b = if c then a else b
+will be unpacked, but
 
-2a But do /not/ split if the components are not used; that is, the
-   usage is just 'Used' rather than 'UProd'. In this case
-   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing
-   a massive tuple which is barely used.  Example:
+   <S,U> or <B,U>
+
+will not, because the pieces aren't used. This is quite important otherwise
+we end up unpacking massive tuples passed to the bottoming function. Example:
 
         f :: ((Int,Int) -> String) -> (Int,Int) -> a
         f g pr = error (g pr)
 
         main = print (f fst (1, error "no"))
 
-   Here, f does not take 'pr' apart, and it's stupid to do so.
-   Imagine that it had millions of fields. This actually happened
-   in GHC itself where the tuple was DynFlags
+Does 'main' print "error 1" or "error no"?  We don't really want 'f'
+to unbox its second argument.  This actually happened in GHC's onwn
+source code, in Packages.applyPackageFlag, which ended up un-boxing
+the enormous DynFlags tuple, and being strict in the
+as-yet-un-filled-in unitState files.
 
-3. A plain 'seqDmd', which is head-strict with usage UHead, can't
-   be split by splitProdDmd_maybe.  But we want it to behave just
-   like U(AAAA) for suitable number of absent demands. So we have
-   a special case for it, with arity coming from the data constructor.
+Note [Do not unpack class dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+   f :: Ord a => [a] -> Int -> a
+   {-# INLINABLE f #-}
+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
+(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),
+which can still be specialised by the type-class specialiser, something like
+   fw :: Ord a => [a] -> Int# -> a
 
-Note [Worker-wrapper for bottoming functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used not to split if the result is bottom.
-[Justification:  there's no efficiency to be gained.]
+BUT if f is strict in the Ord dictionary, we might unpack it, to get
+   fw :: (a->a->Bool) -> [a] -> Int# -> a
+and the type-class specialiser can't specialise that. An example is #6056.
 
-But it's sometimes bad not to make a wrapper.  Consider
-        fw = \x# -> let x = I# x# in case e of
-                                        p1 -> error_fn x
-                                        p2 -> error_fn x
-                                        p3 -> the real stuff
-The re-boxing code won't go away unless error_fn gets a wrapper too.
-[We don't do reboxing now, but in general it's better to pass an
-unboxed thing to f, and have it reboxed in the error cases....]
+But in any other situation a dictionary is just an ordinary value,
+and can be unpacked.  So we track the INLINABLE pragma, and switch
+off the unpacking in mkWWstr_one (see the isClassPred test).
+
+Historical note: #14955 describes how I got this fix wrong the first time.
+
+Note [mkWWstr and unsafeCoerce]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+By using unsafeCoerce, it is possible to make the number of demands fail to
+match the number of constructor arguments; this happened in #8037.
+If so, the worker/wrapper split doesn't work right and we get a Core Lint
+bug.  The fix here is simply to decline to do w/w if that happens.
 
 Note [Add demands for strict constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -857,14 +840,183 @@ Consequently, we now instead account for data-con strictness in mkWWstr_one,
 applying the strictness demands to the final result of DmdAnal. The result is
 that we get the strict demand signature we wanted even if we can't float
 the case on `x` up through the case on `burble`.
+-}
 
+{-
+************************************************************************
+*                                                                      *
+\subsection{Strictness stuff}
+*                                                                      *
+************************************************************************
+-}
 
-Note [mkWWstr and unsafeCoerce]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-By using unsafeCoerce, it is possible to make the number of demands fail to
-match the number of constructor arguments; this happened in #8037.
-If so, the worker/wrapper split doesn't work right and we get a Core Lint
-bug.  The fix here is simply to decline to do w/w if that happens.
+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
+  = go args
+  where
+    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg
+
+    go []           = return (False, [], nop_fn, nop_fn)
+    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg
+                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args
+                         ; return ( useful1 || useful2
+                                  , args1 ++ args2
+                                  , wrap_fn1 . wrap_fn2
+                                  , work_fn1 . work_fn2) }
+
+----------------------
+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
+--   *  wrap_fn assumes wrap_arg is in scope,
+--        brings into scope work_args (via cases)
+--   * 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]
+            -> 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)
+
+  | isAbsDmd dmd
+  , Just work_fn <- mk_absent_let dflags fam_envs arg dmd
+     -- 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
+
+  | otherwise   -- Other cases
+  = return (False, [arg], nop_fn, nop_fn)
+
+  where
+    arg_ty = idType arg
+    dmd    = idDemandInfo arg
+
+unbox_one :: DynFlags -> FamInstEnvs -> Var
+          -> [Demand]
+          -> DataConPatContext
+          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
+unbox_one dflags fam_envs arg cs
+          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
+                            , dcpc_co = co }
+  = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM
+       ; let ex_name_fss     = map getOccFS $ dataConExTyCoVars dc
+             (ex_tvs', arg_ids) =
+               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args
+             arg_ids'  = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs
+             unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq
+                                      dc (ex_tvs' ++ arg_ids')
+             arg_no_unf = zapStableUnfolding arg
+                          -- See Note [Zap unfolding when beta-reducing]
+                          -- 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')
+       ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
+                          -- Don't pass the arg, rebox instead
+
+----------------------
+nop_fn :: CoreExpr -> CoreExpr
+nop_fn body = body
+
+addDataConStrictness :: DataCon -> [Demand] -> [Demand]
+-- See Note [Add demands for strict constructors]
+addDataConStrictness con ds
+  | Nothing <- dataConWrapId_maybe con
+  -- DataCon worker=wrapper. Implies no strict fields, so nothing to do
+  = ds
+addDataConStrictness con ds
+  = zipWithEqual "addDataConStrictness" add ds strs
+  where
+    strs = dataConRepStrictness con
+    add dmd str | isMarkedStrict str = strictifyDmd dmd
+                | otherwise          = dmd
+
+{- Note [How to do the worker/wrapper split]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The worker-wrapper transformation, mkWWstr_one, takes into account
+several possibilities to decide if the function is worthy for
+splitting:
+
+1. If an argument is absent, it would be silly to pass it to
+   the worker.  Hence the isAbsDmd case.  This case must come
+   first because a demand like <S,A> or <B,A> is possible.
+   E.g. <B,A> comes from a function like
+       f x = error "urk"
+   and <S,A> can come from Note [Add demands for strict constructors]
+
+2. If the argument is evaluated strictly, and we can split the
+   product demand (splitProdDmd_maybe), then unbox it and w/w its
+   pieces.  For example
+
+    f :: (Int, Int) -> Int
+    f p = (case p of (a,b) -> a) + 1
+  is split to
+    f :: (Int, Int) -> Int
+    f p = case p of (a,b) -> $wf a
+
+    $wf :: Int -> Int
+    $wf a = a + 1
+
+  and
+    g :: Bool -> (Int, Int) -> Int
+    g c p = case p of (a,b) ->
+               if c then a else b
+  is split to
+   g c p = case p of (a,b) -> $gw c a b
+   $gw c a b = if c then a else b
+
+2a But do /not/ split if the components are not used; that is, the
+   usage is just 'Used' rather than 'UProd'. In this case
+   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing
+   a massive tuple which is barely used.  Example:
+
+        f :: ((Int,Int) -> String) -> (Int,Int) -> a
+        f g pr = error (g pr)
+
+        main = print (f fst (1, error "no"))
+
+   Here, f does not take 'pr' apart, and it's stupid to do so.
+   Imagine that it had millions of fields. This actually happened
+   in GHC itself where the tuple was DynFlags
+
+3. A plain 'seqDmd', which is head-strict with usage UHead, can't
+   be split by splitProdDmd_maybe.  But we want it to behave just
+   like U(AAAA) for suitable number of absent demands. So we have
+   a special case for it, with arity coming from the data constructor.
+
+Note [Worker-wrapper for bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used not to split if the result is bottom.
+[Justification:  there's no efficiency to be gained.]
+
+But it's sometimes bad not to make a wrapper.  Consider
+        fw = \x# -> let x = I# x# in case e of
+                                        p1 -> error_fn x
+                                        p2 -> error_fn x
+                                        p3 -> the real stuff
+The re-boxing code won't go away unless error_fn gets a wrapper too.
+[We don't do reboxing now, but in general it's better to pass an
+unboxed thing to f, and have it reboxed in the error cases....]
 
 Note [Record evaluated-ness in worker/wrapper]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -913,97 +1065,8 @@ to record that the relevant binder is evaluated.
          Type scrutiny that is specific to demand analysis
 *                                                                      *
 ************************************************************************
-
-Note [Do not unpack class dictionaries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have
-   f :: Ord a => [a] -> Int -> a
-   {-# INLINABLE f #-}
-and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
-(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),
-which can still be specialised by the type-class specialiser, something like
-   fw :: Ord a => [a] -> Int# -> a
-
-BUT if f is strict in the Ord dictionary, we might unpack it, to get
-   fw :: (a->a->Bool) -> [a] -> Int# -> a
-and the type-class specialiser can't specialise that. An example is #6056.
-
-But in any other situation a dictionary is just an ordinary value,
-and can be unpacked.  So we track the INLINABLE pragma, and switch
-off the unpacking in mkWWstr_one (see the isClassPred test).
-
-Historical note: #14955 describes how I got this fix wrong the first time.
 -}
 
--- | The result of 'splitArgType_maybe' and 'splitResultType_maybe'.
---
--- Both splits
---   * Take a type `ty`
---   * Succeed with (DataConPatContext dc tys co)
---     iff co :: T tys ~ ty
---     and `dc` is the appropriate DataCon of `T`
---     and `T` is suitable for the kind of split
---     (differs for strictness and CPR, see Note [Which types are unboxed?])
-data DataConPatContext
-  = DataConPatContext
-  { dcpc_dc        :: !DataCon
-  , dcpc_tc_args   :: ![Type]
-  , dcpc_co        :: !Coercion
-  }
-
--- | If @splitArgType_maybe ty = Just (dc, tys, co)@
--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
--- and  @co :: ty ~ tc tys@
--- where underscore prefixes are holes, e.g. yet unspecified.
---
--- 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 con <- tyConSingleAlgDataCon_maybe tc
-  = Just DataConPatContext { dcpc_dc      = con
-                           , dcpc_tc_args = tc_args
-                           , dcpc_co      = co }
-splitArgType_maybe _ _ = Nothing
-
--- | If @splitResultType_maybe n ty = Just (dc, tys, co)@
--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
--- and  @co :: ty ~ tc tys@
--- where underscore prefixes are holes, e.g. yet unspecified.
--- @dc@ is the @n@th data constructor of @tc@.
---
--- 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
-  , 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
-                                 -- type constructor via a .hs-boot file (#8743)
-  , let con = cons `getNth` (con_tag - fIRST_TAG)
-  , null (dataConExTyCoVars con) -- no existentials;
-                                 -- See Note [Which types are unboxed?]
-                                 -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt
-                                 -- where we also check this.
-  , all isLinear (dataConInstArgTys con tc_args)
-  -- Deactivates CPR worker/wrapper splits on constructors with non-linear
-  -- arguments, for the moment, because they require unboxed tuple with variable
-  -- multiplicity fields.
-  = Just DataConPatContext { dcpc_dc = con
-                           , dcpc_tc_args = tc_args
-                           , dcpc_co = co }
-splitResultType_maybe _ _ _ = Nothing
-
-isLinear :: Scaled a -> Bool
-isLinear (Scaled w _ ) =
-  case w of
-    One -> True
-    _ -> False
-
 findTypeShape :: FamInstEnvs -> Type -> TypeShape
 -- Uncover the arrow and product shape of a type
 -- The data type TypeShape is defined in GHC.Types.Demand
@@ -1062,43 +1125,7 @@ dubiousDataConInstArgTys dc tc_args = arg_tys
     subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs
     arg_tys  = map (substTy subst . scaledThing) (dataConRepArgTys dc)
 
-{- Note [Which types are unboxed?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Worker/wrapper will unbox
-
-  1. A strict data type argument, that
-       * is an algebraic data type (not a newtype)
-       * has a single constructor (thus is a "product")
-       * that may bind existentials
-     We can transform
-     > f (D @ex a b) = e
-     to
-     > $wf @ex a b = e
-     via 'mkWWstr'.
-
-  2. The constructed result of a function, if
-       * its type is an algebraic data type (not a newtype)
-       * (might have multiple constructors, in contrast to (1))
-       * the applied data constructor *does not* bind existentials
-     We can transform
-     > f x y = let ... in D a b
-     to
-     > $wf x y = let ... in (# a, b #)
-     via 'mkWWcpr'.
-
-     NB: We don't allow existentials for CPR W/W, because we don't have unboxed
-     dependent tuples (yet?). Otherwise, we could transform
-     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)
-     to
-     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)
-
-The respective tests are in 'splitArgType_maybe' and
-'splitResultType_maybe', respectively.
-
-Note that the data constructor /can/ have evidence arguments: equality
-constraints, type classes etc.  So it can be GADT.  These evidence
-arguments are simply value arguments, and should not get in the way.
-
+{-
 ************************************************************************
 *                                                                      *
 \subsection{CPR stuff}
@@ -1118,7 +1145,7 @@ left-to-right traversal of the result structure.
 mkWWcpr :: Bool
         -> FamInstEnvs
         -> Type                              -- function body type
-        -> CprResult                         -- CPR analysis results
+        -> Cpr                               -- CPR analysis results
         -> UniqSM (Bool,                     -- Is w/w'ing useful?
                    CoreExpr -> CoreExpr,     -- New wrapper
                    CoreExpr -> CoreExpr,     -- New worker
@@ -1131,12 +1158,13 @@ mkWWcpr opt_CprAnal fam_envs body_ty cpr
   | otherwise
   = case asConCpr cpr of
        Nothing      -> return (False, id, id, body_ty)  -- No CPR info
-       Just con_tag | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty
-                    -> mkWWcpr_help dcpc
-                    |  otherwise
-                       -- See Note [non-algebraic or open body type warning]
-                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
-                       return (False, id, id, body_ty)
+       Just (con_tag, _cprs)
+         | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty
+         -> mkWWcpr_help dcpc
+         |  otherwise
+         -- See Note [non-algebraic or open body type warning]
+         -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
+            return (False, id, id, body_ty)
 
 mkWWcpr_help :: DataConPatContext
              -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs
index 05bafe98bc..5bfc23eef6 100644
--- a/compiler/GHC/Data/Graph/UnVar.hs
+++ b/compiler/GHC/Data/Graph/UnVar.hs
@@ -17,7 +17,7 @@ equal to g, but twice as expensive and large.
 module GHC.Data.Graph.UnVar
     ( UnVarSet
     , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
-    , delUnVarSet
+    , extendUnVarSet, delUnVarSet
     , elemUnVarSet, isEmptyUnVarSet
     , UnVarGraph
     , emptyUnVarGraph
diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs
index a884091cef..29b28d23e2 100644
--- a/compiler/GHC/Types/Cpr.hs
+++ b/compiler/GHC/Types/Cpr.hs
@@ -1,61 +1,92 @@
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
--- | Types for the Constructed Product Result lattice. "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils"
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+-- | Types for the Constructed Product Result lattice.
+-- "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils"
 -- are its primary customers via 'GHC.Types.Id.idCprInfo'.
 module GHC.Types.Cpr (
-    CprResult, topCpr, botCpr, conCpr, asConCpr,
-    CprType (..), topCprType, botCprType, conCprType,
-    lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy,
-    CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig
+    Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr,
+    CprType (..), topCprType, botCprType, flatConCprType,
+    lubCprType, applyCprTy, abstractCprTy, trimCprTy,
+    UnpackConFieldsResult (..), unpackConFieldsCpr,
+    CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig
   ) where
 
 import GHC.Prelude
 
+import GHC.Core.DataCon
 import GHC.Types.Basic
-import GHC.Utils.Outputable
 import GHC.Utils.Binary
+import GHC.Utils.Misc
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
 
 --
--- * CprResult
+-- * Cpr
 --
 
--- | The constructed product result lattice.
---
--- @
---                    NoCPR
---                      |
---                 ConCPR ConTag
---                      |
---                    BotCPR
--- @
-data CprResult = NoCPR          -- ^ Top of the lattice
-               | ConCPR !ConTag -- ^ Returns a constructor from a data type
-               | BotCPR         -- ^ Bottom of the lattice
-               deriving( Eq, Show )
-
-lubCpr :: CprResult -> CprResult -> CprResult
-lubCpr (ConCPR t1) (ConCPR t2)
-  | t1 == t2               = ConCPR t1
-lubCpr BotCPR      cpr     = cpr
-lubCpr cpr         BotCPR  = cpr
-lubCpr _           _       = NoCPR
-
-topCpr :: CprResult
-topCpr = NoCPR
-
-botCpr :: CprResult
-botCpr = BotCPR
-
-conCpr :: ConTag -> CprResult
-conCpr = ConCPR
-
-trimCpr :: CprResult -> CprResult
-trimCpr ConCPR{} = NoCPR
-trimCpr cpr      = cpr
-
-asConCpr :: CprResult -> Maybe ConTag
-asConCpr (ConCPR t)  = Just t
-asConCpr NoCPR       = Nothing
-asConCpr BotCPR      = Nothing
+data Cpr
+  = BotCpr
+  | ConCpr_ !ConTag ![Cpr]
+  -- ^ The number of field Cprs equals 'dataConRepArity'.
+  -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern
+  -- synonym 'ConCpr'.
+  | FlatConCpr !ConTag
+  | TopCpr
+  deriving Eq
+
+pattern ConCpr :: ConTag -> [Cpr] -> Cpr
+pattern ConCpr t cs <- ConCpr_ t cs where
+  ConCpr t cs
+    | all (== TopCpr) cs = FlatConCpr t
+    | otherwise          = ConCpr_ t cs
+{-# COMPLETE BotCpr, TopCpr, FlatConCpr, ConCpr #-}
+
+viewConTag :: Cpr -> Maybe ConTag
+viewConTag (FlatConCpr t) = Just t
+viewConTag (ConCpr t _)   = Just t
+viewConTag _              = Nothing
+{-# INLINE viewConTag #-}
+
+lubCpr :: Cpr -> Cpr -> Cpr
+lubCpr BotCpr      cpr     = cpr
+lubCpr cpr         BotCpr  = cpr
+lubCpr (FlatConCpr t1) (viewConTag -> Just t2)
+  | t1 == t2 = FlatConCpr t1
+lubCpr (viewConTag -> Just t1) (FlatConCpr t2)
+  | t1 == t2 = FlatConCpr t2
+lubCpr (ConCpr t1 cs1) (ConCpr t2 cs2)
+  | t1 == t2 = ConCpr t1 (lubFieldCprs cs1 cs2)
+lubCpr _           _       = TopCpr
+
+lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]
+lubFieldCprs as bs
+  | as `equalLength` bs = zipWith lubCpr as bs
+  | otherwise           = []
+
+topCpr :: Cpr
+topCpr = TopCpr
+
+botCpr :: Cpr
+botCpr = BotCpr
+
+flatConCpr :: ConTag -> Cpr
+flatConCpr t = FlatConCpr t
+
+trimCpr :: Cpr -> Cpr
+trimCpr BotCpr = botCpr
+trimCpr _      = topCpr
+
+asConCpr :: Cpr -> Maybe (ConTag, [Cpr])
+asConCpr (ConCpr t cs)  = Just (t, cs)
+asConCpr (FlatConCpr t) = Just (t, [])
+asConCpr TopCpr         = Nothing
+asConCpr BotCpr         = Nothing
+
+seqCpr :: Cpr -> ()
+seqCpr (ConCpr _ cs) = foldr (seq . seqCpr) () cs
+seqCpr _             = ()
 
 --
 -- * CprType
@@ -64,10 +95,10 @@ asConCpr BotCPR      = Nothing
 -- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper.
 data CprType
   = CprType
-  { ct_arty :: !Arity     -- ^ Number of value arguments the denoted expression
-                          --   eats before returning the 'ct_cpr'
-  , ct_cpr  :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to
-                          --   'ct_arty' arguments
+  { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression
+                      --   eats before returning the 'ct_cpr'
+  , ct_cpr  :: !Cpr   -- ^ 'Cpr' eventually unleashed when applied to
+                      --   'ct_arty' arguments
   }
 
 instance Eq CprType where
@@ -78,10 +109,10 @@ topCprType :: CprType
 topCprType = CprType 0 topCpr
 
 botCprType :: CprType
-botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments
+botCprType = CprType 0 botCpr
 
-conCprType :: ConTag -> CprType
-conCprType con_tag = CprType 0 (conCpr con_tag)
+flatConCprType :: ConTag -> CprType
+flatConCprType con_tag = CprType { ct_arty = 0, ct_cpr = flatConCpr con_tag }
 
 lubCprType :: CprType -> CprType -> CprType
 lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)
@@ -104,14 +135,31 @@ abstractCprTy (CprType n res)
   | res == topCpr = topCprType
   | otherwise     = CprType (n+1) res
 
-ensureCprTyArity :: Arity -> CprType -> CprType
-ensureCprTyArity n ty@(CprType m _)
-  | n == m    = ty
-  | otherwise = topCprType
-
 trimCprTy :: CprType -> CprType
 trimCprTy (CprType arty res) = CprType arty (trimCpr res)
 
+-- | The result of 'unpackConFieldsCpr'.
+data UnpackConFieldsResult
+  = AllFieldsSame !Cpr
+  | ForeachField ![Cpr]
+
+-- | Unpacks a 'ConCpr'-shaped 'Cpr' and returns the field 'Cpr's wrapped in a
+-- 'ForeachField'. Otherwise, it returns 'AllFieldsSame' with the appropriate
+-- 'Cpr' to assume for each field.
+--
+-- The use of 'UnpackConFieldsResult' allows O(1) space for the common,
+-- non-'ConCpr' case.
+unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult
+unpackConFieldsCpr dc (ConCpr t cs)
+  | t == dataConTag dc, cs `lengthIs` dataConRepArity dc
+  = ForeachField cs
+unpackConFieldsCpr _  BotCpr = AllFieldsSame BotCpr
+unpackConFieldsCpr _  _      = AllFieldsSame TopCpr
+{-# INLINE unpackConFieldsCpr #-}
+
+seqCprTy :: CprType -> ()
+seqCprTy (CprType _ cpr) = seqCpr cpr
+
 -- | The arity of the wrapped 'CprType' is the arity at which it is safe
 -- to unleash. See Note [Understanding DmdType and StrictSig] in "GHC.Types.Demand"
 newtype CprSig = CprSig { getCprSig :: CprType }
@@ -121,21 +169,40 @@ newtype CprSig = CprSig { getCprSig :: CprType }
 -- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in
 -- "GHC.Types.Demand"
 mkCprSigForArity :: Arity -> CprType -> CprSig
-mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty)
+mkCprSigForArity arty ty@(CprType n cpr)
+  | arty /= n         = topCprSig
+      -- Trim on arity mismatch
+  | ConCpr t _ <- cpr = CprSig (CprType n (flatConCpr t))
+      -- Flatten nested CPR info, we don't exploit it (yet)
+  | otherwise         = CprSig ty
 
 topCprSig :: CprSig
 topCprSig = CprSig topCprType
 
-mkCprSig :: Arity -> CprResult -> CprSig
+isTopCprSig :: CprSig -> Bool
+isTopCprSig (CprSig ty) = ct_cpr ty == topCpr
+
+mkCprSig :: Arity -> Cpr -> CprSig
 mkCprSig arty cpr = CprSig (CprType arty cpr)
 
 seqCprSig :: CprSig -> ()
-seqCprSig sig = sig `seq` ()
-
-instance Outputable CprResult where
-  ppr NoCPR        = empty
-  ppr (ConCPR n)   = char 'm' <> int n
-  ppr BotCPR       = char 'b'
+seqCprSig (CprSig ty) = seqCprTy ty
+
+-- | BNF:
+-- ```
+--   cpr ::= ''                               -- TopCpr
+--        |  n                                -- FlatConCpr n
+--        |  n '(' cpr1 ',' cpr2 ',' ... ')'  -- ConCpr n [cpr1,cpr2,...]
+--        |  'b'                              -- BotCpr
+-- ```
+-- Examples:
+--   * `f x = f x` has denotation `b`
+--   * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`.
+instance Outputable Cpr where
+  ppr TopCpr         = empty
+  ppr (FlatConCpr n) = int n
+  ppr (ConCpr n cs)  = int n <> parens (pprWithCommas ppr cs)
+  ppr BotCpr         = char 'b'
 
 instance Outputable CprType where
   ppr (CprType arty res) = ppr arty <> ppr res
@@ -144,20 +211,20 @@ instance Outputable CprType where
 instance Outputable CprSig where
   ppr (CprSig ty) = ppr (ct_cpr ty)
 
-instance Binary CprResult where
-  put_ bh (ConCPR n)   = do { putByte bh 0; put_ bh n }
-  put_ bh NoCPR        = putByte bh 1
-  put_ bh BotCPR       = putByte bh 2
-
+instance Binary Cpr where
+  put_ bh TopCpr         = putByte bh 0
+  put_ bh BotCpr         = putByte bh 1
+  put_ bh (FlatConCpr n) = putByte bh 2 *> put_ bh n
+  put_ bh (ConCpr n cs)  = putByte bh 3 *> put_ bh n *> put_ bh cs
   get  bh = do
-          h <- getByte bh
-          case h of
-            0 -> do { n <- get bh; return (ConCPR n) }
-            1 -> return NoCPR
-            _ -> return BotCPR
+    h <- getByte bh
+    case h of
+      0 -> return TopCpr
+      1 -> return BotCpr
+      2 -> FlatConCpr <$> get bh
+      3 -> ConCpr <$> get bh <*> get bh
+      _ -> pprPanic "Binary Cpr: Invalid tag" (int (fromIntegral h))
 
 instance Binary CprType where
-  put_ bh (CprType arty cpr) = do
-    put_ bh arty
-    put_ bh cpr
-  get  bh = CprType <$> get bh <*> get bh
+  put_ bh (CprType arty cpr) = put_ bh arty *> put_ bh cpr
+  get  bh                    = CprType <$> get bh <*> get bh
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 092ba18324..36a2c9d1df 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -610,14 +610,14 @@ mkDataConWorkId wkr_name data_con
                    mkLams univ_tvs $ Lam id_arg1 $
                    wrapNewTypeBody tycon res_ty_args (Var id_arg1)
 
-dataConCPR :: DataCon -> CprResult
+dataConCPR :: DataCon -> Cpr
 dataConCPR con
   | isDataTyCon tycon     -- Real data types only; that is,
                           -- not unboxed tuples or newtypes
   , null (dataConExTyCoVars con)  -- No existentials
   , wkr_arity > 0
   , wkr_arity <= mAX_CPR_SIZE
-  = conCpr (dataConTag con)
+  = flatConCpr (dataConTag con)
   | otherwise
   = topCpr
   where
diff --git a/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr b/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
index 7f98fe0612..b837aeb8c5 100644
--- a/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
+++ b/testsuite/tests/cpranal/sigs/CaseBinderCPR.stderr
@@ -1,7 +1,6 @@
 
 ==================== Cpr signatures ====================
-CaseBinderCPR.$trModule:
 CaseBinderCPR.f_list_cmp:
-CaseBinderCPR.g: m1
+CaseBinderCPR.g: 1
 
 
diff --git a/testsuite/tests/cpranal/sigs/T19232.stderr b/testsuite/tests/cpranal/sigs/T19232.stderr
index 3aa701833b..59fa00d7e6 100644
--- a/testsuite/tests/cpranal/sigs/T19232.stderr
+++ b/testsuite/tests/cpranal/sigs/T19232.stderr
@@ -1,6 +1,5 @@
 
 ==================== Cpr signatures ====================
-T19232.$trModule:
 T19232.f:
 
 
diff --git a/testsuite/tests/cpranal/sigs/T19398.hs b/testsuite/tests/cpranal/sigs/T19398.hs
new file mode 100644
index 0000000000..e0347fd502
--- /dev/null
+++ b/testsuite/tests/cpranal/sigs/T19398.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE BangPatterns #-}
+
+module T19398 where
+
+data T a = MkT !a !a
+
+f :: T a -> T a
+f (MkT a b) = MkT b a
+{-# NOINLINE f #-}
+
+-- | Should *not* have the CPR property, even though the scrutinee is a
+-- variable with the CPR property. It shows how Test (A) of
+-- Historical Note [Optimistic field binder CPR] is unsound.
+a :: Int -> Int
+a n
+  | n == 0    = n
+  | even n    = case q of MkT x y -> if x == y then x else y
+  | otherwise = case q of MkT x y -> if x == y then y else x
+  where
+    q = f $ f $ f $ f $ f $ f $ f $ MkT n n
+
+-- | Should not have the CPR property, because 'x' will not be unboxed.
+-- It shows how Test (C) of Historical Note [Optimistic field binder CPR] is
+-- unsound.
+c :: (Int, Int) -> Int
+c (x,_) = x
+
+-- | An interesting artifact is that the following function has the Nested CPR
+-- property, and we could in theory exploit that:
+g :: (Int, Int) -> (Int, Int)
+g p@(!x, !y) | x == y = error "blah"
+g p                   = p
diff --git a/testsuite/tests/cpranal/sigs/T19398.stderr b/testsuite/tests/cpranal/sigs/T19398.stderr
new file mode 100644
index 0000000000..a293fdd089
--- /dev/null
+++ b/testsuite/tests/cpranal/sigs/T19398.stderr
@@ -0,0 +1,8 @@
+
+==================== Cpr signatures ====================
+T19398.a:
+T19398.c:
+T19398.f: 1
+T19398.g: 1
+
+
diff --git a/testsuite/tests/cpranal/sigs/all.T b/testsuite/tests/cpranal/sigs/all.T
index f5ac233a8c..0647c8a611 100644
--- a/testsuite/tests/cpranal/sigs/all.T
+++ b/testsuite/tests/cpranal/sigs/all.T
@@ -3,7 +3,8 @@
 setTestOpts(only_ways(['optasm']))
 # This directory contains tests where we annotate functions with expected
 # CPR signatures, and verify that these are actually those found by the compiler
-setTestOpts(extra_hc_opts('-ddump-cpr-signatures'))
+setTestOpts(extra_hc_opts('-dno-typeable-binds -ddump-cpr-signatures'))
 
 test('CaseBinderCPR', normal, compile, [''])
 test('T19232', normal, compile, [''])
+test('T19398', normal, compile, [''])
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 69f40310b4..8b3f8a53b6 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -7,7 +7,7 @@ Result size of Tidy Core
 T2431.$WRefl [InlPrag=INLINE[final] CONLIKE] :: forall a. a :~: a
 [GblId[DataConWrapper],
  Caf=NoCafRefs,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index 889b8f48f8..ad3878e35a 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -44,7 +44,7 @@ dr :: Double -> Double
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
@@ -61,7 +61,7 @@ dl :: Double -> Double
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
@@ -72,7 +72,7 @@ fr :: Float -> Float
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
@@ -91,7 +91,7 @@ fl :: Float -> Float
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr
index ec423d7b4a..86094fe7d9 100644
--- a/testsuite/tests/simplCore/should_compile/T13143.stderr
+++ b/testsuite/tests/simplCore/should_compile/T13143.stderr
@@ -90,7 +90,7 @@ g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int
 [GblId,
  Arity=3,
  Str=<1L><1L><1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/simplCore/should_compile/T13543.stderr b/testsuite/tests/simplCore/should_compile/T13543.stderr
index 32e34ea559..90bda9792f 100644
--- a/testsuite/tests/simplCore/should_compile/T13543.stderr
+++ b/testsuite/tests/simplCore/should_compile/T13543.stderr
@@ -8,8 +8,8 @@ Foo.g: <1P(1P(L),1P(L))>
 
 ==================== Cpr signatures ====================
 Foo.$trModule:
-Foo.f: m1
-Foo.g: m1
+Foo.f: 1
+Foo.g: 1
 
 
 
diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr
index 69b1766a84..f33b8ec401 100644
--- a/testsuite/tests/simplCore/should_compile/T3717.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3717.stderr
@@ -57,7 +57,7 @@ foo [InlPrag=[2]] :: Int -> Int
 [GblId,
  Arity=1,
  Str=<1P(1L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index 04e065f51c..66d257897e 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -57,7 +57,7 @@ foo [InlPrag=[2]] :: Int -> Int
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 0b45e8a390..fe869c7c40 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -9,7 +9,7 @@ T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo
  Arity=1,
  Caf=NoCafRefs,
  Str=<SL>,
- Cpr=m3,
+ Cpr=3,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
@@ -36,7 +36,7 @@ fun2 :: forall {a}. [a] -> ((), Int)
 [GblId,
  Arity=1,
  Str=<ML>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index 683ff4d6ac..319eba03cb 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -112,7 +112,7 @@ Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int
 [GblId,
  Arity=2,
  Str=<1L><1L>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
@@ -144,7 +144,7 @@ foo :: Int -> Int
 [GblId,
  Arity=1,
  Str=<1P(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
diff --git a/testsuite/tests/stranal/should_compile/T10694.stderr b/testsuite/tests/stranal/should_compile/T10694.stderr
index 29b6e9e816..481c350fc2 100644
--- a/testsuite/tests/stranal/should_compile/T10694.stderr
+++ b/testsuite/tests/stranal/should_compile/T10694.stderr
@@ -30,7 +30,7 @@ pm [InlPrag=[final]] :: Int -> Int -> (Int, Int)
 [GblId,
  Arity=2,
  Str=<LP(L)><LP(L)>,
- Cpr=m1,
+ Cpr=1,
  Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True,
          Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
          Tmpl= \ (w [Occ=Once1] :: Int) (w1 [Occ=Once1] :: Int) ->
diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
index 7b954564a7..c1fa7f22e6 100644
--- a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
+++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr
@@ -8,7 +8,7 @@ BottomFromInnerLambda.f: <1P(SL)>
 
 ==================== Cpr signatures ====================
 BottomFromInnerLambda.$trModule:
-BottomFromInnerLambda.expensive: m1
+BottomFromInnerLambda.expensive: 1
 BottomFromInnerLambda.f:
 
 
diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
index 8f70d7d5e0..4cbc565ee2 100644
--- a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
+++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr
@@ -20,10 +20,10 @@ DmdAnalGADTs.$tcD:
 DmdAnalGADTs.$trModule:
 DmdAnalGADTs.diverges: b
 DmdAnalGADTs.f:
-DmdAnalGADTs.f': m1
+DmdAnalGADTs.f': 1
 DmdAnalGADTs.g:
 DmdAnalGADTs.hasCPR:
-DmdAnalGADTs.hasStrSig: m1
+DmdAnalGADTs.hasStrSig: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/HyperStrUse.stderr b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
index e8a806e4ad..09829ae4fa 100644
--- a/testsuite/tests/stranal/sigs/HyperStrUse.stderr
+++ b/testsuite/tests/stranal/sigs/HyperStrUse.stderr
@@ -7,7 +7,7 @@ HyperStrUse.f: <1P(1P(L),A)><1L>
 
 ==================== Cpr signatures ====================
 HyperStrUse.$trModule:
-HyperStrUse.f: m1
+HyperStrUse.f: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/NewtypeArity.stderr b/testsuite/tests/stranal/sigs/NewtypeArity.stderr
index 5a73b53524..66a810f5a5 100644
--- a/testsuite/tests/stranal/sigs/NewtypeArity.stderr
+++ b/testsuite/tests/stranal/sigs/NewtypeArity.stderr
@@ -12,8 +12,8 @@ Test.t2: <1P(L)><1P(L)>
 Test.$tc'MkT:
 Test.$tcT:
 Test.$trModule:
-Test.t: m1
-Test.t2: m1
+Test.t: 1
+Test.t2: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/T12370.stderr b/testsuite/tests/stranal/sigs/T12370.stderr
index d557b437b1..ac5eb53888 100644
--- a/testsuite/tests/stranal/sigs/T12370.stderr
+++ b/testsuite/tests/stranal/sigs/T12370.stderr
@@ -8,8 +8,8 @@ T12370.foo: <1P(1P(L),1P(L))>
 
 ==================== Cpr signatures ====================
 T12370.$trModule:
-T12370.bar: m1
-T12370.foo: m1
+T12370.bar: 1
+T12370.foo: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/T18957.stderr b/testsuite/tests/stranal/sigs/T18957.stderr
index 2beea34dfb..6795bf0dab 100644
--- a/testsuite/tests/stranal/sigs/T18957.stderr
+++ b/testsuite/tests/stranal/sigs/T18957.stderr
@@ -14,7 +14,7 @@ T18957.$trModule:
 T18957.g:
 T18957.h1:
 T18957.h2:
-T18957.h3: m1
+T18957.h3: 1
 T18957.seq':
 
 
diff --git a/testsuite/tests/stranal/sigs/T8598.stderr b/testsuite/tests/stranal/sigs/T8598.stderr
index 9f49534945..db7c97f807 100644
--- a/testsuite/tests/stranal/sigs/T8598.stderr
+++ b/testsuite/tests/stranal/sigs/T8598.stderr
@@ -7,7 +7,7 @@ T8598.fun: <1P(L)>
 
 ==================== Cpr signatures ====================
 T8598.$trModule:
-T8598.fun: m1
+T8598.fun: 1
 
 
 
diff --git a/testsuite/tests/stranal/sigs/UnsatFun.stderr b/testsuite/tests/stranal/sigs/UnsatFun.stderr
index 691fe21c98..b3ccac6f6e 100644
--- a/testsuite/tests/stranal/sigs/UnsatFun.stderr
+++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr
@@ -16,10 +16,10 @@ UnsatFun.$trModule:
 UnsatFun.f: b
 UnsatFun.g:
 UnsatFun.g':
-UnsatFun.g3: m1
+UnsatFun.g3: 1
 UnsatFun.h:
 UnsatFun.h2:
-UnsatFun.h3: m1
+UnsatFun.h3: 1